mirror/freebsd
1
0
Fork 0
mirror of https://git.FreeBSD.org/src.git synced 2024-12-02 08:42:48 +00:00
Code Issues Releases Activity

Maintenance releace 3 of perl5.005. Includes support for threads.

Browse Source
This commit is contained in:
Mark Murray 1999-05-02 14:33:17 +00:00
parent ff6b7ba98e
commit 7c312e6b6a
Notes: svn2git 2020-12-20 02:59:44 +00:00 
svn path=/vendor/perl5/dist/; revision=46307
418 changed files with 22758 additions and 4976 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3444
contrib/perl5/Changes
View File

File diff suppressed because it is too large Load Diff

801
contrib/perl5/Configure
View File

File diff suppressed because it is too large Load Diff

6
contrib/perl5/Copying
View File

@ -2,7 +2,7 @@
Version 1, February 1989
Copyright (C) 1989 Free Software Foundation, Inc.
675 Mass Ave, Cambridge, MA 02139, USA
59 Temple Place, Suite 330, Boston, MA 02111-1307, USA
Everyone is permitted to copy and distribute verbatim copies
of this license document, but changing it is not allowed.
@ -215,8 +215,8 @@ the exclusion of warranty; and each file should have at least the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
along with this program; if not, write to the Free Software Foundation,
Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307, USA.
Also add information on how to contact you by electronic and paper mail.

2
contrib/perl5/EXTERN.h
View File

@ -1,6 +1,6 @@
/* EXTERN.h
*
* Copyright (c) 1991-1997, Larry Wall
* Copyright (c) 1991-1999, Larry Wall
*
* You may distribute under the terms of either the GNU General Public
* License or the Artistic License, as specified in the README file.

141
contrib/perl5/INSTALL
View File

@ -64,6 +64,23 @@ In a related issue, old extensions may possibly be affected by the
changes in the Perl language in the current release. Please see
pod/perldelta.pod for a description of what's changed.
=head1 WARNING: This version requires a compiler that supports ANSI C.
If you find that your C compiler is not ANSI-capable, try obtaining
GCC, available from GNU mirrors worldwide (e.g. ftp://ftp.gnu.org/pub/gnu).
Another alternative may be to use a tool like C<ansi2knr> to convert the
sources back to K&R style, but there is no guarantee this route will get
you anywhere, since the prototypes are not the only ANSI features used
in the Perl sources. C<ansi2knr> is usually found as part of the freely
available C<Ghostscript> distribution. Another similar tool is
C<unprotoize>, distributed with GCC. Since C<unprotoize> requires GCC to
run, you may have to run it on a platform where GCC is available, and move
the sources back to the platform without GCC.
If you succeed in automatically converting the sources to a K&R compatible
form, be sure to email perlbug@perl.com to let us know the steps you
followed. This will enable us to officially support this option.
=head1 Space Requirements
The complete perl5 source tree takes up about 10 MB of disk space. The
@ -167,6 +184,9 @@ put (symlinks to) perl and its accompanying utilities, such as perldoc,
into a directory typically found along a user's PATH, or in another
obvious and convenient place.
You can use "Configure -Uinstallusrbinperl" which causes installperl
to skip installing perl also as /usr/bin/perl.
By default, Configure will compile perl to use dynamic loading if
your system supports it. If you want to force perl to be compiled
statically, you can either choose this when Configure prompts you or
@ -472,23 +492,26 @@ that problem.
If you need to install perl on many identical systems, it is
convenient to compile it once and create an archive that can be
installed on multiple systems. Here's one way to do that:
installed on multiple systems. Suppose, for example, that you want to
create an archive that can be installed in /opt/perl.
Here's one way to do that:
# Set up config.over to install perl into a different directory,
# e.g. /tmp/perl5 (see previous part).
sh Configure -des
sh Configure -Dprefix=/opt/perl -des
make
make test
make install
make install # This will install everything into /tmp/perl5.
cd /tmp/perl5
# Edit $archlib/Config.pm to change all the
# Edit $archlib/Config.pm and $archlib/.packlist to change all the
# install* variables back to reflect where everything will
# really be installed.
# Edit any of the scripts in $scriptdir to have the correct
# really be installed. (That is, change /tmp/perl5 to /opt/perl
# everywhere in those files.)
# Check the scripts in $scriptdir to make sure they have the correct
# #!/wherever/perl line.
tar cvf ../perl5-archive.tar .
# Then, on each machine where you want to install perl,
cd /usr/local # Or wherever you specified as $prefix
cd /opt/perl # Or wherever you specified as $prefix
tar xvf perl5-archive.tar
=head2 Site-wide Policy settings
@ -518,8 +541,9 @@ some of the main things you can change.
=head2 Threads
On some platforms, perl5.005 can be compiled to use threads. To
enable this, read the file README.threads, and then try
On some platforms, perl5.005 can be compiled with experimental support
for threads. To enable this, read the file README.threads, and then
try:
sh Configure -Dusethreads
@ -653,9 +677,24 @@ You can elect to build a shared libperl by
sh Configure -Duseshrplib
To actually build perl, you must add the current working directory to your
LD_LIBRARY_PATH environment variable before running make. You can do
this with
To build a shared libperl, the environment variable controlling shared
library search (LD_LIBRARY_PATH in most systems, DYLD_LIBRARY_PATH for
NeXTSTEP/OPENSTEP, LIBRARY_PATH for BeOS) must be set up to include
the Perl build directory because that's where the shared libperl will
be created. Configure arranges Makefile to have the correct shared
library search settings.
However, there are some special cases where manually setting the
shared library path might be required. For example, if you want to run
something like the following with the newly-built but not-yet-installed
./perl:
cd t; ./perl misc/failing_test.t
or
./perl -Ilib ~/my_mission_critical_test
then you need to set up the shared library path explicitly.
You can do this with
LD_LIBRARY_PATH=`pwd`:$LD_LIBRARY_PATH; export LD_LIBRARY_PATH
@ -663,9 +702,13 @@ for Bourne-style shells, or
setenv LD_LIBRARY_PATH `pwd`
for Csh-style shells. You *MUST* do this before running make.
Folks running NeXT OPENSTEP must substitute DYLD_LIBRARY_PATH for
LD_LIBRARY_PATH above.
for Csh-style shells. (This procedure may also be needed if for some
unexpected reason Configure fails to set up Makefile correctly.)
You can often recognize failures to build/use a shared libperl from error
messages complaining about a missing libperl.so (or libperl.sl in HP-UX),
for example:
18126:./miniperl: /sbin/loader: Fatal Error: cannot map libperl.so
There is also an potential problem with the shared perl library if you
want to have more than one "flavor" of the same version of perl (e.g.
@ -771,21 +814,6 @@ you can change a number of factors in the way perl is built
by adding appropriate -D directives to your ccflags variable in
config.sh.
For example, you can replace the rand() and srand() functions in the
perl source by any other random number generator by a trick such as the
following (this should all be on one line):
sh Configure -Dccflags='-Dmy_rand=random -Dmy_srand=srandom' \
-Drandbits=31
or you can use the drand48 family of functions with
sh Configure -Dccflags='-Dmy_rand=lrand48 -Dmy_srand=srand48' \
-Drandbits=31
or by adding the -D flags to your ccflags at the appropriate Configure
prompt. (Read pp.c to see how this works.)
You should also run Configure interactively to verify that a hint file
doesn't inadvertently override your ccflags setting. (Hints files
shouldn't do that, but some might.)
@ -920,6 +948,42 @@ to config.h and edit the config.h to reflect your system's peculiarities.
You'll probably also have to extensively modify the extension building
mechanism.
=item Environment variable clashes
Configure uses a CONFIG variable that is reported to cause trouble on
ReliantUnix 5.44. If your system sets this variable, you can try
unsetting it before you run Configure. Configure should eventually
be fixed to avoid polluting the namespace of the environment.
=item Digital UNIX/Tru64 UNIX and BIN_SH
In Digital UNIX/Tru64 UNIX Configure might abort with
Build a threading Perl? [n]
Configure[2437]: Syntax error at line 1 : `config.sh' is not expected.
This indicates that Configure is being run with a broken Korn shell
(even though you think you are using a Bourne shell by using
"sh Configure" or "./Configure"). The Korn shell bug has been reported
to Compaq as of February 1999 but in the meanwhile, the reason ksh is
being used is that you have the environment variable BIN_SH set to
'xpg4'. This causes /bin/sh to delegate its duties to /bin/posix/sh
(a ksh). Unset the environment variable and rerun Configure.
=item HP-UX 11, pthreads, and libgdbm
If you are running Configure with -Dusethreads in HP-UX 11, be warned
that POSIX threads and libgdbm (the GNU dbm library) compiled before
HP-UX 11 do not mix. This will cause a basic test run by Configure to
fail
Pthread internal error: message: __libc_reinit() failed, file: ../pthreads/pthread.c, line: 1096
Return Pointer is 0xc082bf33
sh: 5345 Quit(coredump)
and Configure will give up. The cure is to recompile and install
libgdbm under HP-UX 11.
=item Porting information
Specific information for the OS/2, Plan9, VMS and Win32 ports is in the
@ -1218,6 +1282,17 @@ ones (which ones these are depends on your system and applications)
with "ipcrm -s SEMAPHORE_ID_HERE" or configure more semaphores to your
system.
=item GNU binutils
If you mix GNU binutils (nm, ld, ar) with equivalent vendor-supplied
tools you may be in for some trouble. For example creating archives
with an old GNU 'ar' and then using a new current vendor-supplied 'ld'
may lead into linking problems. Either recompile your GNU binutils
under your current operating system release, or modify your PATH not
to include the GNU utils before running Configure, or specify the
vendor-supplied utilities explicitly to Configure, for example by
Configure -Dar=/bin/ar.
=item Miscellaneous
Some additional things that have been reported for either perl4 or perl5:
@ -1236,6 +1311,12 @@ If you get syntax errors on '(', try -DCRIPPLED_CC.
Machines with half-implemented dbm routines will need to #undef I_ODBM
HP-UX 11 Y2K patch "Y2K-1100 B.11.00.B0125 HP-UX Core OS Year 2000
Patch Bundle" has been reported to break the io/fs test #18 which
tests whether utime() can change timestamps. The Y2K patch seems to
break utime() so that over NFS the timestamps do not get changed
(on local filesystems utime() still works).
=back
=head1 make test

2
contrib/perl5/INTERN.h
View File

@ -1,6 +1,6 @@
/* INTERN.h
*
* Copyright (c) 1991-1997, Larry Wall
* Copyright (c) 1991-1999, Larry Wall
*
* You may distribute under the terms of either the GNU General Public
* License or the Artistic License, as specified in the README file.

56
contrib/perl5/MANIFEST
View File

@ -29,9 +29,13 @@ Porting/patchls Flexible patch file listing utility
Porting/pumpkin.pod Guidelines and hints for Perl maintainers
README The Instructions
README.amiga Notes about AmigaOS port
README.apollo Notes about Apollo DomainOS port
README.beos Notes about BeOS port
README.cygwin32 Notes about Cygwin32 port
README.dos Notes about dos/djgpp port
README.hpux Notes about HP-UX port
README.hurd Notes about GNU/Hurd port
README.mint Notes about Atari MiNT port
README.mpeix Notes about MPE/iX port
README.os2 Notes about OS/2 port
README.os390 Notes about OS/390 (nee MVS) port
@ -39,11 +43,13 @@ README.plan9 Notes about Plan9 port
README.qnx Notes about QNX port
README.threads Notes about multithreading
README.vms Notes about VMS port
README.vos Notes about Stratus VOS port
README.win32 Notes about Win32 port
Todo The Wishlist
Todo-5.005 What needs doing before 5.005 release
XSlock.h Include file for extensions built with PERL_OBJECT defined
XSUB.h Include file for extension subroutines
apollo/netinet/in.h Apollo DomainOS port: C header file frontend
av.c Array value code
av.h Array value header
beos/nm.c BeOS port
@ -65,8 +71,8 @@ cygwin32/ld2 Cygwin32 port
cygwin32/perlgcc Cygwin32 port
cygwin32/perlld Cygwin32 port
deb.c Debugging routines
djgpp/config.over DOS/DJGPP port
djgpp/configure.bat DOS/DJGPP port
djgpp/config.over DOS/DJGPP port
djgpp/configure.bat DOS/DJGPP port
djgpp/djgpp.c DOS/DJGPP port
djgpp/djgppsed.sh DOS/DJGPP port
djgpp/fixpmain DOS/DJGPP port
@ -185,6 +191,7 @@ ext/DB_File/DB_File.xs Berkeley DB extension external subroutines
ext/DB_File/DB_File_BS Berkeley DB extension mkbootstrap fodder
ext/DB_File/Makefile.PL Berkeley DB extension makefile writer
ext/DB_File/dbinfo Berkeley DB database version checker
ext/DB_File/hints/dynixptx.pl Hints for DB_File for named architecture
ext/DB_File/typemap Berkeley DB extension interface types
ext/Data/Dumper/Changes Data pretty printer, changelog
ext/Data/Dumper/Dumper.pm Data pretty printer, module
@ -195,6 +202,7 @@ ext/DynaLoader/DynaLoader_pm.PL Dynamic Loader perl module
ext/DynaLoader/Makefile.PL Dynamic Loader makefile writer
ext/DynaLoader/README Dynamic Loader notes and intro
ext/DynaLoader/dl_aix.xs AIX implementation
ext/DynaLoader/dl_beos.xs BeOS implementation
ext/DynaLoader/dl_cygwin32.xs Cygwin32 implementation
ext/DynaLoader/dl_dld.xs GNU dld style implementation
ext/DynaLoader/dl_dlopen.xs BSD/SunOS4&5 dlopen() style implementation
@ -213,6 +221,7 @@ ext/Fcntl/Makefile.PL Fcntl extension makefile writer
ext/GDBM_File/GDBM_File.pm GDBM extension Perl module
ext/GDBM_File/GDBM_File.xs GDBM extension external subroutines
ext/GDBM_File/Makefile.PL GDBM extension makefile writer
ext/GDBM_File/hints/sco.pl Hint for GDBM_File for named architecture
ext/GDBM_File/typemap GDBM extension interface types
ext/IO/IO.pm Top-level interface to IO::* classes
ext/IO/IO.xs IO extension external subroutines
@ -262,8 +271,10 @@ ext/POSIX/POSIX.pm POSIX extension Perl module
ext/POSIX/POSIX.pod POSIX extension documentation
ext/POSIX/POSIX.xs POSIX extension external subroutines
ext/POSIX/hints/bsdos.pl Hint for POSIX for named architecture
ext/POSIX/hints/dynixptx.pl Hint for POSIX for named architecture
ext/POSIX/hints/freebsd.pl Hint for POSIX for named architecture
ext/POSIX/hints/linux.pl Hint for POSIX for named architecture
ext/POSIX/hints/mint.pl Hint for POSIX for named architecture
ext/POSIX/hints/netbsd.pl Hint for POSIX for named architecture
ext/POSIX/hints/next_3.pl Hint for POSIX for named architecture
ext/POSIX/hints/openbsd.pl Hint for POSIX for named architecture
@ -380,6 +391,7 @@ hints/esix4.sh Hints for named architecture
hints/fps.sh Hints for named architecture
hints/freebsd.sh Hints for named architecture
hints/genix.sh Hints for named architecture
hints/gnu.sh Hints for named architecture
hints/greenhills.sh Hints for named architecture
hints/hpux.sh Hints for named architecture
hints/i386.sh Hints for named architecture
@ -394,6 +406,7 @@ hints/linux.sh Hints for named architecture
hints/lynxos.sh Hints for named architecture
hints/machten.sh Hints for named architecture
hints/machten_2.sh Hints for named architecture
hints/mint.sh Hints for named architecture
hints/mips.sh Hints for named architecture
hints/mpc.sh Hints for named architecture
hints/mpeix.sh Hints for named architecture
@ -429,12 +442,12 @@ hints/unicosmk.sh Hints for named architecture
hints/unisysdynix.sh Hints for named architecture
hints/utekv.sh Hints for named architecture
hints/uts.sh Hints for named architecture
hints/uwin.sh Hints for named architecture
hv.c Hash value code
hv.h Hash value header
installhtml Perl script to install html files for pods
installman Perl script to install man pages for pods
installperl Perl script to do "make install" dirty work
interp.sym Interpreter specific symbols to hide in a struct
intrpvar.h Variables held in each interpreter instance
iperlsys.h Perl's interface to the system
keywords.h The keyword numbers
@ -456,8 +469,9 @@ lib/CPAN/Nox.pm Runs CPAN while avoiding compiled extensions
lib/Carp.pm Error message base class
lib/Class/Struct.pm Declare struct-like datatypes as Perl classes
lib/Cwd.pm Various cwd routines (getcwd, fastcwd, chdir)
lib/Devel/SelfStubber.pm Generate stubs for SelfLoader.pm
lib/Devel/SelfStubber.pm Generate stubs for SelfLoader.pm
lib/DirHandle.pm like FileHandle only for directories
lib/Dumpvalue.pm Screen dump of perl values
lib/English.pm Readable aliases for short variables
lib/Env.pm Map environment into ordinary variables
lib/Exporter.pm Exporter base class
@ -553,7 +567,7 @@ lib/bigint.pl An arbitrary precision integer arithmetic package
lib/bigrat.pl An arbitrary precision rational arithmetic package
lib/blib.pm For "use blib"
lib/cacheout.pl Manages output filehandles when you need too many
lib/chat2.pl Obsolete ipc library (use Comm.pm etc instead)
lib/chat2.pl Obsolete ipc library (use Comm.pm etc instead)
lib/complete.pl A command completion subroutine
lib/constant.pm For "use constant"
lib/ctime.pl A ctime workalike
@ -602,6 +616,13 @@ mg.c Magic code
mg.h Magic header
minimod.pl Writes lib/ExtUtils/Miniperl.pm
miniperlmain.c Basic perl w/o dynamic loading or extensions
mint/errno.h MiNT port
mint/Makefile MiNT port
mint/pwd.c MiNT port
mint/README MiNT port
mint/stdio.h MiNT port
mint/sys/time.h MiNT port
mint/time.h MiNT port
mpeix/mpeixish.h MPE/iX port
mpeix/nm MPE/iX port
mpeix/relink MPE/iX port
@ -725,15 +746,18 @@ pod/perlmodinstall.pod Installing CPAN Modules
pod/perlmodlib.pod Module policy info
pod/perlobj.pod Object info
pod/perlop.pod Operator info
pod/perlopentut.pod open() tutorial
pod/perlpod.pod Pod info
pod/perlport.pod Portability guide
pod/perlre.pod Regular expression info
pod/perlref.pod References info
pod/perlreftut.pod References tutorial
pod/perlrun.pod Execution info
pod/perlsec.pod Security info
pod/perlstyle.pod Style info
pod/perlsub.pod Subroutine info
pod/perlsyn.pod Syntax info
pod/perlthrtut.pod Threads tutorial
pod/perltie.pod Tieing an object class into a simple variable
pod/perltoc.pod Table of Contents info
pod/perltoot.pod Tom's object-oriented tutorial
@ -829,6 +853,7 @@ t/lib/dumper.t See if Data::Dumper works
t/lib/english.t See if English works
t/lib/env.t See if Env works
t/lib/errno.t See if Errno works
t/lib/fatal.t See if Fatal works
t/lib/fields.t See if base/fields works
t/lib/filecache.t See if FileCache works
t/lib/filecopy.t See if File::Copy works
@ -870,7 +895,8 @@ t/lib/socket.t See if Socket works
t/lib/soundex.t See if Soundex works
t/lib/symbol.t See if Symbol works
t/lib/texttabs.t See if Text::Tabs works
t/lib/textwrap.t See if Text::Wrap works
t/lib/textfill.t See if Text::Wrap::fill works
t/lib/textwrap.t See if Text::Wrap::wrap works
t/lib/thread.t Basic test of threading (skipped if no threads)
t/lib/tie-push.t Test for Tie::Array
t/lib/tie-stdarray.t Test for Tie::StdArray
@ -903,6 +929,7 @@ t/op/fork.t See if fork works
t/op/glob.t See if <*> works
t/op/goto.t See if goto works
t/op/goto_xs.t See if "goto &sub" works on XSUBs
t/op/grep.t See if grep() and map() work
t/op/groups.t See if $( works
t/op/gv.t See if typeglobs work
t/op/hashwarn.t See if warnings for bad hash assignments work
@ -938,7 +965,7 @@ t/op/repeat.t See if x operator works
t/op/runlevel.t See if die() works from perl_call_*()
t/op/sleep.t See if sleep works
t/op/sort.t See if sort works
t/op/splice.t See if splice works
t/op/splice.t See if splice works
t/op/split.t See if split works
t/op/sprintf.t See if sprintf works
t/op/stat.t See if stat works
@ -951,6 +978,7 @@ t/op/tie.t See if tie/untie functions work
t/op/tiearray.t See if tie for arrays works
t/op/tiehandle.t See if tie for handles works
t/op/time.t See if time functions work
t/op/tr.t See if tr works
t/op/undef.t See if undef works
t/op/universal.t See if UNIVERSAL class works
t/op/unshift.t See if unshift works
@ -1006,19 +1034,29 @@ vms/genconfig.pl retcon config.sh from config.h
vms/genopt.com hack to write options files in case of broken makes
vms/make_command.com record MM[SK] command used to build Perl
vms/mms2make.pl convert descrip.mms to make syntax
vms/munchconfig.c performs shell $var substitution for VMS
vms/munchconfig.c performs shell $var substitution for VMS
vms/myconfig.com record local configuration info for bug report
vms/perlvms.pod VMS-specific additions to Perl documentation
vms/perly_c.vms perly.c with fixed declarations for global syms
vms/perly_h.vms perly.h with fixed declarations for global syms
vms/sockadapt.c glue for SockshShr socket support
vms/sockadapt.h glue for SockshShr socket support
vms/subconfigure.com performs compiler checks and writes config.sh, config.h, and descrip.mms
vms/subconfigure.com performs compiler checks and writes config.sh, config.h, and descrip.mms
vms/test.com DCL driver for regression tests
vms/vms.c VMS-specific C code for Perl core
vms/vms_yfix.pl convert Unix perly.[ch] to VMS perly_[ch].vms
vms/vmsish.h VMS-specific C header for Perl core
vms/writemain.pl Generate perlmain.c from miniperlmain.c+extensions
vos/build.cm VOS command macro to build Perl
vos/Changes Changes made to port Perl to the VOS operating system
vos/compile_perl.cm VOS commnad macro to build multiple version of Perl
vos/config.h config.h for VOS
vos/config_h.SH_orig config_h.SH at the time config.h was created
vos/perl.bind VOS bind control file
vos/test_vos_dummies.c Test program for "vos_dummies.c"
vos/vos_accept.c Wrapper to fixup nonstandard VOS _accept function
vos/vos_dummies.c Wrappers to soak up undefined functions
vos/vosish.h VOS-specific header file
win32/GenCAPI.pl Win32 port for C API with PERL_OBJECT
win32/Makefile Win32 makefile for NMAKE (Visual C++ build)
win32/TEST Win32 port

87
contrib/perl5/Makefile.SH
View File

@ -43,12 +43,17 @@ true)
# NeXT uses a different name.
ldlibpth="DYLD_LIBRARY_PATH=`pwd`:$DYLD_LIBRARY_PATH"
;;
beos*) ldlibpth="LIBRARY_PATH=`pwd`:$LIBRARY_PATH"
;;
os2*) # OS/2 doesn't need anything special for LD_LIBRARY_PATH.
ldlibpth=''
;;
sunos*|freebsd[23]*|netbsd*)
sunos*)
linklibperl="-lperl"
;;
netbsd*|freebsd[234]*)
linklibperl="-L. -lperl"
;;
aix*)
shrpldflags="-H512 -T512 -bhalt:4 -bM:SRE -bE:perl.exp"
case "$osvers" in
@ -161,7 +166,7 @@ shellflags = $shellflags
$make_set_make
# These variables may need to be manually set for non-Unix systems.
AR = $ar
AR = $full_ar
EXE_EXT = $_exe
LIB_EXT = $_a
OBJ_EXT = $_o
@ -450,14 +455,15 @@ perly.h: perly.y
-@sh -c true
# No compat3.sym here since and including the 5.004_50.
SYM = global.sym interp.sym perlio.sym thread.sym
# No interp.sym since 5.005_03.
SYM = global.sym perlio.sym thread.sym
SYMH = perlvars.h thrdvar.h
# The following files are generated automatically
# keywords.h: keywords.pl
# opcode.h: opcode.pl
# embed.h: embed.pl global.sym interp.sym
# embed.h: embed.pl global.sym
# byterun.h: bytecode.pl
# byterun.c: bytecode.pl
# lib/B/Asmdata.pm: bytecode.pl
@ -598,13 +604,13 @@ minitest: miniperl lib/re.pm
# Please *don't* use this unless all tests pass.
# If you want to report test failures, use "make nok" instead.
ok: utilities
$(LBLIBPTH) ./perl -Ilib utils/perlbug -ok -s '(UNINSTALLED)'
$(LDLIBPTH) ./perl -Ilib utils/perlbug -ok -s '(UNINSTALLED)'
okfile: utilities
$(LBLIBPTH) ./perl -Ilib utils/perlbug -ok -s '(UNINSTALLED)' -F perl.ok
$(LDLIBPTH) ./perl -Ilib utils/perlbug -ok -s '(UNINSTALLED)' -F perl.ok
nok: utilities
$(LBLIBPTH) ./perl -Ilib utils/perlbug -nok -s '(UNINSTALLED)'
$(LDLIBPTH) ./perl -Ilib utils/perlbug -nok -s '(UNINSTALLED)'
clist: $(c)
echo $(c) | tr ' ' $(TRNL) >.clist
@ -644,3 +650,70 @@ case `pwd` in
;;
esac
$rm -f $firstmakefile
# Now do any special processing required before building.
case "$ebcdic" in
$define)
xxx=''
echo "This is an EBCDIC system, checking if any parser files need regenerating." >&4
case "$osname" in
os390)
rm -f y.tab.c y.tab.h
yacc -d perly.y >/dev/null 2>&1
if cmp -s y.tab.c perly.c; then
rm -f y.tab.c
else
echo "perly.y -> perly.c" >&2
mv -f y.tab.c perly.c
chmod u+w perly.c
sed -e 's/fprintf *( *stderr *,/PerlIO_printf(Perl_debug_log,/g' \
-e 's/y\.tab/perly/g' perly.c >perly.tmp && mv perly.tmp perly.c
xxx="$xxx perly.c"
fi
if cmp -s y.tab.h perly.h; then
rm -f y.tab.h
else
echo "perly.y -> perly.h" >&2
mv -f y.tab.h perly.h
xxx="$xxx perly.h"
fi
if cd x2p
then
rm -f y.tab.c y.tab.h
yacc a2p.y >/dev/null 2>&1
if cmp -s y.tab.c a2p.c
then
rm -f y.tab.c
else
echo "a2p.y -> a2p.c" >&2
mv -f y.tab.c a2p.c
chmod u+w a2p.c
sed -e 's/fprintf *( *stderr *,/PerlIO_printf(Perl_debug_log,/g' \
-e 's/y\.tab/a2p/g' a2p.c >a2p.tmp && mv a2p.tmp a2p.c
xxx="$xxx a2p.c"
fi
# In case somebody yacc -d:ed the a2p.y.
if test -f y.tab.h
then
if cmp -s y.tab.h a2p.h
then
rm -f y.tab.h
else
echo "a2p.h -> a2p.h" >&2
mv -f y.tab.h a2p.h
xxx="$xxx a2p.h"
fi
fi
cd ..
fi
;;
*)
echo "'$osname' is an EBCDIC system I don't know that well." >&4
;;
esac
case "$xxx" in
'') echo "No parser files were regenerated. That's okay." >&2 ;;
esac
;;
esac

170
contrib/perl5/Porting/Glossary
View File

@ -5,7 +5,7 @@ generates pod documentation for Config.pm from this file--please try to keep
the formatting regular.]
Mcc (Loc.U):
This variable is be used internally by Configure to determine the
This variable is used internally by Configure to determine the
full pathname (if any) of the Mcc program. After Configure runs,
the value is reset to a plain "Mcc" and is not useful.
@ -52,7 +52,7 @@ apiversion (patchlevel.U):
will retain binary compatibility.
ar (Loc.U):
This variable is be used internally by Configure to determine the
This variable is used internally by Configure to determine the
full pathname (if any) of the ar program. After Configure runs,
the value is reset to a plain "ar" and is not useful.
@ -79,7 +79,7 @@ archobjs (Unix.U):
include os2/os2.obj.
awk (Loc.U):
This variable is be used internally by Configure to determine the
This variable is used internally by Configure to determine the
full pathname (if any) of the awk program. After Configure runs,
the value is reset to a plain "awk" and is not useful.
@ -105,7 +105,7 @@ bison (Loc.U):
The value is a plain '' and is not useful.
byacc (Loc.U):
This variable is be used internally by Configure to determine the
This variable is used internally by Configure to determine the
full pathname (if any) of the byacc program. After Configure runs,
the value is reset to a plain "byacc" and is not useful.
@ -129,7 +129,7 @@ castflags (d_castneg.U):
4 = couldn't cast in argument expression list
cat (Loc.U):
This variable is be used internally by Configure to determine the
This variable is used internally by Configure to determine the
full pathname (if any) of the cat program. After Configure runs,
the value is reset to a plain "cat" and is not useful.
@ -154,6 +154,12 @@ ccflags (ccflags.U):
This variable contains any additional C compiler flags desired by
the user. It is up to the Makefile to use this.
ccsymbols (Cppsym.U):
The variable contains the symbols defined by the C compiler alone.
The symbols defined by cpp or by cc when it calls cpp are not in
this list, see cppsymbols and cppccsymbols.
The list is a space-separated list of symbol=value tokens.
cf_by (cf_who.U):
Login name of the person who ran the Configure script and answered the
questions. This is used to tag both config.sh and config_h.SH.
@ -184,7 +190,7 @@ clocktype (d_times.U):
included).
comm (Loc.U):
This variable is be used internally by Configure to determine the
This variable is used internally by Configure to determine the
full pathname (if any) of the comm program. After Configure runs,
the value is reset to a plain "comm" and is not useful.
@ -199,7 +205,7 @@ contains (contains.U):
is primarily for the use of other Configure units.
cp (Loc.U):
This variable is be used internally by Configure to determine the
This variable is used internally by Configure to determine the
full pathname (if any) of the cp program. After Configure runs,
the value is reset to a plain "cp" and is not useful.
@ -208,7 +214,7 @@ cpio (Loc.U):
The value is a plain '' and is not useful.
cpp (Loc.U):
This variable is be used internally by Configure to determine the
This variable is used internally by Configure to determine the
full pathname (if any) of the cpp program. After Configure runs,
the value is reset to a plain "cpp" and is not useful.
@ -244,13 +250,25 @@ cppstdin (cppstdin.U):
It is primarily used by other Configure units that ask about
preprocessor symbols.
cppsymbols (Cppsym.U):
The variable contains the symbols defined by the C preprocessor
alone. The symbols defined by cc or by cc when it calls cpp are
not in this list, see ccsymbols and cppccsymbols.
The list is a space-separated list of symbol=value tokens.
cppccsymbols (Cppsym.U):
The variable contains the symbols defined by the C compiler when
when it calls cpp. The symbols defined by the cc alone or cpp
alone are not in this list, see ccsymbols and cppsymbols.
The list is a space-separated list of symbol=value tokens.
cryptlib (d_crypt.U):
This variable holds -lcrypt or the path to a libcrypt.a archive if
the crypt() function is not defined in the standard C library. It is
up to the Makefile to use this.
csh (Loc.U):
This variable is be used internally by Configure to determine the
This variable is used internally by Configure to determine the
full pathname (if any) of the csh program. After Configure runs,
the value is reset to a plain "csh" and is not useful.
@ -477,6 +495,14 @@ d_fsetpos (d_fsetpos.U):
This variable conditionally defines HAS_FSETPOS if fsetpos() is
available to set the file position indicator.
d_fstatfs (d_statfs.U):
This variable conditionally defines the HAS_FSTATFS symbol, which
indicates to the C program that the fstatfs() routine is available.
d_fstatvfs (d_statvfs.U):
This variable conditionally defines the HAS_FSTATVFS symbol, which
indicates to the C program that the fstatvfs() routine is available.
d_ftime (d_ftime.U):
This variable conditionally defines the HAS_FTIME symbol, which indicates
that the ftime() routine exists. The ftime() routine is basically
@ -522,6 +548,11 @@ d_getlogin (d_getlogin.U):
indicates to the C program that the getlogin() routine is available
to get the login name.
d_getmntent (d_getmntent.U):
This variable conditionally defines the HAS_GETMNTENT symbol, which
indicates to the C program that the getmntent() routine is available
to iterate through mounted files.
d_getnbyaddr (d_getnbyad.U):
This variable conditionally defines the HAS_GETNETBYADDR symbol, which
indicates to the C program that the getnetbyaddr() routine is available
@ -626,6 +657,11 @@ d_grpasswd (i_grp.U):
This variable conditionally defines GRPASSWD, which indicates
that struct group in <grp.h> contains gr_passwd.
d_hasmntopt (d_hasmntopt.U):
This variable conditionally defines the HAS_HASMNTOPT symbol, which
indicates to the C program that the hasmntopt() routine is available
to query the mount options of file systems.
d_htonl (d_htonl.U):
This variable conditionally defines HAS_HTONL if htonl() and its
friends are available to do network order byte swapping.
@ -1072,6 +1108,16 @@ d_statblks (d_statblks.U):
This variable conditionally defines USE_STAT_BLOCKS if this system
has a stat structure declaring st_blksize and st_blocks.
d_statfsflags (d_statfs.U):
This variable conditionally defines the HAS_STRUCT_STATFS_FLAGS
symbol, which indicates to struct statfs from has f_flags member.
This kind of struct statfs is coming from sys/mount.h (BSD),
not from sys/statfs.h (SYSV).
d_statvfs (d_statvfs.U):
This variable conditionally defines the HAS_STATVFS symbol, which
indicates to the C program that the statvfs() routine is available.
d_stdio_cnt_lval (d_stdstdio.U):
This variable conditionally defines STDIO_CNT_LVALUE if the
FILE_cnt macro can be used as an lvalue.
@ -1260,7 +1306,7 @@ d_xenix (Guess.U):
the C program that it runs under Xenix.
date (Loc.U):
This variable is be used internally by Configure to determine the
This variable is used internally by Configure to determine the
full pathname (if any) of the date program. After Configure runs,
the value is reset to a plain "date" and is not useful.
@ -1307,12 +1353,12 @@ ebcdic (ebcdic.U):
See trnl.U
echo (Loc.U):
This variable is be used internally by Configure to determine the
This variable is used internally by Configure to determine the
full pathname (if any) of the echo program. After Configure runs,
the value is reset to a plain "echo" and is not useful.
egrep (Loc.U):
This variable is be used internally by Configure to determine the
This variable is used internally by Configure to determine the
full pathname (if any) of the egrep program. After Configure runs,
the value is reset to a plain "egrep" and is not useful.
@ -1329,7 +1375,7 @@ exe_ext (Unix.U):
This is an old synonym for _exe.
expr (Loc.U):
This variable is be used internally by Configure to determine the
This variable is used internally by Configure to determine the
full pathname (if any) of the expr program. After Configure runs,
the value is reset to a plain "expr" and is not useful.
@ -1340,7 +1386,7 @@ extensions (Extensions.U):
is available.
find (Loc.U):
This variable is be used internally by Configure to determine the
This variable is used internally by Configure to determine the
full pathname (if any) of the find program. After Configure runs,
the value is reset to a plain "find" and is not useful.
@ -1362,6 +1408,11 @@ freetype (mallocsrc.U):
This variable contains the return type of free(). It is usually
void, but occasionally int.
full_ar (Loc_ar.U):
This variable contains the full pathname to 'ar', whether or
not the user has specified 'portability'. This is only used
in the Makefile.SH.
full_csh (d_csh.U):
This variable contains the full pathname to 'csh', whether or
not the user has specified 'portability'. This is only used
@ -1387,7 +1438,7 @@ gidtype (gidtype.U):
of getgid(). Typically, it is the type of group ids in the kernel.
grep (Loc.U):
This variable is be used internally by Configure to determine the
This variable is used internally by Configure to determine the
full pathname (if any) of the grep program. After Configure runs,
the value is reset to a plain "grep" and is not useful.
@ -1403,7 +1454,7 @@ groupstype (groupstype.U):
gidtype (gid_t), but sometimes it isn't.
gzip (Loc.U):
This variable is be used internally by Configure to determine the
This variable is used internally by Configure to determine the
full pathname (if any) of the gzip program. After Configure runs,
the value is reset to a plain "gzip" and is not useful.
@ -1489,6 +1540,10 @@ i_locale (i_locale.U):
This variable conditionally defines the I_LOCALE symbol,
and indicates whether a C program should include <locale.h>.
i_machcthr (i_machcthr.U):
This variable conditionally defines the I_MACH_CTHREADS symbol,
and indicates whether a C program should include <mach/cthreads.h>.
i_malloc (i_malloc.U):
This variable conditionally defines the I_MALLOC symbol, and indicates
whether a C program should include <malloc.h>.
@ -1501,6 +1556,10 @@ i_memory (i_memory.U):
This variable conditionally defines the I_MEMORY symbol, and indicates
whether a C program should include <memory.h>.
i_mntent (i_mntent.U):
This variable conditionally defines the I_MNTENT symbol, and indicates
whether a C program should include <mntent.h>.
i_ndbm (i_ndbm.U):
This variable conditionally defines the I_NDBM symbol, which
indicates to the C program that <ndbm.h> exists and should
@ -1580,6 +1639,10 @@ i_sysioctl (i_sysioctl.U):
indicates to the C program that <sys/ioctl.h> exists and should
be included.
i_sysmount (i_sysmount.U):
This variable conditionally defines the I_SYSMOUNT symbol,
and indicates whether a C program should include <sys/mount.h>.
i_sysndir (i_sysndir.U):
This variable conditionally defines the I_SYS_NDIR symbol, and indicates
whether a C program should include <sys/ndir.h>.
@ -1606,6 +1669,14 @@ i_sysstat (i_sysstat.U):
This variable conditionally defines the I_SYS_STAT symbol,
and indicates whether a C program should include <sys/stat.h>.
i_sysstatfs (i_sysstatfs.U):
This variable conditionally defines the I_SYSSTATFS symbol,
and indicates whether a C program should include <sys/statfs.h>.
i_sysstatvfs (i_sysstatvfs.U):
This variable conditionally defines the I_SYSSTATVFS symbol,
and indicates whether a C program should include <sys/statvfs.h>.
i_systime (i_time.U):
This variable conditionally defines I_SYS_TIME, which indicates
to the C program that it should include <sys/time.h>.
@ -1671,6 +1742,11 @@ i_vfork (i_vfork.U):
This variable conditionally defines the I_VFORK symbol, and indicates
whether a C program should include vfork.h.
ignore_versioned_solibs (libs.U):
This variable should be non-empty if non-versioned shared
libraries (libfoo.so.x.y) are to be ignored (because they
cannot be linked against).
incpath (usrinc.U):
This variable must preceed the normal include path to get hte
right one, as in "$incpath/usr/include" or "$incpath/usr/lib".
@ -1722,6 +1798,11 @@ installsitelib (sitelib.U):
those systems using AFS. For extra portability, only this variable
should be used in makefiles.
installusrbinperl (instubperl.U):
This variable tells whether Perl should be installed also as
/usr/bin/perl in addition to
$installbin/perl
intsize (intsize.U):
This variable contains the value of the INTSIZE symbol, which
indicates to the C program how many bytes there are in an int.
@ -1756,7 +1837,7 @@ ldflags (ccflags.U):
the user. It is up to the Makefile to use this.
less (Loc.U):
This variable is be used internally by Configure to determine the
This variable is used internally by Configure to determine the
full pathname (if any) of the less program. After Configure runs,
the value is reset to a plain "less" and is not useful.
@ -1788,7 +1869,7 @@ libswanted (Myinit.U):
ahead of ucb or bsd libraries for SVR4.
line (Loc.U):
This variable is be used internally by Configure to determine the
This variable is used internally by Configure to determine the
full pathname (if any) of the line program. After Configure runs,
the value is reset to a plain "line" and is not useful.
@ -1801,7 +1882,7 @@ lkflags (ccflags.U):
the user. It is up to the Makefile to use this.
ln (Loc.U):
This variable is be used internally by Configure to determine the
This variable is used internally by Configure to determine the
full pathname (if any) of the ln program. After Configure runs,
the value is reset to a plain "ln" and is not useful.
@ -1845,7 +1926,7 @@ lpr (Loc.U):
The value is a plain '' and is not useful.
ls (Loc.U):
This variable is be used internally by Configure to determine the
This variable is used internally by Configure to determine the
full pathname (if any) of the ls program. After Configure runs,
the value is reset to a plain "ls" and is not useful.
@ -1863,7 +1944,7 @@ mailx (Loc.U):
The value is a plain '' and is not useful.
make (Loc.U):
This variable is be used internally by Configure to determine the
This variable is used internally by Configure to determine the
full pathname (if any) of the make program. After Configure runs,
the value is reset to a plain "make" and is not useful.
@ -1934,7 +2015,7 @@ mips_type (usrinc.U):
Possible values are "BSD 4.3" and "System V".
mkdir (Loc.U):
This variable is be used internally by Configure to determine the
This variable is used internally by Configure to determine the
full pathname (if any) of the mkdir program. After Configure runs,
the value is reset to a plain "mkdir" and is not useful.
@ -1949,7 +2030,7 @@ modetype (modetype.U):
modes for system calls.
more (Loc.U):
This variable is be used internally by Configure to determine the
This variable is used internally by Configure to determine the
full pathname (if any) of the more program. After Configure runs,
the value is reset to a plain "more" and is not useful.
@ -2006,7 +2087,7 @@ netdb_net_type (netdbtype.U):
This is only useful if you have getnetbyaddr(), naturally.
nm (Loc.U):
This variable is be used internally by Configure to determine the
This variable is used internally by Configure to determine the
full pathname (if any) of the nm program. After Configure runs,
the value is reset to a plain "nm" and is not useful.
@ -2026,7 +2107,7 @@ nonxs_ext (Extensions.U):
in the package. All of them will be built.
nroff (Loc.U):
This variable is be used internally by Configure to determine the
This variable is used internally by Configure to determine the
full pathname (if any) of the nroff program. After Configure runs,
the value is reset to a plain "nroff" and is not useful.
@ -2086,7 +2167,7 @@ path_sep (Unix.U):
used to separate elements in the command shell search PATH.
perl (Loc.U):
This variable is be used internally by Configure to determine the
This variable is used internally by Configure to determine the
full pathname (if any) of the perl program. After Configure runs,
the value is reset to a plain "perl" and is not useful.
@ -2099,7 +2180,7 @@ perlpath (perlpath.U):
shell scripts and in the "eval 'exec'" idiom.
pg (Loc.U):
This variable is be used internally by Configure to determine the
This variable is used internally by Configure to determine the
full pathname (if any) of the pg program. After Configure runs,
the value is reset to a plain "pg" and is not useful.
@ -2172,7 +2253,7 @@ rd_nodata (nblock_io.U):
no data and an EOF.. Sigh!
rm (Loc.U):
This variable is be used internally by Configure to determine the
This variable is used internally by Configure to determine the
full pathname (if any) of the rm program. After Configure runs,
the value is reset to a plain "rm" and is not useful.
@ -2197,10 +2278,17 @@ scriptdirexp (scriptdir.U):
at configuration time, for programs not wanting to bother with it.
sed (Loc.U):
This variable is be used internally by Configure to determine the
This variable is used internally by Configure to determine the
full pathname (if any) of the sed program. After Configure runs,
the value is reset to a plain "sed" and is not useful.
selectminbits (selectminbits.U):
This variable holds the minimum number of bits operated by select.
That is, if you do select(n, ...), how many bits at least will be
cleared in the masks if some activity is detected. Usually this
is either n or 32*ceil(n/32), especially many little-endians do
the latter. This is only useful if you have select(), naturally.
selecttype (selecttype.U):
This variable holds the type used for the 2nd, 3rd, and 4th
arguments to select. Usually, this is 'fd_set *', if HAS_FD_SET
@ -2208,7 +2296,7 @@ selecttype (selecttype.U):
have select(), naturally.
sendmail (Loc.U):
This variable is be used internally by Configure to determine the
This variable is used internally by Configure to determine the
full pathname (if any) of the sendmail program. After Configure runs,
the value is reset to a plain "sendmail" and is not useful.
@ -2277,6 +2365,12 @@ sig_num (sig_name.U):
the value of the signal listed in the same place within the
sig_name list.
sig_num_init (sig_name.U):
This variable holds the signal numbers, enclosed in double quotes and
separated by commas, suitable for use in the SIG_NUM definition
below. A "ZERO" is prepended to the list, and the list is
terminated with a plain 0.
signal_t (d_voidsig.U):
This variable holds the type of the signal handler (void or int).
@ -2329,7 +2423,7 @@ socketlib (d_socket.U):
This variable has the names of any libraries needed for socket support.
sort (Loc.U):
This variable is be used internally by Configure to determine the
This variable is used internally by Configure to determine the
full pathname (if any) of the sort program. After Configure runs,
the value is reset to a plain "sort" and is not useful.
@ -2440,12 +2534,12 @@ tbl (Loc.U):
The value is a plain '' and is not useful.
tee (Loc.U):
This variable is be used internally by Configure to determine the
This variable is used internally by Configure to determine the
full pathname (if any) of the tee program. After Configure runs,
the value is reset to a plain "tee" and is not useful.
test (Loc.U):
This variable is be used internally by Configure to determine the
This variable is used internally by Configure to determine the
full pathname (if any) of the test program. After Configure runs,
the value is reset to a plain "test" and is not useful.
@ -2458,12 +2552,12 @@ timetype (d_time.U):
included). Anyway, the type Time_t should be used.
touch (Loc.U):
This variable is be used internally by Configure to determine the
This variable is used internally by Configure to determine the
full pathname (if any) of the touch program. After Configure runs,
the value is reset to a plain "touch" and is not useful.
tr (Loc.U):
This variable is be used internally by Configure to determine the
This variable is used internally by Configure to determine the
full pathname (if any) of the tr program. After Configure runs,
the value is reset to a plain "tr" and is not useful.
@ -2482,12 +2576,12 @@ uidtype (uidtype.U):
ushort, or whatever type is used to declare user ids in the kernel.
uname (Loc.U):
This variable is be used internally by Configure to determine the
This variable is used internally by Configure to determine the
full pathname (if any) of the uname program. After Configure runs,
the value is reset to a plain "uname" and is not useful.
uniq (Loc.U):
This variable is be used internally by Configure to determine the
This variable is used internally by Configure to determine the
full pathname (if any) of the uniq program. After Configure runs,
the value is reset to a plain "uniq" and is not useful.
@ -2574,7 +2668,7 @@ zcat (Loc.U):
The value is a plain '' and is not useful.
zip (Loc.U):
This variable is be used internally by Configure to determine the
This variable is used internally by Configure to determine the
full pathname (if any) of the zip program. After Configure runs,
the value is reset to a plain "zip" and is not useful.

52
contrib/perl5/Porting/patching.pod
View File

@ -10,7 +10,7 @@ The latest version of this document is available from
=head2 How to contribute to this document
You may mail corrections, additions, and suggestions to me
at dgris@tdrenterprises.com but the preferred method would be
at dgris@dimensional.com but the preferred method would be
to follow the instructions set forth in this document and
submit a patch 8-).
@ -36,6 +36,12 @@ and patches not produced using standard utilities (such as diff).
=head1 Proper Patch Guidelines
=head2 What to patch
Generally speaking you should patch the latest development release
of perl. The maintainers of the individual branches will see to it
that patches are picked up and applied as appropriate.
=head2 How to prepare your patch
=over 4
@ -159,18 +165,19 @@ guidelines (courtesy of Gurusamy Sarathy (gsar@engin.umich.edu))-
Interpret results strictly.
Use unrelated features (this will flush out bizarre interactions).
Use non-standard idioms (otherwise you are not testing TIMTOWTDI).
Avoid using hardcoded test umbers whenever possible (the EXPECTED/GOT style
found in t/op/tie.t is much more maintainable, and gives better failure
reports).
Avoid using hardcoded test numbers whenever possible (the
EXPECTED/GOT found in t/op/tie.t is much more maintainable,
and gives better failure reports).
Give meaningful error messages when a test fails.
Avoid using qx// and system() unless you are testing for them. If you
do use them, make sure that you cover _all_ perl platforms.
Unlink any temporary files you create.
Promote unforeseen warnings to errors with $SIG{__WARN__}.
Be sure to use the libraries and modules shipped with version being tested,
not those that were already installed.
Be sure to use the libraries and modules shipped with version
being tested, not those that were already installed.
Add comments to the code explaining what you are testing for.
Make updating the '1..42' string unnecessary. Or make sure that you update it.
Make updating the '1..42' string unnecessary. Or make sure that
you update it.
Test _all_ behaviors of a given operator, library, or function-
All optional arguments
Return values in various contexts (boolean, scalar, list, lvalue)
@ -289,23 +296,25 @@ others will have an easy time using your work, and it should be easier
for the maintainers to coordinate the occasionally large numbers of
patches received.
Also, just because you're not a brilliant coder doesn't mean that you can't
contribute. As valuable as code patches are there is always a need for better
documentation (especially considering the general level of joy that most
programmers feel when forced to sit down and write docs). If all you do
is patch the documentation you have still contributed more than the person
who sent in an amazing new feature that noone can use because noone understands
the code (what I'm getting at is that documentation is both the hardest part to
do (because everyone hates doing it) and the most valuable).
Also, just because you're not a brilliant coder doesn't mean that you
can't contribute. As valuable as code patches are there is always a
need for better documentation (especially considering the general
level of joy that most programmers feel when forced to sit down and
write docs). If all you do is patch the documentation you have still
contributed more than the person who sent in an amazing new feature
that no one can use because no one understands the code (what I'm
getting at is that documentation is both the hardest part to do
(because everyone hates doing it) and the most valuable).
Mostly, when contributing patches, imagine that it is B<you> receiving hundreds
of patches and that it is B<your> responsibility to integrate them into the source.
Obviously you'd want the patches to be as easy to apply as possible. Keep that in
mind. 8-)
Mostly, when contributing patches, imagine that it is B<you> receiving
hundreds of patches and that it is B<your> responsibility to integrate
them into the source. Obviously you'd want the patches to be as easy
to apply as possible. Keep that in mind. 8-)
=head1 Last Modified
Last modified 21 May 1998 by Daniel Grisinger <dgris@perrin.dimensional.com>
Last modified 21 January 1999
Daniel Grisinger <dgris@dimensional.com>
=head1 Author and Copyright Information
@ -314,6 +323,3 @@ Copyright (c) 1998 Daniel Grisinger
Adapted from a posting to perl5-porters by Tim Bunce (Tim.Bunce@ig.co.uk).
I'd like to thank the perl5-porters for their suggestions.

10
contrib/perl5/Porting/pumpkin.pod
View File

@ -1178,6 +1178,16 @@ the dist-users mailing list along these lines. They have been folded
back into the main distribution, but various parts of the perl
Configure/build/install process still assume src='.'.
=item Directory for vendor-supplied modules?
If a vendor supplies perl, but wants to leave $siteperl and $sitearch
for the local user to use, where should the vendor put vendor-supplied
modules (such as Tk.so?) If the vendor puts them in $archlib, then
they need to be updated each time the perl version is updated.
Perhaps we need a set of libries $vendorperl and $vendorarch that
track $apiversion (like the $sitexxx directories do) rather than
just $version (like the main perl directory).
=item Hint file fixes
Various hint files work around Configure problems. We ought to fix

6
contrib/perl5/README
View File

@ -1,7 +1,7 @@
Perl Kit, Version 5.0
Copyright 1989-1997, Larry Wall
Copyright 1989-1999, Larry Wall
All rights reserved.
This program is free software; you can redistribute it and/or modify
@ -22,8 +22,8 @@
Kit, in the file named "Artistic". If not, I'll be glad to provide one.
You should also have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
along with this program; if not, write to the Free Software Foundation,
Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307, USA.
For those of you that choose to use the GNU General Public License,
my interpretation of the GNU General Public License is that no Perl

24
contrib/perl5/README.threads
View File

@ -1,3 +1,10 @@
NOTE
Threading is a highly experimental feature. There are still a
few race conditions that show up under high contention on SMP
machines. Internal implementation is still subject to changes.
It is not recommended for production use at this time.
Building
If you want to build with multi-threading support and you are
@ -27,7 +34,8 @@ work or you are using another platform which you believe supports
POSIX.1c threads then read on. Additional information may be in
a platform-specific "hints" file in the hints/ subdirectory.
Omit the -d from your ./Configure arguments. For example, use
On other platforms that use Configure to build perl, omit the -d
from your ./Configure arguments. For example, use:
./Configure -Dusethreads
@ -92,6 +100,10 @@ For AIX:
Add -lc_r to libswanted
Change -lc in lddflags to be -lpthread -lc_r -lc
For Win32:
See README.win32, and the notes at the beginning of win32/Makefile
or win32/makefile.mk.
Now you can do a
make
@ -147,11 +159,8 @@ libraries were not compiled to be thread-aware).
Bugs
* FAKE_THREADS should produce a working perl but the Thread
extension won't build with it yet.
* There's a known memory leak (curstack isn't freed at the end
of each thread because it causes refcount problems that I
haven't tracked down yet) and there are very probably others too.
extension won't build with it yet. (FAKE_THREADS has not been
tested at all in recent times.)
* There may still be races where bugs show up under contention.
@ -275,3 +284,6 @@ Last updated: 27 November 1997
Configure-related info updated 16 July 1998 by
Andy Dougherty <doughera@lafayette.edu>
Other minor updates 10 Feb 1999 by
Gurusamy Sarathy

5
contrib/perl5/Todo
View File

@ -10,9 +10,8 @@ Would be nice to have
lexperl
Bundled perl preprocessor
Use posix calls internally where possible
gettimeofday
gettimeofday (possibly best left for a module?)
format BOTTOM
-iprefix.
-i rename file only when successfully changed
All ARGV input should act like <>
report HANDLE [formats].
@ -23,6 +22,8 @@ Would be nice to have
lvalue functions
regression/sanity tests for suidperl
Full 64 bit support (i.e. "long long")
Generalise Errno way of extracting cpp symbols and use that in
Errno and Fcntl (ExtUtils::CppSymbol?)
Possible pragmas
debugger

31
contrib/perl5/Todo-5.005
View File

@ -1,26 +1,21 @@
Multi-threading
$AUTOLOAD. Hmm.
without USE_THREADS, change extern variable for dTHR
consistent semantics for exit/die in threads
SvREFCNT_dec(curstack) in threadstart() in Thread.xs
better support for externally created threads
Thread::Pool
more Configure support
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
$^C to track compiler/checker status
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
symbol-space: "pl_" prefix for all global vars
"Perl_" prefix for all functions
CPP-space: restrict what we export from headers
stop malloc()/free() pollution unless asked
header-space: move into CORE/perl/
@ -28,9 +23,7 @@ Namespace cleanup
MULTIPLICITY support
complete work on safe recursive interpreters, C<Perl->new()>
Configure
installation layout changes to avoid overwriting old versions
revisit extra implicit arg that provides curthread/curinterp context
Reliable Signals
alternate runops() for signal despatch
@ -38,31 +31,31 @@ Reliable Signals
add tests for Thread::Signal
Win32 stuff
automate maintenance of most PERL_OBJECT code
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
put perlobject in $ARCHNAME so it can coexist with rest
get PERL_OBJECT building on non-win32?
style-check
Miscellaneous
rename and alter ISA.pm
magic_setisa should be made to update %FIELDS [???]
be generous in accepting foreign line terminations
make filenames 8.3 friendly, where feasible
upgrade to newer versions of all independently maintained modules
add new modules (Data-Dumper, Storable?)
test it with large parts of CPAN
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
comprehensive perldelta.pod
describe new age patterns
update perl{guts,call,embed,xs} with additions, changes to API
document Win32 choices
rework INSTALL to reflect changes in installation structure
spot-check all new modules for completeness
better docs for pack()/unpack()
add perlport.pod
reorg tutorials vs. reference sections

70
contrib/perl5/XSUB.h
View File

@ -57,8 +57,8 @@
#ifdef XS_VERSION
# define XS_VERSION_BOOTCHECK \
STMT_START { \
SV *tmpsv; \
char *vn = Nullch, *module = SvPV(ST(0),PL_na); \
SV *tmpsv; STRLEN n_a; \
char *vn = Nullch, *module = SvPV(ST(0),n_a); \
if (items >= 2) /* version supplied as bootstrap arg */ \
tmpsv = ST(1); \
else { \
@ -69,7 +69,7 @@
tmpsv = perl_get_sv(form("%s::%s", module, \
vn = "VERSION"), FALSE); \
} \
if (tmpsv && (!SvOK(tmpsv) || strNE(XS_VERSION, SvPV(tmpsv, PL_na)))) \
if (tmpsv && (!SvOK(tmpsv) || strNE(XS_VERSION, SvPV(tmpsv, n_a)))) \
croak("%s object version %s does not match %s%s%s%s %_", \
module, XS_VERSION, \
vn ? "$" : "", vn ? module : "", vn ? "::" : "", \
@ -79,6 +79,70 @@
# define XS_VERSION_BOOTCHECK
#endif
#ifdef PERL_CAPI
# define VTBL_sv get_vtbl(want_vtbl_sv)
# define VTBL_env get_vtbl(want_vtbl_env)
# define VTBL_envelem get_vtbl(want_vtbl_envelem)
# define VTBL_sig get_vtbl(want_vtbl_sig)
# define VTBL_sigelem get_vtbl(want_vtbl_sigelem)
# define VTBL_pack get_vtbl(want_vtbl_pack)
# define VTBL_packelem get_vtbl(want_vtbl_packelem)
# define VTBL_dbline get_vtbl(want_vtbl_dbline)
# define VTBL_isa get_vtbl(want_vtbl_isa)
# define VTBL_isaelem get_vtbl(want_vtbl_isaelem)
# define VTBL_arylen get_vtbl(want_vtbl_arylen)
# define VTBL_glob get_vtbl(want_vtbl_glob)
# define VTBL_mglob get_vtbl(want_vtbl_mglob)
# define VTBL_nkeys get_vtbl(want_vtbl_nkeys)
# define VTBL_taint get_vtbl(want_vtbl_taint)
# define VTBL_substr get_vtbl(want_vtbl_substr)
# define VTBL_vec get_vtbl(want_vtbl_vec)
# define VTBL_pos get_vtbl(want_vtbl_pos)
# define VTBL_bm get_vtbl(want_vtbl_bm)
# define VTBL_fm get_vtbl(want_vtbl_fm)
# define VTBL_uvar get_vtbl(want_vtbl_uvar)
# define VTBL_defelem get_vtbl(want_vtbl_defelem)
# define VTBL_regexp get_vtbl(want_vtbl_regexp)
# ifdef USE_LOCALE_COLLATE
# define VTBL_collxfrm get_vtbl(want_vtbl_collxfrm)
# endif
# ifdef OVERLOAD
# define VTBL_amagic get_vtbl(want_vtbl_amagic)
# define VTBL_amagicelem get_vtbl(want_vtbl_amagicelem)
# endif
#else
# define VTBL_sv &vtbl_sv
# define VTBL_env &vtbl_env
# define VTBL_envelem &vtbl_envelem
# define VTBL_sig &vtbl_sig
# define VTBL_sigelem &vtbl_sigelem
# define VTBL_pack &vtbl_pack
# define VTBL_packelem &vtbl_packelem
# define VTBL_dbline &vtbl_dbline
# define VTBL_isa &vtbl_isa
# define VTBL_isaelem &vtbl_isaelem
# define VTBL_arylen &vtbl_arylen
# define VTBL_glob &vtbl_glob
# define VTBL_mglob &vtbl_mglob
# define VTBL_nkeys &vtbl_nkeys
# define VTBL_taint &vtbl_taint
# define VTBL_substr &vtbl_substr
# define VTBL_vec &vtbl_vec
# define VTBL_pos &vtbl_pos
# define VTBL_bm &vtbl_bm
# define VTBL_fm &vtbl_fm
# define VTBL_uvar &vtbl_uvar
# define VTBL_defelem &vtbl_defelem
# define VTBL_regexp &vtbl_regexp
# ifdef USE_LOCALE_COLLATE
# define VTBL_collxfrm &vtbl_collxfrm
# endif
# ifdef OVERLOAD
# define VTBL_amagic &vtbl_amagic
# define VTBL_amagicelem &vtbl_amagicelem
# endif
#endif
#ifdef PERL_OBJECT
#include "objXSUB.h"
#ifndef NO_XSLOCKS

21
contrib/perl5/XSlock.h
View File

@ -13,23 +13,26 @@ class XSLockManager
};
XSLockManager g_XSLock;
CPerlObj* pPerl;
class XSLock
{
public:
XSLock() { g_XSLock.Enter(); };
XSLock(CPerlObj *p) {
g_XSLock.Enter();
::pPerl = p;
};
~XSLock() { g_XSLock.Leave(); };
};
CPerlObj* pPerl;
/* PERL_CAPI does its own locking in xs_handler() */
#if defined(PERL_OBJECT) && !defined(PERL_CAPI)
#undef dXSARGS
#define dXSARGS \
dSP; dMARK; \
I32 ax = mark - PL_stack_base + 1; \
I32 items = sp - mark; \
XSLock localLock; \
::pPerl = pPerl
XSLock localLock(pPerl); \
dSP; dMARK; \
I32 ax = mark - PL_stack_base + 1; \
I32 items = sp - mark
#endif /* PERL_OBJECT && !PERL_CAPI */
#endif

36
contrib/perl5/av.c
View File

@ -1,6 +1,6 @@
/* av.c
*
* Copyright (c) 1991-1997, Larry Wall
* Copyright (c) 1991-1999, Larry Wall
*
* You may distribute under the terms of either the GNU General Public
* License or the Artistic License, as specified in the README file.
@ -24,7 +24,7 @@ av_reify(AV *av)
if (AvREAL(av))
return;
#ifdef DEBUGGING
if (SvRMAGICAL(av) && mg_find((SV*)av,'P'))
if (SvTIED_mg((SV*)av, 'P'))
warn("av_reify called on tied array");
#endif
key = AvMAX(av) + 1;
@ -41,6 +41,7 @@ av_reify(AV *av)
key = AvARRAY(av) - AvALLOC(av);
while (key)
AvALLOC(av)[--key] = &PL_sv_undef;
AvREIFY_off(av);
AvREAL_on(av);
}
@ -49,14 +50,14 @@ av_extend(AV *av, I32 key)
{
dTHR; /* only necessary if we have to extend stack */
MAGIC *mg;
if (SvRMAGICAL(av) && (mg = mg_find((SV*)av,'P'))) {
if (mg = SvTIED_mg((SV*)av, 'P')) {
dSP;
ENTER;
SAVETMPS;
PUSHSTACKi(PERLSI_MAGIC);
PUSHMARK(SP);
EXTEND(SP,2);
PUSHs(mg->mg_obj);
PUSHs(SvTIED_obj((SV*)av, mg));
PUSHs(sv_2mortal(newSViv(key+1)));
PUTBACK;
perl_call_method("EXTEND", G_SCALAR|G_DISCARD);
@ -174,10 +175,7 @@ av_fetch(register AV *av, I32 key, I32 lval)
if (key > AvFILLp(av)) {
if (!lval)
return 0;
if (AvREALISH(av))
sv = NEWSV(5,0);
else
sv = sv_newmortal();
sv = NEWSV(5,0);
return av_store(av,key,sv);
}
if (AvARRAY(av)[key] == &PL_sv_undef) {
@ -370,7 +368,7 @@ av_undef(register AV *av)
/*SUPPRESS 560*/
/* Give any tie a chance to cleanup first */
if (SvRMAGICAL(av) && mg_find((SV*)av,'P'))
if (SvTIED_mg((SV*)av, 'P'))
av_fill(av, -1); /* mg_clear() ? */
if (AvREAL(av)) {
@ -397,12 +395,12 @@ av_push(register AV *av, SV *val)
if (SvREADONLY(av))
croak(no_modify);
if (SvRMAGICAL(av) && (mg = mg_find((SV*)av,'P'))) {
if (mg = SvTIED_mg((SV*)av, 'P')) {
dSP;
PUSHSTACKi(PERLSI_MAGIC);
PUSHMARK(SP);
EXTEND(SP,2);
PUSHs(mg->mg_obj);
PUSHs(SvTIED_obj((SV*)av, mg));
PUSHs(val);
PUTBACK;
ENTER;
@ -424,11 +422,11 @@ av_pop(register AV *av)
return &PL_sv_undef;
if (SvREADONLY(av))
croak(no_modify);
if (SvRMAGICAL(av) && (mg = mg_find((SV*)av,'P'))) {
if (mg = SvTIED_mg((SV*)av, 'P')) {
dSP;
PUSHSTACKi(PERLSI_MAGIC);
PUSHMARK(SP);
XPUSHs(mg->mg_obj);
XPUSHs(SvTIED_obj((SV*)av, mg));
PUTBACK;
ENTER;
if (perl_call_method("POP", G_SCALAR)) {
@ -459,12 +457,12 @@ av_unshift(register AV *av, register I32 num)
if (SvREADONLY(av))
croak(no_modify);
if (SvRMAGICAL(av) && (mg = mg_find((SV*)av,'P'))) {
if (mg = SvTIED_mg((SV*)av, 'P')) {
dSP;
PUSHSTACKi(PERLSI_MAGIC);
PUSHMARK(SP);
EXTEND(SP,1+num);
PUSHs(mg->mg_obj);
PUSHs(SvTIED_obj((SV*)av, mg));
while (num-- > 0) {
PUSHs(&PL_sv_undef);
}
@ -510,11 +508,11 @@ av_shift(register AV *av)
return &PL_sv_undef;
if (SvREADONLY(av))
croak(no_modify);
if (SvRMAGICAL(av) && (mg = mg_find((SV*)av,'P'))) {
if (mg = SvTIED_mg((SV*)av, 'P')) {
dSP;
PUSHSTACKi(PERLSI_MAGIC);
PUSHMARK(SP);
XPUSHs(mg->mg_obj);
XPUSHs(SvTIED_obj((SV*)av, mg));
PUTBACK;
ENTER;
if (perl_call_method("SHIFT", G_SCALAR)) {
@ -551,14 +549,14 @@ av_fill(register AV *av, I32 fill)
croak("panic: null array");
if (fill < 0)
fill = -1;
if (SvRMAGICAL(av) && (mg = mg_find((SV*)av,'P'))) {
if (mg = SvTIED_mg((SV*)av, 'P')) {
dSP;
ENTER;
SAVETMPS;
PUSHSTACKi(PERLSI_MAGIC);
PUSHMARK(SP);
EXTEND(SP,2);
PUSHs(mg->mg_obj);
PUSHs(SvTIED_obj((SV*)av, mg));
PUSHs(sv_2mortal(newSViv(fill+1)));
PUTBACK;
perl_call_method("STORESIZE", G_SCALAR|G_DISCARD);

2
contrib/perl5/av.h
View File

@ -1,6 +1,6 @@
/* av.h
*
* Copyright (c) 1991-1998, Larry Wall
* Copyright (c) 1991-1999, Larry Wall
*
* You may distribute under the terms of either the GNU General Public
* License or the Artistic License, as specified in the README file.

2
contrib/perl5/bytecode.h
View File

@ -64,7 +64,7 @@ typedef IV IV64;
BGET_U32(hi); \
BGET_U32(lo); \
if (sizeof(IV) == 8) \
arg = (IV) (hi << (sizeof(IV)*4) | lo); \
arg = ((IV)hi << (sizeof(IV)*4) | lo); \
else if (((I32)hi == -1 && (I32)lo < 0) \
|| ((I32)hi == 0 && (I32)lo >= 0)) { \
arg = (I32)lo; \

2
contrib/perl5/cc_runtime.h
View File

@ -45,7 +45,7 @@
case 0: \
PL_op = ppaddr(ARGS); \
PL_retstack[PL_retstack_ix - 1] = Nullop; \
if (PL_op != nxt) runops(); \
if (PL_op != nxt) CALLRUNOPS(); \
JMPENV_POP; \
break; \
case 1: JMPENV_POP; JMPENV_JUMP(1); \

71
contrib/perl5/config_h.SH
View File

@ -239,6 +239,54 @@ sed <<!GROK!THIS! >config.h -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un-
*/
#$d_fsetpos HAS_FSETPOS /**/
/* I_SYS_MOUNT:
* This symbol, if defined, indicates to the C program that it should
* include <sys/mount.h>.
*/
#$i_sysmount I_SYS_MOUNT /**/
/* HAS_FSTATFS:
* This symbol, if defined, indicates that the fstatfs routine is
* available to stat the filesystem of a file descriptor.
*/
#$d_fstatfs HAS_FSTATFS /**/
/* HAS_STRUCT_STATFS_FLAGS:
* This symbol, if defined, indicates that the struct statfs has
* the f_flags member for mount flags.
*/
#$d_statfsflags HAS_STRUCT_STATFS_FLAGS /**/
/* I_SYS_STATVFS:
* This symbol, if defined, indicates to the C program that it should
* include <sys/statvfs.h>.
*/
#$i_sysstatvfs I_SYS_STATVFS /**/
/* HAS_FSTATVFS:
* This symbol, if defined, indicates that the fstatvfs routine is
* available to stat the filesystem of a file descriptor.
*/
#$d_fstatvfs HAS_FSTATVFS /**/
/* I_MNTENT:
* This symbol, if defined, indicates to the C program that it should
* include <mntent.h>.
*/
#$i_mntent I_MNTENT /**/
/* HAS_GETMNTENT:
* This symbol, if defined, indicates that the getmntent routine is
* available to lookup mount entries in some data base or other.
*/
#$d_getmntent HAS_GETMNTENT /**/
/* HAS_HASMNTOPT:
* This symbol, if defined, indicates that the hasmntopt routine is
* available to query mount entries returned by getmntent.
*/
#$d_hasmntopt HAS_HASMNTOPT /**/
/* HAS_GETTIMEOFDAY:
* This symbol, if defined, indicates that the gettimeofday() system
* call is available for a sub-second accuracy clock. Usually, the file
@ -1813,7 +1861,7 @@ sed <<!GROK!THIS! >config.h -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un-
* the sig_name list.
*/
#define SIG_NAME $sig_name_init /**/
#define SIG_NUM $sig_num /**/
#define SIG_NUM $sig_num_init /**/
/* VOIDFLAGS:
* This symbol indicates how much support of the void type is given by this
@ -1902,6 +1950,15 @@ sed <<!GROK!THIS! >config.h -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un-
#define PRIVLIB "$privlib" /**/
#define PRIVLIB_EXP "$privlibexp" /**/
/* SELECT_MIN_BITS:
* This symbol holds the minimum number of bits operated by select.
* That is, if you do select(n, ...), how many bits at least will be
* cleared in the masks if some activity is detected. Usually this
* is either n or 32*ceil(n/32), especially many little-endians do
* the latter. This is only useful if you have select(), naturally.
*/
#define SELECT_MIN_BITS $selectminbits /**/
/* SITEARCH:
* This symbol contains the name of the private library for this package.
* The library is private in the sense that it needn't be in anyone's
@ -2017,6 +2074,18 @@ sed <<!GROK!THIS! >config.h -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un-
*/
#define ARCHNAME "$archname" /**/
/* I_MACH_CTHREADS:
* This symbol, if defined, indicates to the C program that it should
* include <mach/cthreads.h>.
*/
#$i_machcthreads I_MACH_CTHREADS /**/
/* I_PTHREAD:
* This symbol, if defined, indicates to the C program that it should
* include <pthread.h>.
*/
#$i_pthread I_PTHREAD /**/
/* HAS_PTHREAD_YIELD:
* This symbol, if defined, indicates that the pthread_yield
* routine is available to yield the execution of the current

2
contrib/perl5/configure.com
View File

@ -974,7 +974,7 @@ $ line = F$EDIT(line,"COMPRESS, TRIM")
$ patchlevel = F$EXTRACT(18,F$LENGTH(line)-18,line)
$ got_patch = "true"
$ ENDIF
$ IF ((F$LOCATE("SUBVERSION",line).NE.F$LENGTH(line)).AND.(.NOT.got_sub))
$ IF ((F$LOCATE("#define SUBVERSION",line).NE.F$LENGTH(line)).AND.(.NOT.got_sub))
$ THEN
$ line = F$EDIT(line,"COMPRESS, TRIM")
$ subversion = F$EXTRACT(18,F$LENGTH(line)-18,line)

29
contrib/perl5/cop.h
View File

@ -1,6 +1,6 @@
/* cop.h
*
* Copyright (c) 1991-1997, Larry Wall
* Copyright (c) 1991-1999, Larry Wall
*
* You may distribute under the terms of either the GNU General Public
* License or the Artistic License, as specified in the README file.
@ -142,7 +142,7 @@ struct block_loop {
#define POPLOOP2() \
SvREFCNT_dec(cxloop.iterlval); \
if (cxloop.itervar) { \
SvREFCNT_dec(*cxloop.itervar); \
sv_2mortal(*cxloop.itervar); \
*cxloop.itervar = cxloop.itersave; \
} \
if (cxloop.iterary && cxloop.iterary != PL_curstack) \
@ -180,17 +180,17 @@ struct block {
cx->cx_type = t, \
cx->blk_oldsp = sp - PL_stack_base, \
cx->blk_oldcop = PL_curcop, \
cx->blk_oldmarksp = PL_markstack_ptr - PL_markstack, \
cx->blk_oldmarksp = PL_markstack_ptr - PL_markstack, \
cx->blk_oldscopesp = PL_scopestack_ix, \
cx->blk_oldretsp = PL_retstack_ix, \
cx->blk_oldretsp = PL_retstack_ix, \
cx->blk_oldpm = PL_curpm, \
cx->blk_gimme = gimme; \
DEBUG_l( PerlIO_printf(PerlIO_stderr(), "Entering block %ld, type %s\n", \
(long)cxstack_ix, block_type[t]); )
(long)cxstack_ix, block_type[CxTYPE(cx)]); )
/* Exit a block (RETURN and LAST). */
#define POPBLOCK(cx,pm) cx = &cxstack[cxstack_ix--], \
newsp = PL_stack_base + cx->blk_oldsp, \
newsp = PL_stack_base + cx->blk_oldsp, \
PL_curcop = cx->blk_oldcop, \
PL_markstack_ptr = PL_markstack + cx->blk_oldmarksp, \
PL_scopestack_ix = cx->blk_oldscopesp, \
@ -198,14 +198,15 @@ struct block {
pm = cx->blk_oldpm, \
gimme = cx->blk_gimme; \
DEBUG_l( PerlIO_printf(PerlIO_stderr(), "Leaving block %ld, type %s\n", \
(long)cxstack_ix+1,block_type[cx->cx_type]); )
(long)cxstack_ix+1,block_type[CxTYPE(cx)]); )
/* Continue a block elsewhere (NEXT and REDO). */
#define TOPBLOCK(cx) cx = &cxstack[cxstack_ix], \
PL_stack_sp = PL_stack_base + cx->blk_oldsp, \
PL_stack_sp = PL_stack_base + cx->blk_oldsp, \
PL_markstack_ptr = PL_markstack + cx->blk_oldmarksp, \
PL_scopestack_ix = cx->blk_oldscopesp, \
PL_retstack_ix = cx->blk_oldretsp
PL_retstack_ix = cx->blk_oldretsp, \
PL_curpm = cx->blk_oldpm
/* substitution context */
struct subst {
@ -261,12 +262,14 @@ struct subst {
rxres_free(&cx->sb_rxres)
struct context {
I32 cx_type; /* what kind of context this is */
U32 cx_type; /* what kind of context this is */
union {
struct block cx_blk;
struct subst cx_subst;
} cx_u;
};
#define CXTYPEMASK 0xff
#define CXt_NULL 0
#define CXt_SUB 1
#define CXt_EVAL 2
@ -274,6 +277,12 @@ struct context {
#define CXt_SUBST 4
#define CXt_BLOCK 5
/* private flags for CXt_EVAL */
#define CXp_REAL 0x00000100 /* truly eval'', not a lookalike */
#define CxTYPE(c) ((c)->cx_type & CXTYPEMASK)
#define CxREALEVAL(c) (((c)->cx_type & (CXt_EVAL|CXp_REAL)) == (CXt_EVAL|CXp_REAL))
#define CXINC (cxstack_ix < cxstack_max ? ++cxstack_ix : (cxstack_ix = cxinc()))
/* "gimme" values */

11
contrib/perl5/cv.h
View File

@ -1,6 +1,6 @@
/* cv.h
*
* Copyright (c) 1991-1997, Larry Wall
* Copyright (c) 1991-1999, Larry Wall
*
* You may distribute under the terms of either the GNU General Public
* License or the Artistic License, as specified in the README file.
@ -94,3 +94,12 @@ struct xpvcv {
#define CvLOCKED(cv) (CvFLAGS(cv) & CVf_LOCKED)
#define CvLOCKED_on(cv) (CvFLAGS(cv) |= CVf_LOCKED)
#define CvLOCKED_off(cv) (CvFLAGS(cv) &= ~CVf_LOCKED)
#define CvEVAL(cv) (CvUNIQUE(cv) && !SvFAKE(cv))
#define CvEVAL_on(cv) (CvUNIQUE_on(cv),SvFAKE_off(cv))
#define CvEVAL_off(cv) CvUNIQUE_off(cv)
/* BEGIN|INIT|END */
#define CvSPECIAL(cv) (CvUNIQUE(cv) && SvFAKE(cv))
#define CvSPECIAL_on(cv) (CvUNIQUE_on(cv),SvFAKE_on(cv))
#define CvSPECIAL_off(cv) (CvUNIQUE_off(cv),SvFAKE_off(cv))

2
contrib/perl5/deb.c
View File

@ -1,6 +1,6 @@
/* deb.c
*
* Copyright (c) 1991-1997, Larry Wall
* Copyright (c) 1991-1999, Larry Wall
*
* You may distribute under the terms of either the GNU General Public
* License or the Artistic License, as specified in the README file.

65
contrib/perl5/doio.c
View File

@ -1,6 +1,6 @@
/* doio.c
*
* Copyright (c) 1991-1997, Larry Wall
* Copyright (c) 1991-1999, Larry Wall
*
* You may distribute under the terms of either the GNU General Public
* License or the Artistic License, as specified in the README file.
@ -18,13 +18,12 @@
#include "perl.h"
#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
#ifndef HAS_SEM
#include <sys/ipc.h>
#endif
#ifdef HAS_MSG
#include <sys/msg.h>
#endif
#ifdef HAS_SEM
#include <sys/sem.h>
#endif
#ifdef HAS_SHM
#include <sys/shm.h>
# ifndef HAS_SHMAT_PROTOTYPE
@ -359,8 +358,12 @@ do_open(GV *gv, register char *name, I32 len, int as_raw, int rawmode, int rawpe
PerlIO_clearerr(fp);
}
#if defined(HAS_FCNTL) && defined(F_SETFD)
fd = PerlIO_fileno(fp);
fcntl(fd,F_SETFD,fd > PL_maxsysfd);
{
int save_errno = errno;
fd = PerlIO_fileno(fp);
fcntl(fd,F_SETFD,fd > PL_maxsysfd); /* can change errno */
errno = save_errno;
}
#endif
IoIFP(io) = fp;
if (writing) {
@ -545,7 +548,7 @@ nextargv(register GV *gv)
}
else
PerlIO_printf(PerlIO_stderr(), "Can't open %s: %s\n",
SvPV(sv, PL_na), Strerror(errno));
SvPV(sv, oldlen), Strerror(errno));
}
if (PL_inplace) {
(void)do_close(PL_argvoutgv,FALSE);
@ -759,7 +762,7 @@ do_binmode(PerlIO *fp, int iotype, int flag)
if (flag != TRUE)
croak("panic: unsetting binmode"); /* Not implemented yet */
#ifdef DOSISH
#ifdef atarist
#if defined(atarist) || defined(__MINT__)
if (!PerlIO_flush(fp) && (fp->_flag |= _IOBIN))
return 1;
else
@ -920,6 +923,7 @@ my_stat(ARGSproto)
else {
SV* sv = POPs;
char *s;
STRLEN n_a;
PUTBACK;
if (SvTYPE(sv) == SVt_PVGV) {
tmpgv = (GV*)sv;
@ -930,7 +934,7 @@ my_stat(ARGSproto)
goto do_fstat;
}
s = SvPV(sv, PL_na);
s = SvPV(sv, n_a);
PL_statgv = Nullgv;
sv_setpv(PL_statname, s);
PL_laststype = OP_STAT;
@ -946,6 +950,7 @@ my_lstat(ARGSproto)
{
djSP;
SV *sv;
STRLEN n_a;
if (PL_op->op_flags & OPf_REF) {
EXTEND(SP,1);
if (cGVOP->op_gv == PL_defgv) {
@ -960,13 +965,13 @@ my_lstat(ARGSproto)
PL_statgv = Nullgv;
sv = POPs;
PUTBACK;
sv_setpv(PL_statname,SvPV(sv, PL_na));
sv_setpv(PL_statname,SvPV(sv, n_a));
#ifdef HAS_LSTAT
PL_laststatval = PerlLIO_lstat(SvPV(sv, PL_na),&PL_statcache);
PL_laststatval = PerlLIO_lstat(SvPV(sv, n_a),&PL_statcache);
#else
PL_laststatval = PerlLIO_stat(SvPV(sv, PL_na),&PL_statcache);
PL_laststatval = PerlLIO_stat(SvPV(sv, n_a),&PL_statcache);
#endif
if (PL_laststatval < 0 && PL_dowarn && strchr(SvPV(sv, PL_na), '\n'))
if (PL_laststatval < 0 && PL_dowarn && strchr(SvPV(sv, n_a), '\n'))
warn(warn_nl, "lstat");
return PL_laststatval;
}
@ -976,6 +981,7 @@ do_aexec(SV *really, register SV **mark, register SV **sp)
{
register char **a;
char *tmps;
STRLEN n_a;
if (sp > mark) {
dTHR;
@ -983,14 +989,14 @@ do_aexec(SV *really, register SV **mark, register SV **sp)
a = PL_Argv;
while (++mark <= sp) {
if (*mark)
*a++ = SvPVx(*mark, PL_na);
*a++ = SvPVx(*mark, n_a);
else
*a++ = "";
}
*a = Nullch;
if (*PL_Argv[0] != '/') /* will execvp use PATH? */
TAINT_ENV(); /* testing IFS here is overkill, probably */
if (really && *(tmps = SvPV(really, PL_na)))
if (really && *(tmps = SvPV(really, n_a)))
PerlProc_execvp(tmps,PL_Argv);
else
PerlProc_execvp(PL_Argv[0],PL_Argv);
@ -1116,10 +1122,11 @@ apply(I32 type, register SV **mark, register SV **sp)
char *what;
char *s;
SV **oldmark = mark;
STRLEN n_a;
#define APPLY_TAINT_PROPER() \
STMT_START { \
if (PL_tainting && PL_tainted) { goto taint_proper_label; } \
if (PL_tainted) { TAINT_PROPER(what); } \
} STMT_END
/* This is a first heuristic; it doesn't catch tainting magic. */
@ -1141,7 +1148,7 @@ apply(I32 type, register SV **mark, register SV **sp)
APPLY_TAINT_PROPER();
tot = sp - mark;
while (++mark <= sp) {
char *name = SvPVx(*mark, PL_na);
char *name = SvPVx(*mark, n_a);
APPLY_TAINT_PROPER();
if (PerlLIO_chmod(name, val))
tot--;
@ -1158,7 +1165,7 @@ apply(I32 type, register SV **mark, register SV **sp)
APPLY_TAINT_PROPER();
tot = sp - mark;
while (++mark <= sp) {
char *name = SvPVx(*mark, PL_na);
char *name = SvPVx(*mark, n_a);
APPLY_TAINT_PROPER();
if (PerlLIO_chown(name, val, val2))
tot--;
@ -1178,7 +1185,7 @@ nothing in the core.
APPLY_TAINT_PROPER();
if (mark == sp)
break;
s = SvPVx(*++mark, PL_na);
s = SvPVx(*++mark, n_a);
if (isUPPER(*s)) {
if (*s == 'S' && s[1] == 'I' && s[2] == 'G')
s += 3;
@ -1248,7 +1255,7 @@ nothing in the core.
APPLY_TAINT_PROPER();
tot = sp - mark;
while (++mark <= sp) {
s = SvPVx(*mark, PL_na);
s = SvPVx(*mark, n_a);
APPLY_TAINT_PROPER();
if (PL_euid || PL_unsafe) {
if (UNLINK(s))
@ -1277,23 +1284,23 @@ nothing in the core.
struct utimbuf utbuf;
#else
struct {
long actime;
long modtime;
Time_t actime;
Time_t modtime;
} utbuf;
#endif
Zero(&utbuf, sizeof utbuf, char);
#ifdef BIG_TIME
utbuf.actime = (Time_t)SvNVx(*++mark); /* time accessed */
utbuf.modtime = (Time_t)SvNVx(*++mark); /* time modified */
utbuf.actime = (Time_t)SvNVx(*++mark); /* time accessed */
utbuf.modtime = (Time_t)SvNVx(*++mark); /* time modified */
#else
utbuf.actime = SvIVx(*++mark); /* time accessed */
utbuf.modtime = SvIVx(*++mark); /* time modified */
utbuf.actime = (Time_t)SvIVx(*++mark); /* time accessed */
utbuf.modtime = (Time_t)SvIVx(*++mark); /* time modified */
#endif
APPLY_TAINT_PROPER();
tot = sp - mark;
while (++mark <= sp) {
char *name = SvPVx(*mark, PL_na);
char *name = SvPVx(*mark, n_a);
APPLY_TAINT_PROPER();
if (PerlLIO_utime(name, &utbuf))
tot--;
@ -1306,10 +1313,6 @@ nothing in the core.
}
return tot;
taint_proper_label:
TAINT_PROPER(what);
return 0; /* this should never happen */
#undef APPLY_TAINT_PROPER
}

7
contrib/perl5/doop.c
View File

@ -1,6 +1,6 @@
/* doop.c
*
* Copyright (c) 1991-1997, Larry Wall
* Copyright (c) 1991-1999, Larry Wall
*
* You may distribute under the terms of either the GNU General Public
* License or the Artistic License, as specified in the README file.
@ -352,7 +352,8 @@ do_vop(I32 optype, SV *sv, SV *left, SV *right)
len = leftlen < rightlen ? leftlen : rightlen;
lensave = len;
if (SvOK(sv) || SvTYPE(sv) > SVt_PVMG) {
dc = SvPV_force(sv, PL_na);
STRLEN n_a;
dc = SvPV_force(sv, n_a);
if (SvCUR(sv) < len) {
dc = SvGROW(sv, len + 1);
(void)memzero(dc + SvCUR(sv), len - SvCUR(sv) + 1);
@ -491,7 +492,7 @@ do_kv(ARGSproto)
RETURN;
}
if (!SvRMAGICAL(keys) || !mg_find((SV*)keys,'P'))
if (! SvTIED_mg((SV*)keys, 'P'))
i = HvKEYS(keys);
else {
i = 0;

5
contrib/perl5/dump.c
View File

@ -1,6 +1,6 @@
/* dump.c
*
* Copyright (c) 1991-1997, Larry Wall
* Copyright (c) 1991-1999, Larry Wall
*
* You may distribute under the terms of either the GNU General Public
* License or the Artistic License, as specified in the README file.
@ -239,11 +239,12 @@ dump_op(OP *o)
case OP_GVSV:
case OP_GV:
if (cGVOPo->op_gv) {
STRLEN n_a;
SV *tmpsv = NEWSV(0,0);
ENTER;
SAVEFREESV(tmpsv);
gv_fullname3(tmpsv, cGVOPo->op_gv, Nullch);
dump("GV = %s\n", SvPV(tmpsv, PL_na));
dump("GV = %s\n", SvPV(tmpsv, n_a));
LEAVE;
}
else

8
contrib/perl5/eg/ADB Normal file
View File

@ -0,0 +1,8 @@
#!/usr/bin/perl
# $RCSfile: ADB,v $$Revision: 4.1 $$Date: 92/08/07 17:20:06 $
# This script is only useful when used in your crash directory.
$num = shift;
exec 'adb', '-k', "vmunix.$num", "vmcore.$num";

22
contrib/perl5/eg/README Normal file
View File

@ -0,0 +1,22 @@
Although supplied with the perl package, the perl scripts in this eg
directory and its subdirectories are placed in the public domain, and
you may do anything with them that you wish.
This stuff is supplied on an as-is basis--little attempt has been made to make
any of it portable. It's mostly here to give you an idea of what perl code
looks like, and what tricks and idioms are used.
System administrators responsible for many computers will enjoy the items
down in the g directory very much. The scan directory contains the beginnings
of a system to check on and report various kinds of anomalies.
If you machine doesn't support #!, the first thing you'll want to do is
replace the #! with a couple of lines that look like this:
eval 'exec /usr/bin/perl -S $0 ${1+"$@"}'
if $running_under_some_shell;
being sure to include any flags that were on the #! line. A supplied script
called "nih" will translate perl scripts in place for you:
nih g/g??

36
contrib/perl5/eg/cgi/RunMeFirst Executable file
View File

@ -0,0 +1,36 @@
#!/usr/local/bin/perl
# Make a world-writeable directory for saving state.
$ww = 'WORLD_WRITABLE';
unless (-w $ww) {
$u = umask 0;
mkdir $ww, 0777;
umask $u;
}
# Decode the sample image.
for $uu (<*.uu>) {
unless (open UU, "<$uu") { warn "Can't open $uu: $!\n"; next }
while (<UU>) {
chomp;
if (/^begin\s+\d+\s+(.+)$/) {
$bin = $1;
last;
}
}
unless (open BIN, "> $bin") { warn "Can't create $bin: $!\n"; next }
binmode BIN;
while (<UU>) {
chomp;
last if /^end/;
print BIN unpack "u", $_;
}
close BIN;
close UU;
}
# Create symlinks from *.txt to *.cgi for documentation purposes.
foreach (<*.cgi>) {
($target = $_) =~ s/cgi$/txt/i;
symlink $_, $target unless -e $target;
}

12
contrib/perl5/eg/cgi/caution.xbm Normal file
View File

@ -0,0 +1,12 @@
#define caution_width 32
#define caution_height 32
static char caution_bits[] = {
0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xe0,0x00,0x00,0x00,0x10,0x01,
0x00,0x00,0x08,0x07,0x00,0x00,0x08,0x0e,0x00,0x00,0x04,0x0e,0x00,0x00,0x04,
0x1c,0x00,0x00,0x02,0x1c,0x00,0x00,0xe2,0x38,0x00,0x00,0xf1,0x39,0x00,0x00,
0xf1,0x71,0x00,0x80,0xf0,0x71,0x00,0x80,0xf0,0xe1,0x00,0x40,0xf0,0xe1,0x00,
0x40,0xf0,0xc1,0x01,0x20,0xf0,0xc1,0x01,0x20,0xf0,0x81,0x03,0x10,0xe0,0x80,
0x03,0x10,0xe0,0x00,0x07,0x08,0xe0,0x00,0x07,0x08,0xe0,0x00,0x0e,0x04,0x00,
0x00,0x0e,0x04,0xe0,0x00,0x1c,0x02,0xf0,0x01,0x1c,0x02,0xf0,0x01,0x38,0x01,
0xe0,0x00,0x38,0x01,0x00,0x00,0x70,0x01,0x00,0x00,0x70,0xff,0xff,0xff,0x7f,
0xf8,0xff,0xff,0x3f,0x00,0x00,0x00,0x00};

26
contrib/perl5/eg/cgi/clickable_image.cgi Normal file
View File

@ -0,0 +1,26 @@
#!/usr/local/bin/perl
use CGI;
$query = new CGI;
print $query->header;
print $query->start_html("A Clickable Image");
print <<END;
<H1>A Clickable Image</H1>
</A>
END
print "Sorry, this isn't very exciting!\n";
print $query->startform;
print $query->image_button('picture',"./wilogo.gif");
print "Give me a: ",$query->popup_menu('letter',['A','B','C','D','E','W']),"\n"; #
print "<P>Magnification: ",$query->radio_group('magnification',['1X','2X','4X','20X']),"\n";
print "<HR>\n";
if ($query->param) {
print "<P>Magnification, <EM>",$query->param('magnification'),"</EM>\n";
print "<P>Selected Letter, <EM>",$query->param('letter'),"</EM>\n";
($x,$y) = ($query->param('picture.x'),$query->param('picture.y'));
print "<P>Selected Position <EM>($x,$y)</EM>\n";
}
print $query->end_html;

88
contrib/perl5/eg/cgi/cookie.cgi Normal file
View File

@ -0,0 +1,88 @@
#!/usr/local/bin/perl
use CGI qw(:standard);
@ANIMALS=sort qw/lion tiger bear pig porcupine ferret zebra gnu ostrich
emu moa goat weasel yak chicken sheep hyena dodo lounge-lizard
squirrel rat mouse hedgehog racoon baboon kangaroo hippopotamus
giraffe/;
# Recover the previous animals from the magic cookie.
# The cookie has been formatted as an associative array
# mapping animal name to the number of animals.
%zoo = cookie('animals');
# Recover the new animal(s) from the parameter 'new_animal'
@new = param('new_animals');
# If the action is 'add', then add new animals to the zoo. Otherwise
# delete them.
foreach (@new) {
if (param('action') eq 'Add') {
$zoo{$_}++;
} elsif (param('action') eq 'Delete') {
$zoo{$_}-- if $zoo{$_};
delete $zoo{$_} unless $zoo{$_};
}
}
# Add new animals to old, and put them in a cookie
$the_cookie = cookie(-name=>'animals',
-value=>\%zoo,
-expires=>'+1h');
# Print the header, incorporating the cookie and the expiration date...
print header(-cookie=>$the_cookie);
# Now we're ready to create our HTML page.
print start_html('Animal crackers');
print <<EOF;
<h1>Animal Crackers</h1>
Choose the animals you want to add to the zoo, and click "add".
Come back to this page any time within the next hour and the list of
animals in the zoo will be resurrected. You can even quit Netscape
completely!
<p>
Try adding the same animal several times to the list. Does this
remind you vaguely of a shopping cart?
<p>
<em>This script only works with Netscape browsers</em>
<p>
<center>
<table border>
<tr><th>Add/Delete<th>Current Contents
EOF
;
print "<tr><td>",start_form;
print scrolling_list(-name=>'new_animals',
-values=>[@ANIMALS],
-multiple=>1,
-override=>1,
-size=>10),"<br>";
print submit(-name=>'action',-value=>'Delete'),
submit(-name=>'action',-value=>'Add');
print end_form;
print "<td>";
if (%zoo) { # make a table
print "<ul>\n";
foreach (sort keys %zoo) {
print "<li>$zoo{$_} $_\n";
}
print "</ul>\n";
} else {
print "<strong>The zoo is empty.</strong>\n";
}
print "</table></center>";
print <<EOF;
<hr>
<ADDRESS>Lincoln D. Stein</ADDRESS><BR>
<A HREF="./">More Examples</A>
EOF
;
print end_html;

6
contrib/perl5/eg/cgi/crash.cgi Normal file
View File

@ -0,0 +1,6 @@
#!/usr/local/bin/perl
use CGI::Carp qw(fatalsToBrowser);
# This line invokes a fatal error message at compile time.
foo bar baz;

92
contrib/perl5/eg/cgi/customize.cgi Normal file
View File

@ -0,0 +1,92 @@
#!/usr/local/bin/perl
use CGI qw(:standard :html3);
# Some constants to use in our form.
@colors=qw/aqua black blue fuschia gray green lime maroon navy olive
purple red silver teal white yellow/;
@sizes=("<default>",1..7);
# recover the "preferences" cookie.
%preferences = cookie('preferences');
# If the user wants to change the background color or her
# name, they will appear among our CGI parameters.
foreach ('text','background','name','size') {
$preferences{$_} = param($_) || $preferences{$_};
}
# Set some defaults
$preferences{'background'} = $preferences{'background'} || 'silver';
$preferences{'text'} = $preferences{'text'} || 'black';
# Refresh the cookie so that it doesn't expire. This also
# makes any changes the user made permanent.
$the_cookie = cookie(-name=>'preferences',
-value=>\%preferences,
-expires=>'+30d');
print header(-cookie=>$the_cookie);
# Adjust the title to incorporate the user's name, if provided.
$title = $preferences{'name'} ?
"Welcome back, $preferences{name}!" : "Customizable Page";
# Create the HTML page. We use several of Netscape's
# extended tags to control the background color and the
# font size. It's safe to use Netscape features here because
# cookies don't work anywhere else anyway.
print start_html(-title=>$title,
-bgcolor=>$preferences{'background'},
-text=>$preferences{'text'}
);
print basefont({SIZE=>$preferences{size}}) if $preferences{'size'} > 0;
print h1($title),<<END;
You can change the appearance of this page by submitting
the fill-out form below. If you return to this page any time
within 30 days, your preferences will be restored.
END
;
# Create the form
print hr(),
start_form,
"Your first name: ",
textfield(-name=>'name',
-default=>$preferences{'name'},
-size=>30),br,
table(
TR(
td("Preferred"),
td("Page color:"),
td(popup_menu(-name=>'background',
-values=>\@colors,
-default=>$preferences{'background'})
),
),
TR(
td(''),
td("Text color:"),
td(popup_menu(-name=>'text',
-values=>\@colors,
-default=>$preferences{'text'})
)
),
TR(
td(''),
td("Font size:"),
td(popup_menu(-name=>'size',
-values=>\@sizes,
-default=>$preferences{'size'})
)
)
),
submit(-label=>'Set preferences'),
hr;
print a({HREF=>"/"},'Go to the home page');
print end_html;

68
contrib/perl5/eg/cgi/diff_upload.cgi Normal file
View File

@ -0,0 +1,68 @@
#!/usr/local/bin/perl
$DIFF = "/usr/bin/diff";
$PERL = "/usr/bin/perl";
use CGI qw(:standard);
use CGI::Carp;
print header;
print start_html("File Diff Example");
print "<strong>Version </strong>$CGI::VERSION<p>";
print <<EOF;
<H1>File Diff Example</H1>
Enter two files. When you press "submit" their diff will be
produced.
EOF
;
# Start a multipart form.
print start_multipart_form;
print "File #1:",filefield(-name=>'file1',-size=>45),"<BR>\n";
print "File #2:",filefield(-name=>'file2',-size=>45),"<BR>\n";
print "Diff type: ",radio_group(-name=>'type',
-value=>['context','normal']),"<br>\n";
print reset,submit(-name=>'submit',-value=>'Do Diff');
print endform;
# Process the form if there is a file name entered
$file1 = param('file1');
$file2 = param('file2');
$|=1; # for buffering
if ($file1 && $file2) {
$realfile1 = tmpFileName($file1);
$realfile2 = tmpFileName($file2);
print "<HR>\n";
print "<H2>$file1 vs $file2</H2>\n";
print "<PRE>\n";
$options = "-c" if param('type') eq 'context';
system "$DIFF $options $realfile1 $realfile2 | $PERL -pe 's/>/&gt;/g; s/</&lt;/g;'";
close $file1;
close $file2;
print "</PRE>\n";
}
print <<EOF;
<HR>
<A HREF="../cgi_docs.html">CGI documentation</A>
<HR>
<ADDRESS>
<A HREF="/~lstein">Lincoln D. Stein</A>
</ADDRESS><BR>
Last modified 17 July 1996
EOF
;
print end_html;
sub sanitize {
my $name = shift;
my($safe) = $name=~/([a-zA-Z0-9._~#,]+)/;
unless ($safe) {
print "<strong>$name is not a valid Unix filename -- sorry</strong>";
exit 0;
}
return $safe;
}

63
contrib/perl5/eg/cgi/dna.small.gif.uu Normal file
View File

@ -0,0 +1,63 @@
begin 444 dna.small.gif
M1TE&.#=A)0`J`.<``+9%&Y<R0M<F'ID\,!<07%<G1:P<0Q`A2Q`P;"L9/L$:
M,"480N5"&RL7:4LD0T,G144[7BHL2B4?3\0I+"</)BQ.9KD0/S878\96$Z\@
M(:\1*RL:3L0W&QL?2#4?9>@_&A$_5<I"&C`A3*,3-A`//9X<)\@Q(L`@.#\E
M7K,R*R\T6)H++1L72T8=4207:T`G=JX..MD^&!$_;^)2$#T=7S`79AL7.A$3
M1-=%#^,Q&QT_:C8=1!L86]\R#4M":4H76R,515HZ4"477G@T,J\;(X(@/$\7
M."4A2N9;$"DZ6RL34-8I$34A73P86I84/\87%1`0/V,B2"0<0N!(%QPH91<6
M2=!5$3(=73(E23`/,!L4.=$Z'-MH%>`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<V;]\I&&<K/8!*.R044>=/#YH>
M08$I1B,09S$35R(:4C0?<19$7<D^#Q`>5!()-;4702M`=;56)A`25,0K%"X<
M83`N>K`H'HDS*1`40,M&%!<@7M,_$A<N2L)%%18E4^<M$A@=5=0Q$Q`E311*
M2L8E&2D<7Q\A7P\80B48,%E/8[1-'J4/-"H<3"PA1$,T?Q<15R44,R,A4AL/
M,^M4%2,07!L+,[\[&!P4520I:C(9.=54$[,2/M-)&RP?7M=(%1$J8<-,%2H@
M4B,=51436^]2"!X<1A<44RD</>E+#%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=*<E3'5K(:EHS2N%"AP*Y(\&##H6(!A:!XU99B*H?%4IDF?
M!8'<"-F%9I*TH8A83:*TXYD!J83D$0ICI-NE(:O8I6&FJ$64$M5$M%!3PU,F
M2UJD"9I41E824WT2G?BV-!$(!`=,+<IF!P>.%",&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`<D^74R@P2#?T*'/$"%@\(L5Y?RAB!SO3#*,-6CL44\4]C1#
MR0Q3C&&"!AH08@(#:Y2C@`&1---,.#)\T84=R##`0",H++8#)34,@X80R:"`
M0A<]?'#.!";`TDH.8QBB0354A!,*)WI0\<D\YJRQ3PE[V",(.D#48$T9GO22
MA0.BC,)'*]3TP,`^\_#QA0P@>`/"*]=<HX\3"C!BAQV%5",$+Z0,0X,UL3SB
M#B[NN$'/,A&,$L,Y[-BASR(@<**("E^,0(<&;[QA0@^,3%",#2S8H,01_LX0
M`(0:W%`@13#TN+'#&LK@0$T0VER##50*Q/%-%%&H$`0#K7"`!B^X/`),()F0
M0PNT[K#BRBS1-!("`^=,$8`D="B`QRW?1**+-I?(X$@(L(R2AQ8+Y,*#-*YX
MH(00'1Q!CSI,U'!%)^_%4(X&FUB@01$.@*!#$I?4D48I&1BA!2*HD%))(.+T
MYTEOT3B#PB/U4(,$%QD0(<\QX^CRBC=)@%`!&+:<<TH&M*C1"RJX'-'.'`YX
M<H0@<)#"0CX+I%`*-%:4L@XFS`#[11M?U-))"&RP84LWZL!A1A^YH.*)!)3<
MHXX6L]P3"!I`H/!`*>90`PD.F'3SR@-AG)`&_A=3'"**#[J(P<<I@YCA2@32
M!,*+Q9H`(XT2'O2RS"CGS.U9!K>0^C0&S/#1""(ZI)'&*6,,$842N%Q!@3NK
M"R'%%4KP0D(Q?"`S!3)<I#!!".68$T(IMHP#>BVE(/$+)#-80<PTLBRP^@$>
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"<B$<]EG"(#*C"
M%-(@0":\L0U?D&`#_L50@33.(`4M4``=&4@'+-9!!P9JP`#9T$4H=*$+!#1B
M'3A(`SYH`81'B.,(XJ@"":0(CDRPH@/<"$88V+"%$N#A&)MPX0N2H`L]C&,<
MEW"$%6:0BCV@XPIH>$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'<X0[-N$(N@)$+4$C@`<(`
M$(&/<8Q;7$,1UT"``+>P!57`X1F9D`4<W$`"4MP@$ZYX\B-"004Y2$`.HT@%
M)@IAB#><0!]FB(<I.(&`(7P"%GPPQ3)F`0YB0"$0@8"")L!Q!RH`8A&AL,8L
BR!$$,@@#&5OX!1V.\85XA.,.,A##!T2!AP@LXP#;"`@`.P``
end

69
contrib/perl5/eg/cgi/file_upload.cgi Normal file
View File

@ -0,0 +1,69 @@
#!/usr/local/bin/perl -w
use lib '..';
use CGI qw(:standard);
use CGI::Carp qw/fatalsToBrowser/;
print header();
print start_html("File Upload Example");
print strong("Version "),$CGI::VERSION,p;
print h1("File Upload Example"),
'This example demonstrates how to prompt the remote user to
select a remote file for uploading. ',
strong("This feature only works with Netscape 2.0 browsers."),
p,
'Select the ',cite('browser'),' button to choose a text file
to upload. When you press the submit button, this script
will count the number of lines, words, and characters in
the file.';
@types = ('count lines','count words','count characters');
# Start a multipart form.
print start_multipart_form(),
"Enter the file to process:",
filefield('filename','',45),
br,
checkbox_group('count',\@types,\@types),
p,
reset,submit('submit','Process File'),
endform;
# Process the form if there is a file name entered
if ($file = param('filename')) {
$tmpfile=tmpFileName($file);
$mimetype = uploadInfo($file)->{'Content-Type'} || '';
print hr(),
h2($file),
h3($tmpfile),
h4("MIME Type:",em($mimetype));
my($lines,$words,$characters,@words) = (0,0,0,0);
while (<$file>) {
$lines++;
$words += @words=split(/\s+/);
$characters += length($_);
}
close $file;
grep($stats{$_}++,param('count'));
if (%stats) {
print strong("Lines: "),$lines,br if $stats{'count lines'};
print strong("Words: "),$words,br if $stats{'count words'};
print strong("Characters: "),$characters,br if $stats{'count characters'};
} else {
print strong("No statistics selected.");
}
}
# print cite("URL parameters: "),url_param();
print hr(),
a({href=>"../cgi_docs.html"},"CGI documentation"),
hr,
address(
a({href=>'/~lstein'},"Lincoln D. Stein")),
br,
'Last modified July 17, 1996',
end_html;

81
contrib/perl5/eg/cgi/frameset.cgi Normal file
View File

@ -0,0 +1,81 @@
#!/usr/local/bin/perl
use CGI;
$query = new CGI;
print $query->header;
$TITLE="Frameset Example";
# We use the path information to distinguish between calls
# to the script to:
# (1) create the frameset
# (2) create the query form
# (3) create the query response
$path_info = $query->path_info;
# If no path information is provided, then we create
# a side-by-side frame set
if (!$path_info) {
&print_frameset;
exit 0;
}
# If we get here, then we either create the query form
# or we create the response.
&print_html_header;
&print_query if $path_info=~/query/;
&print_response if $path_info=~/response/;
&print_end;
# Create the frameset
sub print_frameset {
$script_name = $query->script_name;
print <<EOF;
<html><head><title>$TITLE</title></head>
<frameset cols="50,50">
<frame src="$script_name/query" name="query">
<frame src="$script_name/response" name="response">
</frameset>
EOF
;
exit 0;
}
sub print_html_header {
print $query->start_html($TITLE);
}
sub print_end {
print qq{<P><hr><A HREF="../index.html" TARGET="_top">More Examples</A>};
print $query->end_html;
}
sub print_query {
$script_name = $query->script_name;
print "<H1>Frameset Query</H1>\n";
print $query->startform(-action=>"$script_name/response",-TARGET=>"response");
print "What's your name? ",$query->textfield('name');
print "<P>What's the combination?<P>",
$query->checkbox_group(-name=>'words',
-values=>['eenie','meenie','minie','moe']);
print "<P>What's your favorite color? ",
$query->popup_menu(-name=>'color',
-values=>['red','green','blue','chartreuse']),
"<P>";
print $query->submit;
print $query->endform;
}
sub print_response {
print "<H1>Frameset Result</H1>\n";
unless ($query->param) {
print "<b>No query submitted yet.</b>";
return;
}
print "Your name is <EM>",$query->param(name),"</EM>\n";
print "<P>The keywords are: <EM>",join(", ",$query->param(words)),"</EM>\n";
print "<P>Your favorite color is <EM>",$query->param(color),"</EM>\n";
}

118
contrib/perl5/eg/cgi/index.html Normal file
View File

@ -0,0 +1,118 @@
<HTML> <HEAD>
<TITLE>More Examples of Scripts Created with CGI.pm</TITLE>
</HEAD>
<BODY>
<H1>More Examples of Scripts Created with CGI.pm</H1>
<H2> Basic Non Sequitur Questionnaire</H2>
<UL>
<LI> <A HREF="tryit.cgi">Try the script</A>
<LI> <A HREF="tryit.txt">Look at its source code</A>
</UL>
<H2> Advanced Non Sequitur Questionnaire</H2>
<UL>
<LI> <A HREF="monty.cgi">Try the script</A>
<LI> <A HREF="monty.txt">Look at its source code</A>
</UL>
<H2> Save and restore the state of a form to a file</H2>
<UL>
<LI> <A HREF="save_state.cgi">Try the script</A>
<LI> <A HREF="save_state.txt">Look at its source code</A>
</UL>
<H2> Server Push</H2>
<ul>
<li><a href="nph-multipart.cgi">Try the script</a>
<li><a href="nph-multipart.txt">Look at its source code</a>
</ul>
<H2> Read the coordinates from a clickable image map</H2>
<UL>
<LI> <A HREF="clickable_image.cgi">Try the script</A>
<LI> <A HREF="clickable_image.txt">Look at its source code</A>
</UL>
<H2> Multiple independent forms on the same page</H2>
<UL>
<LI> <A HREF="multiple_forms.cgi">Try the script</A>
<LI> <A HREF="multiple_forms.txt">Look at its source code</A>
</UL>
<H2> How to maintain state on a page with internal links</H2>
<UL>
<LI> <A HREF="internal_links.cgi">Try the script</A>
<LI> <A HREF="internal_links.txt">Look at its source code</A>
</UL>
<h2>Echo fatal script errors to the browser</h2>
<em>This script deliberately generates a compile-time error.</em>
<ul>
<li><a href="crash.cgi">Try the script</a>
<li><a href="crash.txt">Look at its source code</a>
</ul>
<EM>The Following Scripts only Work with Netscape 2.0 & Internet Explorer only!</EM>
<H2> Prompt for a file to upload and process it</H2>
<UL>
<LI> <A HREF="file_upload.cgi">Try the script</A>
<LI> <A HREF="file_upload.txt">Look at its source code</A>
</UL>
<h2> A Continuously-Updated Page using Server Push</h2>
<ul>
<li><a href="nph-clock.cgi">Try the script</a>
<li><a href="nph-clock.txt">Look at its source code</a>
</ul>
<h2>Compute the "diff" between two uploaded files</h2>
<ul>
<li><a href="diff_upload.cgi">Try the script</a>
<li><a href="diff_upload.txt">Look at its source code</a>
</ul>
<h2>Maintain state over a long period with a cookie</h2>
<ul>
<li><a href="cookie.cgi">Try the script</a>
<li><a href="cookie.txt">Look at its source code</a>
</ul>
<h2>Permanently customize the appearance of a page with a cookie</h2>
<ul>
<li><a href="customize.cgi">Try the script</a>
<li><a href="customize.txt">Look at its source code</a>
</ul>
<h2> Popup the response in a new window</h2>
<ul>
<li><a href="popup.cgi">Try the script</a>
<li><a href="popup.txt">Look at its source code</a>
</ul>
<h2> Side-by-side form and response using frames</h2>
<ul>
<li><a href="frameset.cgi">Try the script</a>
<li><a href="frameset.txt">Look at its source code</a>
</ul>
<h2>Verify the Contents of a fill-out form with JavaScript</h2>
<ul>
<li><a href="javascript.cgi">Try the script</a>
<li><a href="javascript.txt">Look at its source code</a>
</ul>
<HR>
<MENU>
<LI> <A HREF="../cgi_docs.html">CGI.pm documentation</A>
<LI> <A HREF="../../CGI.pm.tar.gz">Download the CGI.pm distribution</A>
</MENU>
<HR>
<ADDRESS>Lincoln D. Stein, lstein@genome.wi.mit.edu<br>
<a href="/">Whitehead Institute/MIT Center for Genome Research</a></ADDRESS>
<!-- hhmts start -->
Last modified: Tue May 19 22:16:43 EDT 1998
<!-- hhmts end -->
</BODY> </HTML>

33
contrib/perl5/eg/cgi/internal_links.cgi Normal file
View File

@ -0,0 +1,33 @@
#!/usr/local/bin/perl
use CGI;
$query = new CGI;
# We generate a regular HTML file containing a very long list
# and a popup menu that does nothing except to show that we
# don't lose the state information.
print $query->header;
print $query->start_html("Internal Links Example");
print "<H1>Internal Links Example</H1>\n";
print "Click <cite>Submit Query</cite> to create a state. Then scroll down and",
" click on any of the <cite>Jump to top</cite> links. This is not very exciting.";
print "<A NAME=\"start\"></A>\n"; # an anchor point at the top
# pick a default starting value;
$query->param('amenu','FOO1') unless $query->param('amenu');
print $query->startform;
print $query->popup_menu('amenu',[('FOO1'..'FOO9')]);
print $query->submit,$query->endform;
# We create a long boring list for the purposes of illustration.
$myself = $query->self_url;
print "<OL>\n";
for (1..100) {
print qq{<LI>List item #$_ <A HREF="$myself#start">Jump to top</A>\n};
}
print "</OL>\n";
print $query->end_html;

105
contrib/perl5/eg/cgi/javascript.cgi Normal file
View File

@ -0,0 +1,105 @@
#!/usr/local/bin/perl
# This script illustrates how to use JavaScript to validate fill-out
# forms.
use CGI qw(:standard);
# Here's the javascript code that we include in the document.
$JSCRIPT=<<EOF;
// validate that the user is the right age. Return
// false to prevent the form from being submitted.
function validateForm() {
var today = new Date();
var birthday = validateDate(document.form1.birthdate);
if (birthday == 0) {
document.form1.birthdate.focus()
document.form1.birthdate.select();
return false;
}
var milliseconds = today.getTime()-birthday;
var years = milliseconds/(1000 * 60 * 60 * 24 * 365.25);
if ((years > 20) || (years < 5)) {
alert("You must be between the ages of 5 and 20 to submit this form");
document.form1.birthdate.focus();
document.form1.birthdate.select();
return false;
}
// Since we've calculated the age in years already,
// we might as well send it up to our CGI script.
document.form1.age.value=Math.floor(years);
return true;
}
// make sure that the contents of the supplied
// field contain a valid date.
function validateDate(element) {
var date = Date.parse(element.value);
if (0 == date) {
alert("Please enter date in format MMM DD, YY");
element.focus();
element.select();
}
return date;
}
// Compliments, compliments
function doPraise(element) {
if (element.checked) {
self.status=element.value + " is an excellent choice!";
return true;
} else {
return false;
}
}
function checkColor(element) {
var color = element.options[element.selectedIndex].text;
if (color == "blonde") {
if (confirm("Is it true that blondes have more fun?"))
alert("Darn. That leaves me out.");
} else
alert(color + " is a fine choice!");
}
EOF
;
# here's where the execution begins
print header;
print start_html(-title=>'Personal Profile',-script=>$JSCRIPT);
print h1("Big Brother Wants to Know All About You"),
strong("Note: "),"This page uses JavaScript and requires ",
"Netscape 2.0 or higher to do anything special.";
&print_prompt();
print hr;
&print_response() if param;
print end_html;
sub print_prompt {
print start_form(-name=>'form1',
-onSubmit=>"return validateForm()"),"\n";
print "Birthdate (e.g. Jan 3, 1972): ",
textfield(-name=>'birthdate',
-onBlur=>"validateDate(this)"),"<p>\n";
print "Sex: ",radio_group(-name=>'gender',
-value=>[qw/male female/],
-onClick=>"doPraise(this)"),"<p>\n";
print "Hair color: ",popup_menu(-name=>'color',
-value=>[qw/brunette blonde red gray/],
-default=>'red',
-onChange=>"checkColor(this)"),"<p>\n";
print hidden(-name=>'age',-value=>0);
print submit();
print end_form;
}
sub print_response {
import_names('Q');
print h2("Your profile"),
"You claim to be a ",b($Q::age)," year old ",b($Q::color,$Q::gender),".",
"You should be ashamed of yourself for lying so ",
"blatantly to big brother!",
hr;
}

84
contrib/perl5/eg/cgi/monty.cgi Normal file
View File

@ -0,0 +1,84 @@
#!/usr/local/bin/perl
use CGI;
use CGI::Carp qw/fatalsToBrowser/;
$query = new CGI;
print $query->header;
print $query->start_html("Example CGI.pm Form");
print "<H1> Example CGI.pm Form</H1>\n";
&print_prompt($query);
&do_work($query);
&print_tail;
print $query->end_html;
sub print_prompt {
my($query) = @_;
print $query->start_form;
print "<EM>What's your name?</EM><BR>";
print $query->textfield('name');
print $query->checkbox('Not my real name');
print "<P><EM>Where can you find English Sparrows?</EM><BR>";
print $query->checkbox_group(
-name=>'Sparrow locations',
-Values=>[England,France,Spain,Asia,Hoboken],
-linebreak=>'yes',
-defaults=>[England,Asia]);
print "<P><EM>How far can they fly?</EM><BR>",
$query->radio_group(
-name=>'how far',
-Values=>['10 ft','1 mile','10 miles','real far'],
-default=>'1 mile');
print "<P><EM>What's your favorite color?</EM> ";
print $query->popup_menu(-name=>'Color',
-Values=>['black','brown','red','yellow'],
-default=>'red');
print $query->hidden('Reference','Monty Python and the Holy Grail');
print "<P><EM>What have you got there?</EM><BR>";
print $query->scrolling_list(
-name=>'possessions',
-Values=>['A Coconut','A Grail','An Icon',
'A Sword','A Ticket'],
-size=>5,
-multiple=>'true');
print "<P><EM>Any parting comments?</EM><BR>";
print $query->textarea(-name=>'Comments',
-rows=>10,
-columns=>50);
print "<P>",$query->reset;
print $query->submit('Action','Shout');
print $query->submit('Action','Scream');
print $query->endform;
print "<HR>\n";
}
sub do_work {
my($query) = @_;
my(@values,$key);
print "<H2>Here are the current settings in this form</H2>";
foreach $key ($query->param) {
print "<STRONG>$key</STRONG> -> ";
@values = $query->param($key);
print join(", ",@values),"<BR>\n";
}
}
sub print_tail {
print <<END;
<HR>
<ADDRESS>Lincoln D. Stein</ADDRESS><BR>
<A HREF="/">Home Page</A>
END
;
}

54
contrib/perl5/eg/cgi/multiple_forms.cgi Normal file
View File

@ -0,0 +1,54 @@
#!/usr/local/bin/perl
use CGI;
$query = new CGI;
print $query->header;
print $query->start_html('Multiple Forms');
print "<H1>Multiple Forms</H1>\n";
# Print the first form
print $query->startform;
$name = $query->remote_user || 'anonymous@' . $query->remote_host;
print "What's your name? ",$query->textfield('name',$name,50);
print "<P>What's the combination?<P>",
$query->checkbox_group('words',['eenie','meenie','minie','moe']);
print "<P>What's your favorite color? ",
$query->popup_menu('color',['red','green','blue','chartreuse']),
"<P>";
print $query->submit('form_1','Send Form 1');
print $query->endform;
# Print the second form
print "<HR>\n";
print $query->startform;
print "Some radio buttons: ",$query->radio_group('radio buttons',
[qw{one two three four five}],'three'),"\n";
print "<P>What's the password? ",$query->password_field('pass','secret');
print $query->defaults,$query->submit('form_2','Send Form 2'),"\n";
print $query->endform;
print "<HR>\n";
$query->import_names('Q');
if ($Q::form_1) {
print "<H2>Form 1 Submitted</H2>\n";
print "Your name is <EM>$Q::name</EM>\n";
print "<P>The combination is: <EM>{",join(",",@Q::words),"}</EM>\n";
print "<P>Your favorite color is <EM>$Q::color</EM>\n";
} elsif ($Q::form_2) {
print <<EOF;
<H2>Form 2 Submitted</H2>
<P>The value of the radio buttons is <EM>$Q::radio_buttons</EM>
<P>The secret password is <EM>$Q::pass</EM>
EOF
;
}
print qq{<P><A HREF="./">Other examples</A>};
print qq{<P><A HREF="../cgi_docs.html">Go to the documentation</A>};
print $query->end_html;

18
contrib/perl5/eg/cgi/nph-clock.cgi Normal file
View File

@ -0,0 +1,18 @@
#!/usr/local/bin/perl -w
use CGI::Push qw(:standard :html3);
do_push(-next_page=>\&draw_time,-delay=>1);
sub draw_time {
my $time = `/bin/date`;
return start_html('Tick Tock'),
div({-align=>CENTER},
h1('Virtual Clock'),
h2($time)
),
hr,
a({-href=>'index.html'},'More examples'),
end_html();
}

10
contrib/perl5/eg/cgi/nph-multipart.cgi Executable file
View File

@ -0,0 +1,10 @@
#!/usr/local/bin/perl
use CGI qw/:push -nph/;
$| = 1;
print multipart_init(-boundary=>'----------------here we go!');
while (1) {
print multipart_start(-type=>'text/plain'),
"The current time is ",scalar(localtime),"\n",
multipart_end;
sleep 1;
}

32
contrib/perl5/eg/cgi/popup.cgi Normal file
View File

@ -0,0 +1,32 @@
#!/usr/local/bin/perl
use CGI;
$query = new CGI;
print $query->header;
print $query->start_html('Popup Window');
if (!$query->param) {
print "<H1>Ask your Question</H1>\n";
print $query->startform(-target=>'_new');
print "What's your name? ",$query->textfield('name');
print "<P>What's the combination?<P>",
$query->checkbox_group(-name=>'words',
-values=>['eenie','meenie','minie','moe'],
-defaults=>['eenie','moe']);
print "<P>What's your favorite color? ",
$query->popup_menu(-name=>'color',
-values=>['red','green','blue','chartreuse']),
"<P>";
print $query->submit;
print $query->endform;
} else {
print "<H1>And the Answer is...</H1>\n";
print "Your name is <EM>",$query->param(name),"</EM>\n";
print "<P>The keywords are: <EM>",join(", ",$query->param(words)),"</EM>\n";
print "<P>Your favorite color is <EM>",$query->param(color),"</EM>\n";
}
print qq{<P><A HREF="cgi_docs.html">Go to the documentation</A>};
print $query->end_html;

67
contrib/perl5/eg/cgi/save_state.cgi Normal file
View File

@ -0,0 +1,67 @@
#!/usr/local/bin/perl
use CGI;
$query = new CGI;
print $query->header;
print $query->start_html("Save and Restore Example");
print "<H1>Save and Restore Example</H1>\n";
# Here's where we take action on the previous request
&save_parameters($query) if $query->param('action') eq 'SAVE';
$query = &restore_parameters($query) if $query->param('action') eq 'RESTORE';
# Here's where we create the form
print $query->start_multipart_form;
print "Popup 1: ",$query->popup_menu('popup1',[qw{red green purple magenta orange chartreuse brown}]),"\n";
print "Popup 2: ",$query->popup_menu('popup2',[qw{lion tiger bear zebra potto wildebeest frog emu gazelle}]),"\n";
print "<P>";
$default_name = $query->remote_addr . '.sav';
print "Save/restore state from file: ",$query->textfield('savefile',$default_name),"\n";
print "<P>";
print $query->submit('action','SAVE'),$query->submit('action','RESTORE');
print "<P>",$query->defaults;
print $query->endform;
# Here we print out a bit at the end
print $query->end_html;
sub save_parameters {
local($query) = @_;
local($filename) = &clean_name($query->param('savefile'));
if (open(FILE,">$filename")) {
$query->save(FILE);
close FILE;
print "<STRONG>State has been saved to file $filename</STRONG>\n";
print "<P>If you remember this name you can restore the state later.\n";
} else {
print "<STRONG>Error:</STRONG> couldn't write to file $filename: $!\n";
}
}
sub restore_parameters {
local($query) = @_;
local($filename) = &clean_name($query->param('savefile'));
if (open(FILE,$filename)) {
$query = new CGI(FILE); # Throw out the old query, replace it with a new one
close FILE;
print "<STRONG>State has been restored from file $filename</STRONG>\n";
} else {
print "<STRONG>Error:</STRONG> couldn't restore file $filename: $!\n";
}
return $query;
}
# Very important subroutine -- get rid of all the naughty
# metacharacters from the file name. If there are, we
# complain bitterly and die.
sub clean_name {
local($name) = @_;
unless ($name=~/^[\w\._\-]+$/) {
print "<STRONG>$name has naughty characters. Only ";
print "alphanumerics are allowed. You can't use absolute names.</STRONG>";
die "Attempt to use naughty characters";
}
return "WORLD_WRITABLE/$name";
}

37
contrib/perl5/eg/cgi/tryit.cgi Normal file
View File

@ -0,0 +1,37 @@
#!/usr/local/bin/perl
use CGI ':standard';
print header;
print start_html('A Simple Example'),
h1('A Simple Example'),
start_form,
"What's your name? ",textfield('name'),
p,
"What's the combination?",
p,
checkbox_group(-name=>'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;
}
print a({href=>'../cgi_docs.html'},'Go to the documentation');
print end_html;

13
contrib/perl5/eg/cgi/wilogo.gif.uu Normal file
View File

@ -0,0 +1,13 @@
begin 444 wilogo.gif
M1TE&.#=A7@!$`(```'X2F?___RP`````7@!$```"_D2.J<#MKF)ZU,A3,[OO
M(IUY']A%9"6AW$F)+#2]Y:BNLF6_\;WMH<?#I72^VP+D"@*)F&"O25KRDM&B
M[%C-7;4_J)*6'4ZE&O`W8"1OQ5UGPWRBIKDPM!MW9J]-[;LUKL;$5W.'YQ3(
M(O<&-^>F*(A55\BX%UEI^;<VB0BH1RFX2=<IELE4^*0'N?-I>OJ8N%(*Z^4G
M.OJJ>8HZ.(>;JRMD><E[!KQHB^3;:APL6Z8\RKPK/)O:*-WLW&7]*\UYR]J)
M?<P=1MR-_6VN76,WGAV^32W^3CZ_SCY3;W__C-R^CU^\%M#T!9PVL(ZZ&>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<A6;=YP9'5B++O7:@7
M\]J5]]?DX7:)%<]5%=B/55>-GQW55;$8L\RW6J8-9>QM7<^A/SMZK!ESY$,+
(KPA.EJ```#L`
end

34
contrib/perl5/eg/changes Normal file
View File

@ -0,0 +1,34 @@
#!/usr/bin/perl -P
# $RCSfile: changes,v $$Revision: 4.1 $$Date: 92/08/07 17:20:08 $
($dir, $days) = @ARGV;
$dir = '/' if $dir eq '';
$days = '14' if $days eq '';
# Masscomps do things differently from Suns
#if defined(mc300) || defined(mc500) || defined(mc700)
open(Find, "find $dir -mtime -$days -print |") ||
die "changes: can't run find";
#else
open(Find, "find $dir \\( -fstype nfs -prune \\) -o -mtime -$days -ls |") ||
die "changes: can't run find";
#endif
while (<Find>) {
#if defined(mc300) || defined(mc500) || defined(mc700)
$x = `/bin/ls -ild $_`;
$_ = $x;
($inode,$perm,$links,$owner,$group,$size,$month,$day,$time,$name)
= split(' ');
#else
($inode,$blocks,$perm,$links,$owner,$group,$size,$month,$day,$time,$name)
= split(' ');
#endif
printf("%10s%3s %-8s %-8s%9s %3s %2s %s\n",
$perm,$links,$owner,$group,$size,$month,$day,$name);
}

34
contrib/perl5/eg/client Executable file
View File

@ -0,0 +1,34 @@
#!./perl
$pat = 'S n C4 x8';
$inet = 2;
$echo = 7;
$smtp = 25;
$nntp = 119;
$test = 2345;
$SIG{'INT'} = 'dokill';
$this = pack($pat,$inet,0, 128,149,13,43);
$that = pack($pat,$inet,$test,127,0,0,1);
if (socket(S,2,1,6)) { print "socket ok\n"; } else { die $!; }
if (bind(S,$this)) { print "bind ok\n"; } else { die $!; }
if (connect(S,$that)) { print "connect ok\n"; } else { die $!; }
select(S); $| = 1; select(stdout);
if ($child = fork) {
while (<STDIN>) {
print S;
}
sleep 3;
do dokill();
}
else {
while (<S>) {
print;
}
}
sub dokill { kill 9,$child if $child; }

30
contrib/perl5/eg/down Executable file
View File

@ -0,0 +1,30 @@
#!/usr/bin/perl
$| = 1;
if ($#ARGV >= 0) {
$cmd = join(' ',@ARGV);
}
else {
print "Command: ";
$cmd = <stdin>;
chop($cmd);
while ($cmd =~ s/\\$//) {
print "+ ";
$cmd .= <stdin>;
chop($cmd);
}
}
$cwd = `pwd`; chop($cwd);
open(FIND,'find . -type d -print|') || die "Can't run find";
while (<FIND>) {
chop;
unless (chdir $_) {
print stderr "Can't cd to $_\n";
next;
}
print "\t--> ",$_,"\n";
system $cmd;
chdir $cwd;
}

22
contrib/perl5/eg/dus Normal file
View File

@ -0,0 +1,22 @@
#!/usr/bin/perl
# $RCSfile: dus,v $$Revision: 4.1 $$Date: 92/08/07 17:20:11 $
# This script does a du -s on any directories in the current directory that
# are not mount points for another filesystem.
($mydev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
$blksize,$blocks) = stat('.');
open(ls,'ls -F1|');
while (<ls>) {
chop;
next unless s|/$||;
($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
$blksize,$blocks) = stat($_);
next unless $dev == $mydev;
push(@ary,$_);
}
exec 'du', '-s', @ary;

53
contrib/perl5/eg/findcp Normal file
View File

@ -0,0 +1,53 @@
#!/usr/bin/perl
# $RCSfile: findcp,v $$Revision: 4.1 $$Date: 92/08/07 17:20:12 $
# This is a wrapper around the find command that pretends find has a switch
# of the form -cp host:destination. It presumes your find implements -ls.
# It uses tar to do the actual copy. If your tar knows about the I switch
# you may prefer to use findtar, since this one has to do the tar in batches.
sub copy {
`tar cf - $list | rsh $desthost cd $destdir '&&' tar xBpf -`;
}
$sourcedir = $ARGV[0];
if ($sourcedir =~ /^\//) {
$ARGV[0] = '.';
unless (chdir($sourcedir)) { die "Can't find directory $sourcedir: $!"; }
}
$args = join(' ',@ARGV);
if ($args =~ s/-cp *([^ ]+)/-ls/) {
$dest = $1;
if ($dest =~ /(.*):(.*)/) {
$desthost = $1;
$destdir = $2;
}
else {
die "Malformed destination--should be host:directory";
}
}
else {
die("No destination specified");
}
open(find,"find $args |") || die "Can't run find for you: $!";
while (<find>) {
@x = split(' ');
if ($x[2] =~ /^d/) { next;}
chop($filename = $x[10]);
if (length($list) > 5000) {
do copy();
$list = '';
}
else {
$list .= ' ';
}
$list .= $filename;
}
if ($list) {
do copy();
}

17
contrib/perl5/eg/findtar Normal file
View File

@ -0,0 +1,17 @@
#!/usr/bin/perl
# $RCSfile: findtar,v $$Revision: 4.1 $$Date: 92/08/07 17:20:13 $
# findtar takes find-style arguments and spits out a tarfile on stdout.
# It won't work unless your find supports -ls and your tar the I flag.
$args = join(' ',@ARGV);
open(find,"/usr/bin/find $args -ls |") || die "Can't run find for you.";
open(tar,"| /bin/tar cIf - -") || die "Can't run tar for you: $!";
while (<find>) {
@x = split(' ');
if ($x[2] =~ /^d/) { print tar '-d ';}
print tar $x[10],"\n";
}

114
contrib/perl5/eg/g/gcp Normal file
View File

@ -0,0 +1,114 @@
#!/usr/bin/perl
# $RCSfile: gcp,v $$Revision: 4.1 $$Date: 92/08/07 17:20:15 $
# Here is a script to do global rcps. See man page.
$#ARGV >= 1 || die "Not enough arguments.\n";
if ($ARGV[0] eq '-r') {
$rcp = 'rcp -r';
shift;
} else {
$rcp = 'rcp';
}
$args = $rcp;
$dest = $ARGV[$#ARGV];
$SIG{'QUIT'} = 'CLEANUP';
$SIG{'INT'} = 'CONT';
while ($arg = shift) {
if ($arg =~ /^([-a-zA-Z0-9_+]+):/) {
if ($systype && $systype ne $1) {
die "Can't mix system type specifers ($systype vs $1).\n";
}
$#ARGV < 0 || $arg !~ /:$/ || die "No source file specified.\n";
$systype = $1;
$args .= " $arg";
} else {
if ($#ARGV >= 0) {
if ($arg =~ /^[\/~]/) {
$arg =~ /^(.*)\// && ($dir = $1);
} else {
if (!$pwd) {
chop($pwd = `pwd`);
}
$dir = $pwd;
}
}
if ($olddir && $dir ne $olddir && $dest =~ /:$/) {
$args .= " $dest$olddir; $rcp";
}
$olddir = $dir;
$args .= " $arg";
}
}
die "No system type specified.\n" unless $systype;
$args =~ s/:$/:$olddir/;
chop($thishost = `hostname`);
$one_of_these = ":$systype:";
if ($systype =~ s/\+/[+]/g) {
$one_of_these =~ s/\+/:/g;
}
$one_of_these =~ s/-/:-/g;
@ARGV = ();
push(@ARGV,'.grem') if -f '.grem';
push(@ARGV,'.ghosts') if -f '.ghosts';
push(@ARGV,'/etc/ghosts');
$remainder = '';
line: while (<>) {
s/[ \t]*\n//;
if (!$_ || /^#/) {
next line;
}
if (/^([a-zA-Z_0-9]+)=(.+)/) {
$name = $1; $repl = $2;
$repl =~ s/\+/:/g;
$repl =~ s/-/:-/g;
$one_of_these =~ s/:$name:/:$repl:/;
$repl =~ s/:/:-/g;
$one_of_these =~ s/:-$name:/:-$repl:/g;
next line;
}
@gh = split(' ');
$host = $gh[0];
next line if $host eq $thishost; # should handle aliases too
$wanted = 0;
foreach $class (@gh) {
$wanted++ if index($one_of_these,":$class:") >= 0;
$wanted = -9999 if index($one_of_these,":-$class:") >= 0;
}
if ($wanted > 0) {
($cmd = $args) =~ s/[ \t]$systype:/ $host:/g;
print "$cmd\n";
$result = `$cmd 2>&1`;
$remainder .= "$host+" if
$result =~ /Connection timed out|Permission denied/;
print $result;
}
}
if ($remainder) {
chop($remainder);
open(grem,">.grem") || (printf stderr "Can't create .grem: $!\n");
print grem 'rem=', $remainder, "\n";
close(grem);
print 'rem=', $remainder, "\n";
}
sub CLEANUP {
exit;
}
sub CONT {
print "Continuing...\n"; # Just ignore the signal that kills rcp
$remainder .= "$host+";
}

77
contrib/perl5/eg/g/gcp.man Normal file
View File

@ -0,0 +1,77 @@
.\" $RCSfile: gcp.man,v $$Revision: 4.1 $$Date: 92/08/07 17:20:17 $
.TH GCP 1C "13 May 1988"
.SH NAME
gcp \- global file copy
.SH SYNOPSIS
.B gcp
file1 file2
.br
.B gcp
[
.B \-r
] file ... directory
.SH DESCRIPTION
.I gcp
works just like rcp(1C) except that you may specify a set of hosts to copy files
from or to.
The host sets are defined in the file /etc/ghosts.
(An individual host name can be used as a set containing one member.)
You can give a command like
gcp /etc/motd sun:
to copy your /etc/motd file to /etc/motd on all the Suns.
If, on the other hand, you say
gcp /a/foo /b/bar sun:/tmp
then your files will be copied to /tmp on all the Suns.
The general rule is that if you don't specify the destination directory,
files go to the same directory they are in currently.
.P
You may specify the union of two or more sets by using + as follows:
gcp /a/foo /b/bar 750+mc:
which will copy /a/foo to /a/foo on all 750's and Masscomps, and then copy
/b/bar to /b/bar on all 750's and Masscomps.
.P
Commonly used sets should be defined in /etc/ghosts.
For example, you could add a line that says
pep=manny+moe+jack
Another way to do that would be to add the word "pep" after each of the host
entries:
manny sun3 pep
.br
moe sun3 pep
.br
jack sun3 pep
Hosts and sets of host can also be excluded:
foo=sun-sun2
Any host so excluded will never be included, even if a subsequent set on the
line includes it:
foo=abc+def
.br
bar=xyz-abc+foo
comes out to xyz+def.
You can define private host sets by creating .ghosts in your current directory
with entries just like /etc/ghosts.
Also, if there is a file .grem, it defines "rem" to be the remaining hosts
from the last gsh or gcp that didn't succeed everywhere.
.PP
Interrupting with a SIGINT will cause the rcp to the current host to be skipped
and execution resumed with the next host.
To stop completely, send a SIGQUIT.
.SH SEE ALSO
rcp(1C)
.SH BUGS
All the bugs of rcp, since it calls rcp.

21
contrib/perl5/eg/g/ged Normal file
View File

@ -0,0 +1,21 @@
#!/usr/bin/perl
# $RCSfile: ged,v $$Revision: 4.1 $$Date: 92/08/07 17:20:18 $
# Does inplace edits on a set of files on a set of machines.
#
# Typical invokation:
#
# ged vax+sun /etc/passwd
# s/Freddy/Freddie/;
# ^D
#
$class = shift;
$files = join(' ',@ARGV);
die "Usage: ged class files <perlcmds\n" unless $files;
exec "gsh", $class, "-d", "perl -pi.bak - $files";
die "Couldn't execute gsh for some reason, stopped";

33
contrib/perl5/eg/g/ghosts Normal file
View File

@ -0,0 +1,33 @@
# This first section gives alternate sets defined in terms of the sets given
# by the second section. The order is important--all references must be
# forward references.
Nnd=sun-nd
all=sun+mc+vax
baseline=sun+mc
sun=sun2+sun3
vax=750+8600
pep=manny+moe+jack
# This second section defines the basic sets. Each host should have a line
# that specifies which sets it is a member of. Extra sets should be separated
# by white space. (The first section isn't strictly necessary, since all sets
# could be defined in the second section, but then it wouldn't be so readable.)
basvax 8600 src
cdb0 sun3 sys
cdb1 sun3 sys
cdb2 sun3 sys
chief sun3 src
tis0 sun3
manny sun3 sys
moe sun3 sys
jack sun3 sys
disney sun3 sys
huey sun3 nd
dewey sun3 nd
louie sun3 nd
bizet sun2 src sys
gif0 mc src
mc0 mc
dtv0 mc

117
contrib/perl5/eg/g/gsh Normal file
View File

@ -0,0 +1,117 @@
#! /usr/bin/perl
# $RCSfile: gsh,v $$Revision: 4.1 $$Date: 92/08/07 17:20:20 $
# Do rsh globally--see man page
$SIG{'QUIT'} = 'quit'; # install signal handler for SIGQUIT
sub getswitches {
while ($ARGV[0] =~ /^-/) { # parse switches
$ARGV[0] =~ /^-h/ && ($showhost++,$silent++,shift(@ARGV),next);
$ARGV[0] =~ /^-s/ && ($silent++,shift(@ARGV),next);
$ARGV[0] =~ /^-d/ && ($dodist++,shift(@ARGV),next);
$ARGV[0] =~ /^-n/ && ($n=' -n',shift(@ARGV),next);
$ARGV[0] =~ /^-l/ && ($l=' -l ' . $ARGV[1],shift(@ARGV),shift(@ARGV),
next);
last;
}
}
do getswitches(); # get any switches before class
$systype = shift; # get name representing set of hosts
do getswitches(); # same switches allowed after class
if ($dodist) { # distribute input over all rshes?
`cat >/tmp/gsh$$`; # get input into a handy place
$dist = " </tmp/gsh$$"; # each rsh takes input from there
}
$cmd = join(' ',@ARGV); # remaining args constitute the command
$cmd =~ s/'/'"'"'/g; # quote any embedded single quotes
$one_of_these = ":$systype:"; # prepare to expand "macros"
$one_of_these =~ s/\+/:/g; # we hope to end up with list of
$one_of_these =~ s/-/:-/g; # colon separated attributes
@ARGV = ();
push(@ARGV,'.grem') if -f '.grem';
push(@ARGV,'.ghosts') if -f '.ghosts';
push(@ARGV,'/etc/ghosts');
$remainder = '';
line: while (<>) { # for each line of ghosts
s/[ \t]*\n//; # trim trailing whitespace
if (!$_ || /^#/) { # skip blank line or comment
next line;
}
if (/^(\w+)=(.+)/) { # a macro line?
$name = $1; $repl = $2;
$repl =~ s/\+/:/g;
$repl =~ s/-/:-/g;
$one_of_these =~ s/:$name:/:$repl:/; # do expansion in "wanted" list
$repl =~ s/:/:-/g;
$one_of_these =~ s/:-$name:/:-$repl:/;
next line;
}
# we have a normal line
@attr = split(' '); # a list of attributes to match against
# which we put into an array
$host = $attr[0]; # the first attribute is the host name
if ($showhost) {
$showhost = "$host:\t";
}
$wanted = 0;
foreach $attr (@attr) { # iterate over attribute array
$wanted++ if index($one_of_these,":$attr:") >= 0;
$wanted = -9999 if index($one_of_these,":-$attr:") >= 0;
}
if ($wanted > 0) {
print "rsh $host$l$n '$cmd'\n" unless $silent;
$SIG{'INT'} = 'DEFAULT';
if (open(PIPE,"rsh $host$l$n '$cmd'$dist 2>&1|")) { # start an rsh
$SIG{'INT'} = 'cont';
for ($iter=0; <PIPE>; $iter++) {
unless ($iter) {
$remainder .= "$host+"
if /Connection timed out|Permission denied/;
}
print $showhost,$_;
}
close(PIPE);
} else {
print "(Can't execute rsh: $!)\n";
$SIG{'INT'} = 'cont';
}
}
}
unlink "/tmp/gsh$$" if $dodist;
if ($remainder) {
chop($remainder);
open(grem,">.grem") || (printf stderr "Can't make a .grem file: $!\n");
print grem 'rem=', $remainder, "\n";
close(grem);
print 'rem=', $remainder, "\n";
}
# here are a couple of subroutines that serve as signal handlers
sub cont {
print "\rContinuing...\n";
$remainder .= "$host+";
}
sub quit {
$| = 1;
print "\r";
$SIG{'INT'} = '';
kill 2, $$;
}

80
contrib/perl5/eg/g/gsh.man Normal file
View File

@ -0,0 +1,80 @@
.\" $RCSfile: gsh.man,v $$Revision: 4.1 $$Date: 92/08/07 17:20:22 $
.TH GSH 8 "13 May 1988"
.SH NAME
gsh \- global shell
.SH SYNOPSIS
.B gsh
[options]
.I host
[options]
.I command
.SH DESCRIPTION
.I gsh
works just like rsh(1C) except that you may specify a set of hosts to execute
the command on.
The host sets are defined in the file /etc/ghosts.
(An individual host name can be used as a set containing one member.)
You can give a command like
gsh sun /etc/mungmotd
to run /etc/mungmotd on all your Suns.
.P
You may specify the union of two or more sets by using + as follows:
gsh 750+mc /etc/mungmotd
which will run mungmotd on all 750's and Masscomps.
.P
Commonly used sets should be defined in /etc/ghosts.
For example, you could add a line that says
pep=manny+moe+jack
Another way to do that would be to add the word "pep" after each of the host
entries:
manny sun3 pep
.br
moe sun3 pep
.br
jack sun3 pep
Hosts and sets of host can also be excluded:
foo=sun-sun2
Any host so excluded will never be included, even if a subsequent set on the
line includes it:
foo=abc+def
bar=xyz-abc+foo
comes out to xyz+def.
You can define private host sets by creating .ghosts in your current directory
with entries just like /etc/ghosts.
Also, if there is a file .grem, it defines "rem" to be the remaining hosts
from the last gsh or gcp that didn't succeed everywhere.
Options include all those defined by rsh, as well as
.IP "\-d" 8
Causes gsh to collect input till end of file, and then distribute that input
to each invokation of rsh.
.IP "\-h" 8
Rather than print out the command followed by the output, merely prepends the
host name to each line of output.
.IP "\-s" 8
Do work silently.
.PP
Interrupting with a SIGINT will cause the rsh to the current host to be skipped
and execution resumed with the next host.
To stop completely, send a SIGQUIT.
.SH SEE ALSO
rsh(1C)
.SH BUGS
All the bugs of rsh, since it calls rsh.
Also, will not properly return data from the remote execution that contains
null characters.

141
contrib/perl5/eg/muck Normal file
View File

@ -0,0 +1,141 @@
#!../perl
$M = '-M';
$M = '-m' if -d '/usr/uts' && -f '/etc/master';
do 'getopt.pl';
do Getopt('f');
if ($opt_f) {
$makefile = $opt_f;
}
elsif (-f 'makefile') {
$makefile = 'makefile';
}
elsif (-f 'Makefile') {
$makefile = 'Makefile';
}
else {
die "No makefile\n";
}
$MF = 'mf00';
while(($key,$val) = each(ENV)) {
$mac{$key} = $val;
}
do scan($makefile);
$co = $action{'.c.o'};
$co = ' ' unless $co;
$missing = "Missing dependencies:\n";
foreach $key (sort keys(o)) {
if ($oc{$key}) {
$src = $oc{$key};
$action = $action{$key};
}
else {
$action = '';
}
if (!$action) {
if ($co && ($c = $key) =~ s/\.o$/.c/ && -f $c) {
$src = $c;
$action = $co;
}
else {
print "No source found for $key $c\n";
next;
}
}
$I = '';
$D = '';
$I .= $1 while $action =~ s/(-I\S+\s*)//;
$D .= $1 . ' ' while $action =~ s/(-D\w+)//;
if ($opt_v) {
$cmd = "Checking $key: cc $M $D $I $src";
$cmd =~ s/\s\s+/ /g;
print stderr $cmd,"\n";
}
open(CPP,"cc $M $D $I $src|") || die "Can't run C preprocessor: $!";
while (<CPP>) {
($name,$dep) = split;
$dep =~ s|^\./||;
(print $missing,"$key: $dep\n"),($missing='')
unless ($dep{"$key: $dep"} += 2) > 2;
}
}
$extra = "\nExtraneous dependencies:\n";
foreach $key (sort keys(dep)) {
if ($key =~ /\.o: .*\.h$/ && $dep{$key} == 1) {
print $extra,$key,"\n";
$extra = '';
}
}
sub scan {
local($makefile) = @_;
local($MF) = $MF;
print stderr "Analyzing $makefile.\n" if $opt_v;
$MF++;
open($MF,$makefile) || die "Can't open $makefile: $!";
while (<$MF>) {
chop;
chop($_ = $_ . <$MF>) while s/\\$//;
next if /^#/;
next if /^$/;
s/\$\((\w+):([^=)]*)=([^)]*)\)/do subst("$1","$2","$3")/eg;
s/\$\((\w+)\)/$mac{$1}/eg;
$mac{$1} = $2, next if /^(\w+)\s*=\s*(.*)/;
if (/^include\s+(.*)/) {
do scan($1);
print stderr "Continuing $makefile.\n" if $opt_v;
next;
}
if (/^([^:]+):\s*(.*)/) {
$left = $1;
$right = $2;
if ($right =~ /^([^;]*);(.*)/) {
$right = $1;
$action = $2;
}
else {
$action = '';
}
while (<$MF>) {
last unless /^\t/;
chop;
chop($_ = $_ . <$MF>) while s/\\$//;
next if /^#/;
last if /^$/;
s/\$\((\w+):([^=)]*)=([^)]*)\)/do subst("$1","$2","$3")/eg;
s/\$\((\w+)\)/$mac{$1}/eg;
$action .= $_;
}
foreach $targ (split(' ',$left)) {
$targ =~ s|^\./||;
foreach $src (split(' ',$right)) {
$src =~ s|^\./||;
$deplist{$targ} .= ' ' . $src;
$dep{"$targ: $src"} = 1;
$o{$src} = 1 if $src =~ /\.o$/;
$oc{$targ} = $src if $targ =~ /\.o$/ && $src =~ /\.[yc]$/;
}
$action{$targ} .= $action;
}
redo if $_;
}
}
close($MF);
}
sub subst {
local($foo,$from,$to) = @_;
$foo = $mac{$foo};
$from =~ s/\./[.]/;
y/a/a/;
$foo =~ s/\b$from\b/$to/g;
$foo;
}

21
contrib/perl5/eg/muck.man Normal file
View File

@ -0,0 +1,21 @@
.\" $RCSfile: muck.man,v $$Revision: 4.1 $$Date: 92/08/07 17:20:23 $
.TH MUCK 1 "10 Jan 1989"
.SH NAME
muck \- make usage checker
.SH SYNOPSIS
.B muck
[options]
.SH DESCRIPTION
.I muck
looks at your current makefile and complains if you've left out any dependencies
between .o and .h files.
It also complains about extraneous dependencies.
.PP
You can use the -f FILENAME option to specify an alternate name for your
makefile.
The -v option is a little more verbose about what muck is mucking around
with at the moment.
.SH SEE ALSO
make(1)
.SH BUGS
Only knows about .h, .c and .o files.

29
contrib/perl5/eg/myrup Normal file
View File

@ -0,0 +1,29 @@
#!/usr/bin/perl
# $RCSfile: myrup,v $$Revision: 4.1 $$Date: 92/08/07 17:20:26 $
# This was a customization of ruptime requested by someone here who wanted
# to be able to find the least loaded machine easily. It uses the
# /etc/ghosts file that's defined for gsh and gcp to prune down the
# number of entries to those hosts we have administrative control over.
print "node load (u)\n------- --------\n";
open(ghosts,'/etc/ghosts') || die "Can't open /etc/ghosts: $!";
line: while (<ghosts>) {
next line if /^#/;
next line if /^$/;
next line if /=/;
($host) = split;
$wanted{$host} = 1;
}
open(ruptime,'ruptime|') || die "Can't run ruptime: $!";
open(sort,'|sort +1n');
while (<ruptime>) {
($host,$upness,$foo,$users,$foo,$foo,$load) = split(/[\s,]+/);
if ($wanted{$host} && $upness eq 'up') {
printf sort "%s\t%s (%d)\n", $host, $load, $users;
}
}

11
contrib/perl5/eg/nih Normal file
View File

@ -0,0 +1,11 @@
eval 'exec /usr/bin/perl -Spi.bak $0 ${1+"$@"}'
if $running_under_some_shell;
# $RCSfile: nih,v $$Revision: 4.1 $$Date: 92/08/07 17:20:27 $
# This script makes #! scripts directly executable on machines that don't
# support #!. It edits in place any scripts mentioned on the command line.
s[^#!(.*)]
[#!$1\neval 'exec $1 -S \$0 \${1+"\$@"}'\n\tif \$running_under_some_shell;]
if $. == 1;

82
contrib/perl5/eg/relink Normal file
View File

@ -0,0 +1,82 @@
#!/usr/bin/perl
'di';
'ig00';
#
# $RCSfile: relink,v $$Revision: 4.1 $$Date: 92/08/07 17:20:29 $
#
# $Log: relink,v $
($op = shift) || die "Usage: relink perlexpr [filenames]\n";
if (!@ARGV) {
@ARGV = <STDIN>;
chop(@ARGV);
}
for (@ARGV) {
next unless -l; # symbolic link?
$name = $_;
$_ = readlink($_);
$was = $_;
eval $op;
die $@ if $@;
if ($was ne $_) {
unlink($name);
symlink($_, $name);
}
}
##############################################################################
# These next few lines are legal in both Perl and nroff.
.00; # finish .ig
'di \" finish diversion--previous line must be blank
.nr nl 0-1 \" fake up transition to first page again
.nr % 0 \" start at page 1
';<<'.ex'; #__END__ ############# From here on it's a standard manual page ############
.TH RELINK 1 "July 30, 1990"
.AT 3
.SH LINK
relink \- relinks multiple symbolic links
.SH SYNOPSIS
.B relink perlexpr [symlinknames]
.SH DESCRIPTION
.I Relink
relinks the symbolic links given according to the rule specified as the
first argument.
The argument is a Perl expression which is expected to modify the $_
string in Perl for at least some of the names specified.
For each symbolic link named on the command line, the Perl expression
will be executed on the contents of the symbolic link with that name.
If a given symbolic link's contents is not modified by the expression,
it will not be changed.
If a name given on the command line is not a symbolic link, it will be ignored.
If no names are given on the command line, names will be read
via standard input.
.PP
For example, to relink all symbolic links in the current directory
pointing to somewhere in X11R3 so that they point to X11R4, you might say
.nf
relink 's/X11R3/X11R4/' *
.fi
To change all occurences of links in the system from /usr/spool to /var/spool,
you'd say
.nf
find / -type l -print | relink 's#/usr/spool#/var/spool#'
.fi
.SH ENVIRONMENT
No environment variables are used.
.SH FILES
.SH AUTHOR
Larry Wall
.SH "SEE ALSO"
ln(1)
.br
perl(1)
.SH DIAGNOSTICS
If you give an invalid Perl expression you'll get a syntax error.
.SH BUGS
.ex

74
contrib/perl5/eg/rename Executable file
View File

@ -0,0 +1,74 @@
#!/usr/bin/perl
'di';
'ig00';
#
# $RCSfile: rename,v $$Revision: 4.1 $$Date: 92/08/07 17:20:30 $
#
# $Log: rename,v $
($op = shift) || die "Usage: rename perlexpr [filenames]\n";
if (!@ARGV) {
@ARGV = <STDIN>;
chop(@ARGV);
}
for (@ARGV) {
$was = $_;
eval $op;
die $@ if $@;
rename($was,$_) unless $was eq $_;
}
##############################################################################
# These next few lines are legal in both Perl and nroff.
.00; # finish .ig
'di \" finish diversion--previous line must be blank
.nr nl 0-1 \" fake up transition to first page again
.nr % 0 \" start at page 1
';<<'.ex'; #__END__ ############# From here on it's a standard manual page ############
.TH RENAME 1 "July 30, 1990"
.AT 3
.SH NAME
rename \- renames multiple files
.SH SYNOPSIS
.B rename perlexpr [files]
.SH DESCRIPTION
.I Rename
renames the filenames supplied according to the rule specified as the
first argument.
The argument is a Perl expression which is expected to modify the $_
string in Perl for at least some of the filenames specified.
If a given filename is not modified by the expression, it will not be
renamed.
If no filenames are given on the command line, filenames will be read
via standard input.
.PP
For example, to rename all files matching *.bak to strip the extension,
you might say
.nf
rename 's/\e.bak$//' *.bak
.fi
To translate uppercase names to lower, you'd use
.nf
rename 'y/A-Z/a-z/' *
.fi
.SH ENVIRONMENT
No environment variables are used.
.SH FILES
.SH AUTHOR
Larry Wall
.SH "SEE ALSO"
mv(1)
.br
perl(1)
.SH DIAGNOSTICS
If you give an invalid Perl expression you'll get a syntax error.
.SH BUGS
.I Rename
does not check for the existence of target filenames, so use with care.
.ex

7
contrib/perl5/eg/rmfrom Normal file
View File

@ -0,0 +1,7 @@
#!/usr/bin/perl -n
# $RCSfile: rmfrom,v $$Revision: 4.1 $$Date: 92/08/07 17:20:31 $
# A handy (but dangerous) script to put after a find ... -print.
chop; unlink;

51
contrib/perl5/eg/scan/scan_df Normal file
View File

@ -0,0 +1,51 @@
#!/usr/bin/perl -P
# $RCSfile: scan_df,v $$Revision: 4.1 $$Date: 92/08/07 17:20:33 $
# This report points out filesystems that are in danger of overflowing.
(chdir '/usr/adm/private/memories') || die "Can't cd to memories: $!\n";
`df >newdf`;
open(Df, 'olddf');
while (<Df>) {
($fs,$kbytes,$used,$avail,$capacity,$mounted_on) = split;
next if $fs =~ /:/;
next if $fs eq '';
$oldused{$fs} = $used;
}
open(Df, 'newdf') || die "scan_df: can't open newdf";
while (<Df>) {
($fs,$kbytes,$used,$avail,$capacity,$mounted_on) = split;
next if $fs =~ /:/;
next if $fs eq '';
$oldused = $oldused{$fs};
next if ($oldused == $used && $capacity < 99); # inactive filesystem
if ($capacity >= 90) {
#if defined(mc300) || defined(mc500) || defined(mc700)
$_ = substr($_,0,13) . ' ' . substr($_,13,1000);
$kbytes /= 2; # translate blocks to K
$used /= 2;
$oldused /= 2;
$avail /= 2;
#endif
$diff = int($used - $oldused);
if ($avail < $diff * 2) { # mark specially if in danger
$mounted_on .= ' *';
}
next if $diff < 50 && $mounted_on eq '/';
$fs =~ s|/dev/||;
if ($diff >= 0) {
$diff = '(+' . $diff . ')';
}
else {
$diff = '(' . $diff . ')';
}
printf "%-8s%8d%8d %-8s%8d%7s %s\n",
$fs,$kbytes,$used,$diff,$avail,$capacity,$mounted_on;
}
}
rename('newdf','olddf');

57
contrib/perl5/eg/scan/scan_last Normal file
View File

@ -0,0 +1,57 @@
#!/usr/bin/perl -P
# $RCSfile: scan_last,v $$Revision: 4.1 $$Date: 92/08/07 17:20:35 $
# This reports who was logged on at weird hours
($dy, $mo, $lastdt) = split(/ +/,`date`);
open(Last, 'exec last 2>&1 |') || die "scan_last: can't run last";
while (<Last>) {
#if defined(mc300) || defined(mc500) || defined(mc700)
$_ = substr($_,0,19) . substr($_,23,100);
#endif
next if /^$/;
(print),next if m|^/|;
$login = substr($_,0,8);
$tty = substr($_,10,7);
$from = substr($_,19,15);
$day = substr($_,36,3);
$mo = substr($_,40,3);
$dt = substr($_,44,2);
$hr = substr($_,47,2);
$min = substr($_,50,2);
$dash = substr($_,53,1);
$tohr = substr($_,55,2);
$tomin = substr($_,58,2);
$durhr = substr($_,63,2);
$durmin = substr($_,66,2);
next unless $hr;
next if $login eq 'reboot ';
next if $login eq 'shutdown';
if ($dt != $lastdt) {
if ($lastdt < $dt) {
$seen += $dt - $lastdt;
}
else {
$seen++;
}
$lastdt = $dt;
}
$inat = $hr + $min / 60;
if ($tohr =~ /^[a-z]/) {
$outat = 12; # something innocuous
} else {
$outat = $tohr + $tomin / 60;
}
last if $seen + ($inat < 8) > 1;
if ($inat < 5 || $inat > 21 || $outat < 6 || $outat > 23) {
print;
}
}

222
contrib/perl5/eg/scan/scan_messages Normal file
View File

@ -0,0 +1,222 @@
#!/usr/bin/perl -P
# $RCSfile: scan_messages,v $$Revision: 4.1 $$Date: 92/08/07 17:20:37 $
# This prints out extraordinary console messages. You'll need to customize.
chdir('/usr/adm/private/memories') || die "Can't cd to memories: $!\n";
$maxpos = `cat oldmsgs 2>&1`;
#if defined(mc300) || defined(mc500) || defined(mc700)
open(Msgs, '/dev/null') || die "scan_messages: can't open messages";
#else
open(Msgs, '/usr/adm/messages') || die "scan_messages: can't open messages";
#endif
($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
$blksize,$blocks) = stat(Msgs);
if ($size < $maxpos) { # Did somebody truncate messages file?
$maxpos = 0;
}
seek(Msgs,$maxpos,0); # Start where we left off last time.
while (<Msgs>) {
s/\[(\d+)\]/#/ && s/$1/#/g;
#ifdef vax
$_ =~ s/[A-Z][a-z][a-z] +\w+ +[0-9:]+ +\w+ +//;
next if /root@.*:/;
next if /^vmunix: 4.3 BSD UNIX/;
next if /^vmunix: Copyright/;
next if /^vmunix: avail mem =/;
next if /^vmunix: SBIA0 at /;
next if /^vmunix: disk ra81 is/;
next if /^vmunix: dmf. at uba/;
next if /^vmunix: dmf.:.*asynch/;
next if /^vmunix: ex. at uba/;
next if /^vmunix: ex.: HW/;
next if /^vmunix: il. at uba/;
next if /^vmunix: il.: hardware/;
next if /^vmunix: ra. at uba/;
next if /^vmunix: ra.: media/;
next if /^vmunix: real mem/;
next if /^vmunix: syncing disks/;
next if /^vmunix: tms/;
next if /^vmunix: tmscp. at uba/;
next if /^vmunix: uba. at /;
next if /^vmunix: uda. at /;
next if /^vmunix: uda.: unit . ONLIN/;
next if /^vmunix: .*buffers containing/;
next if /^syslogd: .*newslog/;
#endif
next if /unknown service/;
next if /^\.\.\.$/;
if (/^[A-Z][a-z][a-z] [ 0-9][0-9] [ 0-9][0-9]:[0-9][0-9]/) {
$pfx = '';
next;
}
next if /^[ \t]*$/;
next if /^[ 0-9]*done$/;
if (/^A/) {
next if /^Accounting [sr]/;
}
elsif (/^C/) {
next if /^Called from/;
next if /^Copyright/;
}
elsif (/^E/) {
next if /^End traceback/;
next if /^Ethernet address =/;
}
elsif (/^K/) {
next if /^KERNEL MODE/;
}
elsif (/^R/) {
next if /^Rebooting Unix/;
}
elsif (/^S/) {
next if /^Sun UNIX 4\.2 Release/;
}
elsif (/^W/) {
next if /^WARNING: clock gained/;
}
elsif (/^a/) {
next if /^arg /;
next if /^avail mem =/;
}
elsif (/^b/) {
next if /^bwtwo[0-9] at /;
}
elsif (/^c/) {
next if /^cgone[0-9] at /;
next if /^cdp[0-9] at /;
next if /^csr /;
}
elsif (/^d/) {
next if /^dcpa: init/;
next if /^done$/;
next if /^dts/;
next if /^dump i\/o error/;
next if /^dumping to dev/;
next if /^dump succeeded/;
$pfx = '*' if /^dev = /;
}
elsif (/^e/) {
next if /^end \*\*/;
next if /^error in copy/;
}
elsif (/^f/) {
next if /^found /;
}
elsif (/^i/) {
next if /^ib[0-9] at /;
next if /^ie[0-9] at /;
}
elsif (/^l/) {
next if /^le[0-9] at /;
}
elsif (/^m/) {
next if /^mem = /;
next if /^mt[0-9] at /;
next if /^mti[0-9] at /;
$pfx = '*' if /^mode = /;
}
elsif (/^n/) {
next if /^not found /;
}
elsif (/^p/) {
next if /^page map /;
next if /^pi[0-9] at /;
$pfx = '*' if /^panic/;
}
elsif (/^q/) {
next if /^qqq /;
}
elsif (/^r/) {
next if /^read /;
next if /^revarp: Requesting/;
next if /^root [od]/;
}
elsif (/^s/) {
next if /^sc[0-9] at /;
next if /^sd[0-9] at /;
next if /^sd[0-9]: </;
next if /^si[0-9] at /;
next if /^si_getstatus/;
next if /^sk[0-9] at /;
next if /^skioctl/;
next if /^skopen/;
next if /^skprobe/;
next if /^skread/;
next if /^skwrite/;
next if /^sky[0-9] at /;
next if /^st[0-9] at /;
next if /^st0:.*load/;
next if /^stat1 = /;
next if /^syncing disks/;
next if /^syslogd: going down on signal 15/;
}
elsif (/^t/) {
next if /^timeout [0-9]/;
next if /^tm[0-9] at /;
next if /^tod[0-9] at /;
next if /^tv [0-9]/;
$pfx = '*' if /^trap address/;
}
elsif (/^u/) {
next if /^unit nsk/;
next if /^use one of/;
$pfx = '' if /^using/;
next if /^using [0-9]+ buffers/;
}
elsif (/^x/) {
next if /^xy[0-9] at /;
next if /^write [0-9]/;
next if /^xy[0-9]: </;
next if /^xyc[0-9] at /;
}
elsif (/^y/) {
next if /^yyy [0-9]/;
}
elsif (/^z/) {
next if /^zs[0-9] at /;
}
$pfx = '*' if /^[a-z]+:$/;
s/pid [0-9]+: //;
if (/last message repeated ([0-9]+) time/) {
$seen{$last} += $1;
next;
}
s/^/$pfx/ if $pfx;
unless ($seen{$_}++) {
push(@seen,$_);
}
$last = $_;
}
$max = tell(Msgs);
open(tmp,'|sort >oldmsgs.tmp') || die "Can't create tmp file: $!\n";
while ($_ = pop(@seen)) {
print tmp $_;
}
close(tmp);
open(tmp,'oldmsgs.tmp') || die "Can't reopen tmp file: $!\n";
while (<tmp>) {
if (/^nd:/) {
next if $seen{$_} < 20;
}
if (/NFS/) {
next if $seen{$_} < 20;
}
if (/no carrier/) {
next if $seen{$_} < 20;
}
if (/silo overflow/) {
next if $seen{$_} < 20;
}
print $seen{$_},":\t",$_;
}
print `rm -f oldmsgs.tmp 2>&1; echo $max > oldmsgs 2>&1`;

30
contrib/perl5/eg/scan/scan_passwd Normal file
View File

@ -0,0 +1,30 @@
#!/usr/bin/perl
# $RCSfile: scan_passwd,v $$Revision: 4.1 $$Date: 92/08/07 17:20:38 $
# This scans passwd file for security holes.
open(Pass,'/etc/passwd') || die "Can't open passwd file: $!\n";
# $dotriv = (`date` =~ /^Mon/);
$dotriv = 1;
while (<Pass>) {
($login,$pass,$uid,$gid,$gcos,$home,$shell) = split(/:/);
if ($shell eq '') {
print "Short: $_";
}
next if /^[+]/;
if ($pass eq '') {
if (index(":sync:lpq:+:", ":$login:") < 0) {
print "No pass: $login\t$gcos\n";
}
}
elsif ($dotriv && crypt($login,substr($pass,0,2)) eq $pass) {
print "Trivial: $login\t$gcos\n";
}
if ($uid == 0) {
if ($login !~ /^.?root$/ && $pass ne '*') {
print "Extra root: $_";
}
}
}

32
contrib/perl5/eg/scan/scan_ps Normal file
View File

@ -0,0 +1,32 @@
#!/usr/bin/perl -P
# $RCSfile: scan_ps,v $$Revision: 4.1 $$Date: 92/08/07 17:20:40 $
# This looks for looping processes.
#if defined(mc300) || defined(mc500) || defined(mc700)
open(Ps, '/bin/ps -el|') || die "scan_ps: can't run ps";
while (<Ps>) {
next if /rwhod/;
print if index(' T', substr($_,62,1)) < 0;
}
#else
open(Ps, '/bin/ps auxww|') || die "scan_ps: can't run ps";
while (<Ps>) {
next if /dataserver/;
next if /nfsd/;
next if /update/;
next if /ypserv/;
next if /rwhod/;
next if /routed/;
next if /pagedaemon/;
#ifdef vax
($user,$pid,$cpu,$mem,$sz,$rss,$tt,$stat,$start,$time) = split;
#else
($user,$pid,$cpu,$mem,$sz,$rss,$tt,$stat,$time) = split;
#endif
print if length($time) > 4;
}
#endif

54
contrib/perl5/eg/scan/scan_sudo Normal file
View File

@ -0,0 +1,54 @@
#!/usr/bin/perl -P
# $RCSfile: scan_sudo,v $$Revision: 4.1 $$Date: 92/08/07 17:20:42 $
# Analyze the sudo log.
chdir('/usr/adm/private/memories') || die "Can't cd to memories: $!\n";
if (open(Oldsudo,'oldsudo')) {
$maxpos = <Oldsudo>;
close Oldsudo;
}
else {
$maxpos = 0;
`echo 0 >oldsudo`;
}
unless (open(Sudo, '/usr/adm/sudo.log')) {
print "Somebody removed sudo.log!!!\n" if $maxpos;
exit 0;
}
($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
$blksize,$blocks) = stat(Sudo);
if ($size < $maxpos) {
$maxpos = 0;
print "Somebody reset sudo.log!!!\n";
}
seek(Sudo,$maxpos,0);
while (<Sudo>) {
s/^.* :[ \t]+//;
s/ipcrm.*/ipcrm/;
s/kill.*/kill/;
unless ($seen{$_}++) {
push(@seen,$_);
}
$last = $_;
}
$max = tell(Sudo);
open(tmp,'|sort >oldsudo.tmp') || die "Can't create tmp file: $!\n";
while ($_ = pop(@seen)) {
print tmp $_;
}
close(tmp);
open(tmp,'oldsudo.tmp') || die "Can't reopen tmp file: $!\n";
while (<tmp>) {
print $seen{$_},":\t",$_;
}
print `(rm -f oldsudo.tmp; echo $max > oldsudo) 2>&1`;

84
contrib/perl5/eg/scan/scan_suid Normal file
View File

@ -0,0 +1,84 @@
#!/usr/bin/perl -P
# $RCSfile: scan_suid,v $$Revision: 4.1 $$Date: 92/08/07 17:20:43 $
# Look for new setuid root files.
chdir '/usr/adm/private/memories' || die "Can't cd to memories: $!\n";
($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
$blksize,$blocks) = stat('oldsuid');
if ($nlink) {
$lasttime = $mtime;
$tmp = $ctime - $atime;
if ($tmp <= 0 || $tmp >= 10) {
print "WARNING: somebody has read oldsuid!\n";
}
$tmp = $ctime - $mtime;
if ($tmp <= 0 || $tmp >= 10) {
print "WARNING: somebody has modified oldsuid!!!\n";
}
} else {
$lasttime = time - 60 * 60 * 24; # one day ago
}
$thistime = time;
#if defined(mc300) || defined(mc500) || defined(mc700)
open(Find, 'find / -perm -04000 -print |') ||
die "scan_find: can't run find";
#else
open(Find, 'find / \( -fstype nfs -prune \) -o -perm -04000 -ls |') ||
die "scan_find: can't run find";
#endif
open(suid, '>newsuid.tmp');
while (<Find>) {
#if defined(mc300) || defined(mc500) || defined(mc700)
$x = `/bin/ls -il $_`;
$_ = $x;
s/^ *//;
($inode,$perm,$links,$owner,$group,$size,$month,$day,$time,$name)
= split;
#else
s/^ *//;
($inode,$blocks,$perm,$links,$owner,$group,$size,$month,$day,$time,$name)
= split;
#endif
if ($perm =~ /[sS]/ && $owner eq 'root') {
($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
$blksize,$blocks) = stat($name);
$foo = sprintf("%10s%3s %-8s %-8s%9s %3s %2s %s %s\n",
$perm,$links,$owner,$group,$size,$month,$day,$name,$inode);
print suid $foo;
if ($ctime > $lasttime) {
if ($ctime > $thistime) {
print "Future file: $foo";
}
else {
$ct .= $foo;
}
}
}
}
close(suid);
print `sort +7 -8 newsuid.tmp >newsuid 2>&1`;
$foo = `/bin/diff oldsuid newsuid 2>&1`;
print "Differences in suid info:\n",$foo if $foo;
print `mv oldsuid oldoldsuid 2>&1; mv newsuid oldsuid 2>&1`;
print `touch oldsuid 2>&1;sleep 2 2>&1;chmod o+w oldsuid 2>&1`;
print `rm -f newsuid.tmp 2>&1`;
@ct = split(/\n/,$ct);
$ct = '';
$* = 1;
while ($#ct >= 0) {
$tmp = shift(@ct);
unless ($foo =~ "^>.*$tmp\n") { $ct .= "$tmp\n"; }
}
print "Inode changed since last time:\n",$ct if $ct;

87
contrib/perl5/eg/scan/scanner Normal file
View File

@ -0,0 +1,87 @@
#!/usr/bin/perl
# $RCSfile: scanner,v $$Revision: 4.1 $$Date: 92/08/07 17:20:44 $
# This runs all the scan_* routines on all the machines in /etc/ghosts.
# We run this every morning at about 6 am:
# !/bin/sh
# cd /usr/adm/private
# decrypt scanner | perl >scan.out 2>&1
# mail admin <scan.out
# Note that the scan_* files should be encrypted with the key "-inquire", and
# scanner should be encrypted somehow so that people can't find that key.
# I leave it up to you to figure out how to unencrypt it before executing.
$ENV{'PATH'} = '/bin:/usr/bin:/usr/local/bin:/usr/ucb:.';
$| = 1; # command buffering on stdout
print "Subject: bizarre happenings\n\n";
(chdir '/usr/adm/private') || die "Can't cd to /usr/adm/private: $!\n";
if ($#ARGV >= 0) {
@scanlist = @ARGV;
} else {
@scanlist = split(/[ \t\n]+/,`echo scan_*`);
}
scan: while ($scan = shift(@scanlist)) {
print "\n********** $scan **********\n";
$showhost++;
$systype = 'all';
open(ghosts, '/etc/ghosts') || die 'No /etc/ghosts file';
$one_of_these = ":$systype:";
if ($systype =~ s/\+/[+]/g) {
$one_of_these =~ s/\+/:/g;
}
line: while (<ghosts>) {
s/[ \t]*\n//;
if (!$_ || /^#/) {
next line;
}
if (/^([a-zA-Z_0-9]+)=(.+)/) {
$name = $1; $repl = $2;
$repl =~ s/\+/:/g;
$one_of_these =~ s/:$name:/:$repl:/;
next line;
}
@gh = split;
$host = $gh[0];
if ($showhost) { $showhost = "$host:\t"; }
class: while ($class = pop(gh)) {
if (index($one_of_these,":$class:") >=0) {
$iter = 0;
`exec crypt -inquire <$scan >.x 2>/dev/null`;
unless (open(scan,'.x')) {
print "Can't run $scan: $!\n";
next scan;
}
$cmd = <scan>;
unless ($cmd =~ s/#!(.*)\n/$1/) {
$cmd = '/usr/bin/perl';
}
close(scan);
if (open(PIPE,"exec rsh $host '$cmd' <.x|")) {
sleep(5);
unlink '.x';
while (<PIPE>) {
last if $iter++ > 1000; # must be looping
next if /^[0-9.]+u [0-9.]+s/;
print $showhost,$_;
}
close(PIPE);
} else {
print "(Can't execute rsh: $!)\n";
}
last class;
}
}
}
}

27
contrib/perl5/eg/server Executable file
View File

@ -0,0 +1,27 @@
#!./perl
$pat = 'S n C4 x8';
$inet = 2;
$echo = 7;
$smtp = 25;
$nntp = 119;
$this = pack($pat,$inet,2345, 0,0,0,0);
select(NS); $| = 1; select(stdout);
if (socket(S,2,1,6)) { print "socket ok\n"; } else { die $!; }
if (bind(S,$this)) { print "bind ok\n"; } else { die $!; }
if (listen(S,5)) { print "listen ok\n"; } else { die $!; }
for (;;) {
print "Listening again\n";
if ($addr = accept(NS,S)) { print "accept ok\n"; } else { die $!; }
@ary = unpack($pat,$addr);
$, = ' ';
print @ary; print "\n";
while (<NS>) {
print;
print NS;
}
}

24
contrib/perl5/eg/shmkill Normal file
View File

@ -0,0 +1,24 @@
#!/usr/bin/perl
# $RCSfile: shmkill,v $$Revision: 4.1 $$Date: 92/08/07 17:20:45 $
# A script to call from crontab periodically when people are leaving shared
# memory sitting around unattached.
open(ipcs,'ipcs -m -o|') || die "Can't run ipcs: $!";
while (<ipcs>) {
$tmp = index($_,'NATTCH');
$pos = $tmp if $tmp >= 0;
if (/^m/) {
($m,$id,$key,$mode,$owner,$group,$attach) = split;
if ($attach != substr($_,$pos,6)) {
die "Different ipcs format--can't parse!\n";
}
if ($attach == 0) {
push(@goners,'-m',$id);
}
}
}
exec 'ipcrm', @goners if $#goners >= 0;

9
contrib/perl5/eg/sysvipc/README Normal file
View File

@ -0,0 +1,9 @@
FYEnjoyment, here are the test scripts I used while implementing SysV
IPC in Perl. Each of them must be run with the parameter "s" for
"send" or "r" for "receive"; in each case, the receiver is the server
and the sender is the client.
--
Chip Salzenberg at ComDev/TCT <chip@tct.uucp>, <uunet!ateng!tct!chip>

47
contrib/perl5/eg/sysvipc/ipcmsg Normal file
View File

@ -0,0 +1,47 @@
#!/usr/bin/perl
eval 'exec /usr/bin/perl -S $0 ${1+"$@"}'
if $running_under_some_shell;
require 'sys/ipc.ph';
require 'sys/msg.ph';
$| = 1;
$mode = shift;
die "usage: ipcmsg {r|s}\n" unless $mode =~ /^[rs]$/;
$send = ($mode eq "s");
$id = msgget(0x1234, ($send ? 0 : &IPC_CREAT) | 0644);
die "Can't get message queue: $!\n" unless defined($id);
print "message queue id: $id\n";
if ($send) {
while (<STDIN>) {
chop;
unless (msgsnd($id, pack("LA*", $., $_), 0)) {
die "Can't send message: $!\n";
}
}
}
else {
$SIG{'INT'} = $SIG{'QUIT'} = "leave";
for (;;) {
unless (msgrcv($id, $_, 512, 0, 0)) {
die "Can't receive message: $!\n";
}
($type, $message) = unpack("La*", $_);
printf "[%d] %s\n", $type, $message;
}
}
&leave;
sub leave {
if (!$send) {
$x = msgctl($id, &IPC_RMID, 0);
if (!defined($x) || $x < 0) {
die "Can't remove message queue: $!\n";
}
}
exit;
}

46
contrib/perl5/eg/sysvipc/ipcsem Normal file
View File

@ -0,0 +1,46 @@
#!/usr/bin/perl
eval 'exec /usr/bin/perl -S $0 ${1+"$@"}'
if $running_under_some_shell;
require 'sys/ipc.ph';
require 'sys/msg.ph';
$| = 1;
$mode = shift;
die "usage: ipcmsg {r|s}\n" unless $mode =~ /^[rs]$/;
$signal = ($mode eq "s");
$id = semget(0x1234, 1, ($signal ? 0 : &IPC_CREAT) | 0644);
die "Can't get semaphore: $!\n" unless defined($id);
print "semaphore id: $id\n";
if ($signal) {
while (<STDIN>) {
print "Signalling\n";
unless (semop($id, pack("sss", 0, 1, 0))) {
die "Can't signal semaphore: $!\n";
}
}
}
else {
$SIG{'INT'} = $SIG{'QUIT'} = "leave";
for (;;) {
unless (semop($id, pack("sss", 0, -1, 0))) {
die "Can't wait for semaphore: $!\n";
}
print "Unblocked\n";
}
}
&leave;
sub leave {
if (!$signal) {
$x = semctl($id, 0, &IPC_RMID, 0);
if (!defined($x) || $x < 0) {
die "Can't remove semaphore: $!\n";
}
}
exit;
}

50
contrib/perl5/eg/sysvipc/ipcshm Normal file
View File

@ -0,0 +1,50 @@
#!/usr/bin/perl
eval 'exec /usr/bin/perl -S $0 ${1+"$@"}'
if $running_under_some_shell;
require 'sys/ipc.ph';
require 'sys/shm.ph';
$| = 1;
$mode = shift;
die "usage: ipcshm {r|s}\n" unless $mode =~ /^[rs]$/;
$send = ($mode eq "s");
$SIZE = 32;
$id = shmget(0x1234, $SIZE, ($send ? 0 : &IPC_CREAT) | 0644);
die "Can't get shared memory: $!\n" unless defined($id);
print "shared memory id: $id\n";
if ($send) {
while (<STDIN>) {
chop;
unless (shmwrite($id, pack("La*", length($_), $_), 0, $SIZE)) {
die "Can't write to shared memory: $!\n";
}
}
}
else {
$SIG{'INT'} = $SIG{'QUIT'} = "leave";
for (;;) {
$_ = <STDIN>;
unless (shmread($id, $_, 0, $SIZE)) {
die "Can't read shared memory: $!\n";
}
$len = unpack("L", $_);
$message = substr($_, length(pack("L",0)), $len);
printf "[%d] %s\n", $len, $message;
}
}
&leave;
sub leave {
if (!$send) {
$x = shmctl($id, &IPC_RMID, 0);
if (!defined($x) || $x < 0) {
die "Can't remove shared memory: $!\n";
}
}
exit;
}

46
contrib/perl5/eg/travesty Normal file
View File

@ -0,0 +1,46 @@
#!/usr/bin/perl
while (<>) {
next if /^\./;
next if /^From / .. /^$/;
next if /^Path: / .. /^$/;
s/^\W+//;
push(@ary,split(' '));
while ($#ary > 1) {
$a = $p;
$p = $n;
$w = shift(@ary);
$n = $num{$w};
if ($n eq '') {
push(@word,$w);
$n = pack('S',$#word);
$num{$w} = $n;
}
$lookup{$a . $p} .= $n;
}
}
for (;;) {
$n = $lookup{$a . $p};
($foo,$n) = each(lookup) if $n eq '';
$n = substr($n,int(rand(length($n))) & 0177776,2);
$a = $p;
$p = $n;
($w) = unpack('S',$n);
$w = $word[$w];
$col += length($w) + 1;
if ($col >= 65) {
$col = 0;
print "\n";
}
else {
print ' ';
}
print $w;
if ($w =~ /\.$/) {
if (rand() < .1) {
print "\n";
$col = 80;
}
}
}

186
contrib/perl5/eg/unuc Executable file
View File

@ -0,0 +1,186 @@
#!/usr/bin/perl
print STDERR "Loading proper nouns...\n";
open(DICT,"/usr/dict/words") || die "Can't find /usr/dict/words: $!\n";
while (<DICT>) {
if (/^[A-Z]/) {
chop;
($lower = $_) =~ y/A-Z/a-z/;
$proper{$lower} = $_;
}
}
close DICT;
print STDERR "Loading exceptions...\n";
$prog = <<'EOT';
while (<>) {
next if /[a-z]/;
y/A-Z/a-z/;
s/(\w+)/$proper{$1} ? $proper{$1} : $1/eg;
s/^(\s*)([a-z])/$1 . (($tmp = $2) =~ y:a-z:A-Z:,$tmp)/e;
s/([-.?!]["']?(\n\s*| \s*)["']?)([a-z])/$1 . (($tmp = $3) =~ y:a-z:A-Z:,$tmp)/eg;
s/\b([b-df-hj-np-tv-xz]+)\b/(($tmp = $1) =~ y:a-z:A-Z:,$tmp)/eg;
s/([a-z])'([SDT])\b/$1 . "'" . (($tmp = $2) =~ y:A-Z:a-z:,$tmp)/eg;
EOT
while (<DATA>) {
chop;
next if /^$/;
next if /^#/;
if (! /;$/) {
$foo = $_;
$foo =~ y/A-Z/a-z/;
print STDERR "Dup $_\n" if $proper{$foo};
$foo =~ s/([^\w ])/\\$1/g;
$foo =~ s/ /(\\s+)/g;
$foo = "\\b" . $foo if $foo =~ /^\w/; # XXX till patch 9
$foo .= "\\b" if $foo =~ /\w$/;
$i = 0;
($bar = $_) =~ s/ /'$' . ++$i/eg;
$_ = "s/$foo/$bar/gi;";
}
$prog .= ' ' . $_ . "\n";
}
$prog .= "}\ncontinue {\n print;\n}\n";
$/ = '';
#print $prog;
eval $prog; die $@ if $@;
__END__
A.M.
Air Force
Air Force Base
Air Force Station
American
Apr.
Ariane
Aug.
August
Bureau of Labor Statistics
CIT
Caltech
Cape Canaveral
Challenger
China
Corporation
Crippen
Daily News in Brief
Daniel Quayle
Dec.
Discovery
Edwards
Endeavour
Feb.
Ford Aerospace
Fri.
General Dynamics
George Bush
Headline News
HOTOL
I
II
III
IV
IX
Institute of Technology
JPL
Jan.
Jul.
Jun.
Kennedy Space Center
LDEF
Long Duration Exposure Facility
Long March
Mar.
March
Martin
Martin Marietta
Mercury
Mon.
in May
s/\bmay (\d)/May $1/g;
s/\boffice of (\w)/'Office of ' . (($tmp = $1) =~ y:a-z:A-Z:,$tmp)/eg;
National Science Foundation
NASA Select
New Mexico
Nov.
OMB
Oct.
Office of Management and Budget
President
President Bush
Richard Truly
Rocketdyne
Russian
Russians
Sat.
Sep.
Soviet
Soviet Union
Soviets
Space Shuttle
Sun.
Thu.
Tue.
U.S.
Union of Soviet Socialist Republics
United States
VI
VII
VIII
Vice President
Vice President Quayle
Wed.
White Sands
Kaman Aerospace
Aerospace Daily
Aviation Week
Space Technology
Washington Post
Los Angeles Times
New York Times
Aerospace Industries Association
president of
Johnson Space Center
Space Services
Inc.
Co.
Hughes Aircraft
Company
Orbital Sciences
Swedish Space
Arnauld
Nicogosian
Magellan
Galileo
Mir
Jet Propulsion Laboratory
University
Department of Defense
Orbital Science
OMS
United Press International
United Press
UPI
Associated Press
AP
Cable News Network
Cape York
Zenit
SYNCOM
Eastern
Western
Test Range
Jcsat
Japanese Satellite Communications
Defence Ministry
Defense Ministry
Skynet
Fixed Service Structure
Launch Processing System
Asiasat
Launch Control Center
Earth
CNES
Glavkosmos
Pacific
Atlantic

15
contrib/perl5/eg/uudecode Normal file
View File

@ -0,0 +1,15 @@
#!/usr/bin/perl
while (<>) {
next unless ($mode,$file) = /^begin\s*(\d*)\s*(\S*)/;
open(OUT,"> $file") || die "Can't create $file: $!\n";
while (<>) {
last if /^end/;
next if /[a-z]/;
next unless int((((ord() - 32) & 077) + 2) / 3) ==
int(length() / 4);
print OUT unpack("u", $_);
}
chmod oct($mode), $file;
eof() && die "Missing end: $file may be truncated.\n";
}

45
contrib/perl5/eg/van/empty Normal file
View File

@ -0,0 +1,45 @@
#!/usr/bin/perl
# $RCSfile: empty,v $$Revision: 4.1 $$Date: 92/08/07 17:20:50 $
# This script empties a trashcan.
$recursive = shift if $ARGV[0] eq '-r';
@ARGV = '.' if $#ARGV < 0;
chop($pwd = `pwd`);
dir: foreach $dir (@ARGV) {
unless (chdir $dir) {
print stderr "Can't find directory $dir: $!\n";
next dir;
}
if ($recursive) {
do cmd('find . -name .deleted -exec /bin/rm -rf {} ;');
}
else {
if (-d '.deleted') {
do cmd('rm -rf .deleted');
}
else {
if ($dir eq '.' && $pwd =~ m|/\.deleted$|) {
chdir '..';
do cmd('rm -rf .deleted');
}
else {
print stderr "No trashcan found in directory $dir\n";
}
}
}
}
continue {
chdir $pwd;
}
# force direct execution with no shell
sub cmd {
system split(' ',join(' ',@_));
}

66
contrib/perl5/eg/van/unvanish Normal file
View File

@ -0,0 +1,66 @@
#!/usr/bin/perl
# $RCSfile: unvanish,v $$Revision: 4.1 $$Date: 92/08/07 17:20:52 $
sub it {
if ($olddir ne '.') {
chop($pwd = `pwd`) if $pwd eq '';
(chdir $olddir) || die "Directory $olddir is not accesible";
}
unless ($olddir eq '.deleted') {
if (-d '.deleted') {
chdir '.deleted' || die "Directory .deleted is not accesible";
}
else {
chop($pwd = `pwd`) if $pwd eq '';
die "Directory .deleted does not exist" unless $pwd =~ /\.deleted$/;
}
}
print `mv $startfiles$filelist..$force`;
if ($olddir ne '.') {
(chdir $pwd) || die "Can't get back to original directory $pwd: $!\n";
}
}
if ($#ARGV < 0) {
open(lastcmd,'.deleted/.lastcmd') ||
open(lastcmd,'.lastcmd') ||
die "No previous vanish in this dir";
$ARGV = <lastcmd>;
close(lastcmd);
@ARGV = split(/[\n ]+/,$ARGV);
}
while ($ARGV[0] =~ /^-/) {
$_ = shift;
/^-f/ && ($force = ' >/dev/null 2>&1');
/^-i/ && ($interactive = 1);
if (/^-+$/) {
$startfiles = '- ';
last;
}
}
while ($file = shift) {
if ($file =~ s|^(.*)/||) {
$dir = $1;
}
else {
$dir = '.';
}
if ($dir ne $olddir) {
do it() if $olddir;
$olddir = $dir;
}
if ($interactive) {
print "unvanish: restore $dir/$file? ";
next unless <stdin> =~ /^y/i;
}
$filelist .= $file; $filelist .= ' ';
}
do it() if $olddir;

21
contrib/perl5/eg/van/vanexp Normal file
View File

@ -0,0 +1,21 @@
#!/usr/bin/perl
# $RCSfile: vanexp,v $$Revision: 4.1 $$Date: 92/08/07 17:20:53 $
# This is for running from a find at night to expire old .deleteds
$can = $ARGV[0];
exit 1 unless $can =~ /.deleted$/;
($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
$blksize,$blocks) = stat($can);
exit 0 unless $size;
if (time - $mtime > 2 * 24 * 60 * 60) {
`/bin/rm -rf $can`;
}
else {
`find $can -ctime +2 -exec rm -f {} \;`;
}

65
contrib/perl5/eg/van/vanish Normal file
View File

@ -0,0 +1,65 @@
#!/usr/bin/perl
# $RCSfile: vanish,v $$Revision: 4.1 $$Date: 92/08/07 17:20:54 $
sub it {
if ($olddir ne '.') {
chop($pwd = `pwd`) if $pwd eq '';
(chdir $olddir) || die "Directory $olddir is not accesible";
}
if (!-d .deleted) {
print `mkdir .deleted; chmod 775 .deleted`;
die "You can't remove files from $olddir" if $?;
}
$filelist =~ s/ $//;
$filelist =~ s/#/\\#/g;
if ($filelist !~ /^[ \t]*$/) {
open(lastcmd,'>.deleted/.lastcmd');
print lastcmd $filelist,"\n";
close(lastcmd);
print `/bin/mv $startfiles$filelist .deleted$force`;
}
if ($olddir ne '.') {
(chdir $pwd) || die "Can't get back to original directory $pwd: $!\n";
}
}
while ($ARGV[0] =~ /^-/) {
$_ = shift;
/^-f/ && ($force = ' >/dev/null 2>&1');
/^-i/ && ($interactive = 1);
if (/^-+$/) {
$startfiles = '- ';
last;
}
}
chop($pwd = `pwd`);
while ($file = shift) {
if ($file =~ s|^(.*)/||) {
$dir = $1;
}
else {
$dir = '.';
}
if ($interactive) {
print "vanish: remove $dir/$file? ";
next unless <stdin> =~ /^y/i;
}
if ($file eq '.deleted') {
print stderr "To delete .deleted (the trashcan) use the 'empty' command.\n";
next;
}
if ($dir ne $olddir) {
do it() if $olddir;
$olddir = $dir;
}
$filelist .= $file; $filelist .= ' ';
}
do it() if $olddir;

13
contrib/perl5/eg/who Normal file
View File

@ -0,0 +1,13 @@
#!/usr/bin/perl
# This assumes your /etc/utmp file looks like ours
open(UTMP,'/etc/utmp');
@mo = (Jan,Feb,Mar,Apr,May,Jun,Jul,Aug,Sep,Oct,Nov,Dec);
while (read(UTMP,$utmp,36)) {
($line,$name,$host,$time) = unpack('A8A8A16l',$utmp);
if ($name) {
$host = "($host)" if ord($host);
($sec,$min,$hour,$mday,$mon) = localtime($time);
printf "%-9s%-8s%s %2d %02d:%02d %s\n",
$name,$line,$mo[$mon],$mday,$hour,$min,$host;
}
}

104
contrib/perl5/eg/wrapsuid Executable file
View File

@ -0,0 +1,104 @@
#!/usr/bin/perl
'di';
'ig00';
#
# $Header: wrapsuid,v 1.1 90/08/11 13:51:29 lwall Locked $
#
# $Log: wrapsuid,v $
# Revision 1.1 90/08/11 13:51:29 lwall
# Initial revision
#
$xdev = '-xdev' unless -d '/dev/iop';
if ($#ARGV >= 0) {
@list = @ARGV;
foreach $name (@ARGV) {
die "You must use absolute pathnames.\n" unless $name =~ m|^/|;
}
}
else {
open(DF,"/etc/mount|") || die "Can't run /etc/mount";
while (<DF>) {
chop;
$_ .= <DF> if length($_) < 50;
@ary = split;
push(@list,$ary[2]) if ($ary[0] =~ m|^/dev|);
}
}
$fslist = join(' ',@list);
die "Can't find local filesystems" unless $fslist;
open(FIND,
"find $fslist $xdev -type f \\( -perm -04000 -o -perm -02000 \\) -print|");
while (<FIND>) {
chop;
next unless -T;
print "Fixing ", $_, "\n";
($dir,$file) = m|(.*)/(.*)|;
chdir $dir || die "Can't chdir to $dir";
($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
$blksize,$blocks) = stat($file);
die "Can't stat $_" unless $ino;
chmod $mode & 01777, $file; # wipe out set[ug]id bits
rename($file,".$file");
open(C,">.tmp$$.c") || die "Can't write C program for $_";
$real = "$dir/.$file";
print C '
main(argc,argv)
int argc;
char **argv;
{
execv("' . $real . '",argv);
}
';
close C;
system '/bin/cc', ".tmp$$.c", '-o', $file;
die "Can't compile new $_" if $?;
chmod $mode, $file;
chown $uid, $gid, $file;
unlink ".tmp$$.c";
chdir '/';
}
##############################################################################
# These next few lines are legal in both Perl and nroff.
.00; # finish .ig
'di \" finish diversion--previous line must be blank
.nr nl 0-1 \" fake up transition to first page again
.nr % 0 \" start at page 1
'; __END__ ############# From here on it's a standard manual page ############
.TH SUIDSCRIPT 1 "July 30, 1990"
.AT 3
.SH NAME
wrapsuid \- puts a compiled C wrapper around a setuid or setgid script
.SH SYNOPSIS
.B wrapsuid [dirlist]
.SH DESCRIPTION
.I Wrapsuid
creates a small C program to execute a script with setuid or setgid privileges
without having to set the setuid or setgid bit on the script, which is
a security problem on many machines.
Specify the list of directories or files that you wish to process.
The names must be absolute pathnames.
With no arguments it will attempt to process all the local directories
for this machine.
The scripts to be processed must have the setuid or setgid bit set.
The wrapsuid program will delete the bits and set them on the wrapper.
.PP
Non-superusers may only process their own files.
.SH ENVIRONMENT
No environment variables are used.
.SH FILES
None.
.SH AUTHOR
Larry Wall
.SH "SEE ALSO"
.SH DIAGNOSTICS
.SH BUGS
.ex

3
contrib/perl5/embed.h
View File

@ -159,6 +159,7 @@
#define do_trans Perl_do_trans
#define do_vecset Perl_do_vecset
#define do_vop Perl_do_vop
#define dofile Perl_dofile
#define dofindlabel Perl_dofindlabel
#define dopoptoeval Perl_dopoptoeval
#define dounwind Perl_dounwind
@ -204,6 +205,7 @@
#define get_op_names Perl_get_op_names
#define get_opargs Perl_get_opargs
#define get_specialsv_list Perl_get_specialsv_list
#define get_vtbl Perl_get_vtbl
#define gp_free Perl_gp_free
#define gp_ref Perl_gp_ref
#define gt_amg Perl_gt_amg
@ -859,6 +861,7 @@
#define save_freeop Perl_save_freeop
#define save_freepv Perl_save_freepv
#define save_freesv Perl_save_freesv
#define save_generic_svref Perl_save_generic_svref
#define save_gp Perl_save_gp
#define save_hash Perl_save_hash
#define save_helem Perl_save_helem

14
contrib/perl5/embed.pl
View File

@ -37,7 +37,6 @@ sub readsyms (\%$) {
}
readsyms %global, 'global.sym';
readsyms %interp, 'interp.sym';
sub readvars(\%$$) {
my ($syms, $file,$pre) = @_;
@ -63,11 +62,10 @@ readvars %globvar, 'perlvars.h','G';
foreach my $sym (sort keys %intrp)
{
warn "$sym not in interp.sym\n" unless exists $interp{$sym};
if (exists $global{$sym})
{
delete $global{$sym};
warn "$sym in global.sym as well as interp\n";
warn "$sym in global.sym as well as intrpvar.h\n";
}
}
@ -80,19 +78,13 @@ foreach my $sym (sort keys %globvar)
}
}
foreach my $sym (keys %interp)
{
warn "extra $sym in interp.sym\n"
unless exists $intrp{$sym} || exists $thread{$sym};
}
foreach my $sym (sort keys %thread)
{
warn "$sym in intrpvar.h\n" if exists $intrp{$sym};
warn "$sym in intrpvar.h as well as thrdvar.h\n" if exists $intrp{$sym};
if (exists $global{$sym})
{
delete $global{$sym};
warn "$sym in global.sym as well as thread\n";
warn "$sym in global.sym as well as thrdvar.h\n";
}
}

4
contrib/perl5/embedvar.h
View File

@ -250,6 +250,7 @@
#define PL_stdingv (PL_curinterp->Istdingv)
#define PL_strchop (PL_curinterp->Istrchop)
#define PL_strtab (PL_curinterp->Istrtab)
#define PL_strtab_mutex (PL_curinterp->Istrtab_mutex)
#define PL_sub_generation (PL_curinterp->Isub_generation)
#define PL_sublex_info (PL_curinterp->Isublex_info)
#define PL_sv_arenaroot (PL_curinterp->Isv_arenaroot)
@ -384,6 +385,7 @@
#define PL_Istdingv PL_stdingv
#define PL_Istrchop PL_strchop
#define PL_Istrtab PL_strtab
#define PL_Istrtab_mutex PL_strtab_mutex
#define PL_Isub_generation PL_sub_generation
#define PL_Isublex_info PL_sublex_info
#define PL_Isv_arenaroot PL_sv_arenaroot
@ -647,6 +649,7 @@
#define PL_collxfrm_base (PL_Vars.Gcollxfrm_base)
#define PL_collxfrm_mult (PL_Vars.Gcollxfrm_mult)
#define PL_cop_seqmax (PL_Vars.Gcop_seqmax)
#define PL_cred_mutex (PL_Vars.Gcred_mutex)
#define PL_cryptseen (PL_Vars.Gcryptseen)
#define PL_cshlen (PL_Vars.Gcshlen)
#define PL_cshname (PL_Vars.Gcshname)
@ -757,6 +760,7 @@
#define PL_Gcollxfrm_base PL_collxfrm_base
#define PL_Gcollxfrm_mult PL_collxfrm_mult
#define PL_Gcop_seqmax PL_cop_seqmax
#define PL_Gcred_mutex PL_cred_mutex
#define PL_Gcryptseen PL_cryptseen
#define PL_Gcshlen PL_cshlen
#define PL_Gcshname PL_cshname

10
contrib/perl5/ext/B/B.pm
View File

@ -13,7 +13,7 @@ require Exporter;
class peekop cast_I32 cstring cchar hash threadsv_names
main_root main_start main_cv svref_2object
walkoptree walkoptree_slow walkoptree_exec walksymtable
parents comppadlist sv_undef compile_stats timing_info);
parents comppadlist sv_undef compile_stats timing_info init_av);
use strict;
@B::SV::ISA = 'B::OBJECT';
@ -530,6 +530,8 @@ C<REFCNT> (corresponding to the C function C<SvREFCNT>).
=item XSUBANY
=item CvFLAGS
=back
=head2 B::HV METHODS
@ -576,7 +578,7 @@ This returns the function name as a string (e.g. pp_add, pp_rv2av).
=item desc
This returns the op description from the global C op_desc array
This returns the op description from the global C PL_op_desc array
(e.g. "addition" "array deref").
=item targ
@ -720,6 +722,10 @@ get an initial "handle" on an internal object.
Return the (faked) CV corresponding to the main part of the Perl
program.
=item init_av
Returns the AV object (i.e. in class B::AV) representing INIT blocks.
=item main_root
Returns the root op (i.e. an object in the appropriate B::OP-derived

14
contrib/perl5/ext/B/B.xs
View File

@ -267,7 +267,8 @@ static SV *
cchar(SV *sv)
{
SV *sstr = newSVpv("'", 0);
char *s = SvPV(sv, PL_na);
STRLEN n_a;
char *s = SvPV(sv, n_a);
if (*s == '\'')
sv_catpv(sstr, "\\'");
@ -437,6 +438,7 @@ BOOT:
INIT_SPECIALSV_LIST;
#define B_main_cv() PL_main_cv
#define B_init_av() PL_initav
#define B_main_root() PL_main_root
#define B_main_start() PL_main_start
#define B_comppadlist() (PL_main_cv ? CvPADLIST(PL_main_cv) : CvPADLIST(PL_compcv))
@ -444,6 +446,9 @@ BOOT:
#define B_sv_yes() &PL_sv_yes
#define B_sv_no() &PL_sv_no
B::AV
B_init_av()
B::CV
B_main_cv()
@ -1164,6 +1169,13 @@ CvXSUBANY(cv)
CODE:
ST(0) = sv_2mortal(newSViv(CvXSUBANY(cv).any_iv));
MODULE = B PACKAGE = B::CV
U8
CvFLAGS(cv)
B::CV cv
MODULE = B PACKAGE = B::HV PREFIX = Hv
STRLEN

4
contrib/perl5/ext/B/B/Assembler.pm
View File

@ -53,6 +53,8 @@ sub B::Asmdata::PUT_U16 { pack("n", $_[0]) }
sub B::Asmdata::PUT_U32 { pack("N", $_[0]) }
sub B::Asmdata::PUT_I32 { pack("N", $_[0]) }
sub B::Asmdata::PUT_objindex { pack("N", $_[0]) } # could allow names here
sub B::Asmdata::PUT_svindex { &B::Asmdata::PUT_objindex }
sub B::Asmdata::PUT_opindex { &B::Asmdata::PUT_objindex }
sub B::Asmdata::PUT_strconst {
my $arg = shift;
@ -78,7 +80,7 @@ sub B::Asmdata::PUT_PV {
error "bad string argument: $arg" unless defined($arg);
return pack("N", length($arg)) . $arg;
}
sub B::Asmdata::PUT_comment {
sub B::Asmdata::PUT_comment_t {
my $arg = shift;
$arg = uncstring($arg);
error "bad string argument: $arg" unless defined($arg);

Some files were not shown because too many files have changed in this diff Show More