From 2304df62caa7d9be70e8b8bcdb454e139c9c103d Mon Sep 17 00:00:00 2001 From: Andy Dougherty Date: Mon, 4 Apr 1994 00:00:00 +0000 Subject: perl 5.0 alpha 8 [the last one taken from the September '94 InfoMagic CD; a similar style of cleanup as the previous commits was performed] --- lib/Config.pm | 361 ++++++++++------- lib/English.pm | 2 - lib/FileHandle.pm | 21 +- lib/POSIX.pm | 1045 ++++++++++++++++++++++++++++++++++++++++++++++++- lib/auto/POSIX/_exit | 9 + lib/auto/README | 2 + lib/dotsh.pl.art | 154 ++++++++ lib/quotewords.pl.art | 146 +++++++ lib/soundex.pl.art | 285 ++++++++++++++ 9 files changed, 1863 insertions(+), 162 deletions(-) create mode 100644 lib/auto/POSIX/_exit create mode 100644 lib/auto/README create mode 100644 lib/dotsh.pl.art create mode 100644 lib/quotewords.pl.art create mode 100644 lib/soundex.pl.art (limited to 'lib') diff --git a/lib/Config.pm b/lib/Config.pm index f911b21bcb..5ea45e62f7 100644 --- a/lib/Config.pm +++ b/lib/Config.pm @@ -6,114 +6,136 @@ require Exporter; $] == 5.000 or die sprintf "Perl lib version (5.000) doesn't match executable version (%.3f)\n", $]; -# config.sh -# This file was produced by running the Configure script. +# +# This file was produced by running the Configure script. It holds all the +# definitions figured out by Configure. Should you modify one of these values, +# do not forget to propagate your changes by running "Configure -der". You may +# instead choose to run each of the .SH files by yourself, or "Configure -S". +# + +# Configuration time: Mon Apr 4 15:17:26 PDT 1994 +# Configured by: lwall +# Target system: sunos scalpel 4.1.3 3 sun4c + +$Config{'extensions'} = 'ext/dbm/NDBM_File.xs +ext/dbm/ODBM_File.xs +ext/dbm/GDBM_File.xs +ext/dbm/SDBM_File.xs +ext/posix/POSIX.xs'; +$Config{'d_bsd'} = 'define'; $Config{'d_eunice'} = undef; -$Config{'define'} = 'define'; +$Config{'d_xenix'} = undef; $Config{'eunicefix'} = ':'; -$Config{'loclist'} = ' -cat -cp -echo -expr -grep -mkdir -mv -rm -sed -sort -tr -uniq -'; -$Config{'expr'} = '/bin/expr'; -$Config{'sed'} = '/bin/sed'; -$Config{'echo'} = '/bin/echo'; -$Config{'cat'} = '/bin/cat'; -$Config{'rm'} = '/bin/rm'; -$Config{'mv'} = '/bin/mv'; -$Config{'cp'} = '/bin/cp'; -$Config{'tail'} = ''; -$Config{'tr'} = '/bin/tr'; -$Config{'mkdir'} = '/bin/mkdir'; -$Config{'sort'} = '/bin/sort'; -$Config{'uniq'} = '/bin/uniq'; -$Config{'grep'} = '/bin/grep'; -$Config{'trylist'} = ' -Mcc -bison -cpp -csh -egrep -line -nroff -perl -test -uname -yacc -'; -$Config{'test'} = 'test'; -$Config{'inews'} = ''; -$Config{'egrep'} = '/bin/egrep'; -$Config{'more'} = ''; -$Config{'pg'} = ''; $Config{'Mcc'} = 'Mcc'; -$Config{'vi'} = ''; -$Config{'mailx'} = ''; -$Config{'mail'} = ''; -$Config{'cpp'} = '/usr/lib/cpp'; -$Config{'perl'} = '/home/netlabs1/lwall/pl/perl'; +$Config{'awk'} = 'awk'; +$Config{'bash'} = ''; +$Config{'bison'} = 'bison'; +$Config{'byacc'} = 'byacc'; +$Config{'cat'} = 'cat'; +$Config{'chgrp'} = ''; +$Config{'chmod'} = ''; +$Config{'chown'} = ''; +$Config{'compress'} = ''; +$Config{'cp'} = 'cp'; +$Config{'cpio'} = ''; +$Config{'cpp'} = 'cpp'; +$Config{'csh'} = 'csh'; +$Config{'date'} = 'date'; +$Config{'echo'} = 'echo'; +$Config{'egrep'} = 'egrep'; $Config{'emacs'} = ''; +$Config{'expr'} = 'expr'; +$Config{'find'} = 'find'; +$Config{'flex'} = ''; +$Config{'gcc'} = ''; +$Config{'grep'} = 'grep'; +$Config{'inews'} = ''; +$Config{'ksh'} = ''; +$Config{'less'} = ''; +$Config{'line'} = 'line'; +$Config{'lint'} = ''; +$Config{'ln'} = ''; +$Config{'lp'} = ''; +$Config{'lpr'} = ''; $Config{'ls'} = ''; +$Config{'mail'} = ''; +$Config{'mailx'} = ''; +$Config{'make'} = ''; +$Config{'mkdir'} = 'mkdir'; +$Config{'more'} = ''; +$Config{'mv'} = 'mv'; +$Config{'nroff'} = 'nroff'; +$Config{'perl'} = 'perl'; +$Config{'pg'} = ''; +$Config{'pmake'} = ''; +$Config{'pr'} = ''; +$Config{'rm'} = 'rm'; $Config{'rmail'} = ''; +$Config{'sed'} = 'sed'; $Config{'sendmail'} = ''; +$Config{'sh'} = ''; $Config{'shar'} = ''; +$Config{'sleep'} = ''; $Config{'smail'} = ''; +$Config{'sort'} = 'sort'; +$Config{'submit'} = ''; +$Config{'tail'} = ''; +$Config{'tar'} = ''; $Config{'tbl'} = ''; +$Config{'test'} = 'test'; +$Config{'touch'} = ''; +$Config{'tr'} = 'tr'; $Config{'troff'} = ''; -$Config{'nroff'} = '/bin/nroff'; -$Config{'uname'} = '/bin/uname'; +$Config{'uname'} = 'uname'; +$Config{'uniq'} = 'uniq'; $Config{'uuname'} = ''; -$Config{'line'} = '/bin/line'; -$Config{'chgrp'} = ''; -$Config{'chmod'} = ''; -$Config{'lint'} = ''; -$Config{'sleep'} = ''; -$Config{'pr'} = ''; -$Config{'tar'} = ''; -$Config{'ln'} = ''; -$Config{'lpr'} = ''; -$Config{'lp'} = ''; -$Config{'touch'} = ''; -$Config{'make'} = ''; -$Config{'date'} = ''; -$Config{'csh'} = '/bin/csh'; -$Config{'bash'} = ''; -$Config{'ksh'} = ''; -$Config{'lex'} = ''; -$Config{'flex'} = ''; -$Config{'bison'} = '/usr/local/bin/bison'; -$Config{'Log'} = '$Log'; -$Config{'Header'} = '$Header'; +$Config{'vi'} = ''; +$Config{'zcat'} = ''; +$Config{'hint'} = 'recommended'; +$Config{'myuname'} = 'sunos scalpel 4.1.3 3 sun4c '; +$Config{'Author'} = ''; +$Config{'Date'} = '$Date'; +$Config{'Header'} = ''; $Config{'Id'} = '$Id'; -$Config{'lastuname'} = 'SunOS scalpel 4.1.2 1 sun4c'; +$Config{'Locker'} = ''; +$Config{'Log'} = '$Log'; +$Config{'RCSfile'} = '$RCSfile'; +$Config{'Revision'} = '$Revision'; +$Config{'Source'} = ''; +$Config{'State'} = ''; +$Config{'afs'} = 'false'; $Config{'alignbytes'} = '8'; $Config{'bin'} = '/usr/local/bin'; +$Config{'binexp'} = '/usr/local/bin'; $Config{'installbin'} = '/usr/local/bin'; $Config{'byteorder'} = '4321'; +$Config{'cc'} = 'cc'; +$Config{'gccversion'} = ''; +$Config{'ccflags'} = '-DDEBUGGING'; +$Config{'cppflags'} = ' -DDEBUGGING'; +$Config{'ldflags'} = ''; +$Config{'lkflags'} = ''; +$Config{'optimize'} = '-g'; +$Config{'cf_by'} = 'lwall'; +$Config{'cf_time'} = 'Mon Apr 4 15:17:26 PDT 1994'; $Config{'contains'} = 'grep'; -$Config{'cppstdin'} = '/usr/lib/cpp'; +$Config{'cpplast'} = ''; $Config{'cppminus'} = ''; +$Config{'cpprun'} = 'cpp'; +$Config{'cppstdin'} = '/tmp_mnt/vol/src/local/lwall/perl5/cppstdin'; +$Config{'d_access'} = 'define'; $Config{'d_bcmp'} = 'define'; $Config{'d_bcopy'} = 'define'; -$Config{'d_safebcpy'} = 'define'; $Config{'d_bzero'} = 'define'; -$Config{'d_castneg'} = 'define'; +$Config{'d_casti32'} = 'define'; $Config{'castflags'} = '0'; +$Config{'d_castneg'} = 'define'; $Config{'d_charsprf'} = 'define'; $Config{'d_chsize'} = undef; -$Config{'d_crypt'} = 'define'; +$Config{'d_const'} = undef; $Config{'cryptlib'} = ''; -$Config{'d_csh'} = 'define'; +$Config{'d_crypt'} = 'define'; +$Config{'d_csh'} = undef; $Config{'d_dosuid'} = undef; $Config{'d_dup2'} = 'define'; $Config{'d_fchmod'} = 'define'; @@ -123,17 +145,20 @@ $Config{'d_flexfnam'} = 'define'; $Config{'d_flock'} = 'define'; $Config{'d_getgrps'} = 'define'; $Config{'d_gethent'} = undef; -$Config{'d_getpgrp'} = 'define'; +$Config{'aphostname'} = ''; +$Config{'d_gethname'} = undef; +$Config{'d_phostname'} = undef; +$Config{'d_uname'} = 'define'; $Config{'d_getpgrp2'} = undef; +$Config{'d_getpgrp'} = 'define'; $Config{'d_getprior'} = 'define'; $Config{'d_htonl'} = 'define'; -$Config{'d_index'} = undef; $Config{'d_isascii'} = 'define'; $Config{'d_killpg'} = 'define'; +$Config{'d_link'} = 'define'; $Config{'d_lstat'} = 'define'; $Config{'d_memcmp'} = 'define'; $Config{'d_memcpy'} = 'define'; -$Config{'d_safemcpy'} = undef; $Config{'d_memmove'} = undef; $Config{'d_memset'} = 'define'; $Config{'d_mkdir'} = 'define'; @@ -142,14 +167,13 @@ $Config{'d_msgctl'} = 'define'; $Config{'d_msgget'} = 'define'; $Config{'d_msgrcv'} = 'define'; $Config{'d_msgsnd'} = 'define'; -$Config{'d_ndbm'} = 'define'; -$Config{'d_odbm'} = 'define'; $Config{'d_open3'} = 'define'; +$Config{'d_portable'} = 'define'; $Config{'d_readdir'} = 'define'; $Config{'d_rename'} = 'define'; -$Config{'d_rewindir'} = undef; $Config{'d_rmdir'} = 'define'; -$Config{'d_seekdir'} = 'define'; +$Config{'d_safebcpy'} = 'define'; +$Config{'d_safemcpy'} = undef; $Config{'d_select'} = 'define'; $Config{'d_sem'} = 'define'; $Config{'d_semctl'} = 'define'; @@ -157,119 +181,162 @@ $Config{'d_semget'} = 'define'; $Config{'d_semop'} = 'define'; $Config{'d_setegid'} = 'define'; $Config{'d_seteuid'} = 'define'; -$Config{'d_setpgrp'} = 'define'; +$Config{'d_setlocale'} = 'define'; +$Config{'d_setpgid'} = 'define'; $Config{'d_setpgrp2'} = undef; +$Config{'d_bsdpgrp'} = ''; +$Config{'d_setpgrp'} = 'define'; $Config{'d_setprior'} = 'define'; $Config{'d_setregid'} = 'define'; $Config{'d_setresgid'} = undef; -$Config{'d_setreuid'} = 'define'; $Config{'d_setresuid'} = undef; +$Config{'d_setreuid'} = 'define'; $Config{'d_setrgid'} = 'define'; $Config{'d_setruid'} = 'define'; +$Config{'d_setsid'} = 'define'; $Config{'d_shm'} = 'define'; $Config{'d_shmat'} = 'define'; -$Config{'d_voidshmat'} = undef; $Config{'d_shmctl'} = 'define'; $Config{'d_shmdt'} = 'define'; $Config{'d_shmget'} = 'define'; +$Config{'d_oldsock'} = undef; $Config{'d_socket'} = 'define'; $Config{'d_sockpair'} = 'define'; -$Config{'d_oldsock'} = undef; +$Config{'sockethdr'} = ''; $Config{'socketlib'} = ''; $Config{'d_statblks'} = 'define'; $Config{'d_stdstdio'} = 'define'; +$Config{'d_index'} = undef; +$Config{'d_strchr'} = 'define'; $Config{'d_strctcpy'} = 'define'; +$Config{'d_strerrm'} = 'define'; $Config{'d_strerror'} = undef; +$Config{'d_sysernlst'} = ''; +$Config{'d_syserrlst'} = 'define'; $Config{'d_symlink'} = 'define'; $Config{'d_syscall'} = 'define'; -$Config{'d_telldir'} = 'define'; +$Config{'d_system'} = 'define'; +$Config{'clocktype'} = 'long'; +$Config{'d_times'} = 'define'; $Config{'d_truncate'} = 'define'; +$Config{'d_usendir'} = undef; +$Config{'i_ndir'} = undef; +$Config{'ndirc'} = ''; +$Config{'ndirlib'} = ''; +$Config{'ndiro'} = ''; $Config{'d_vfork'} = 'define'; $Config{'d_voidsig'} = 'define'; -$Config{'d_tosignal'} = 'int'; +$Config{'signal_t'} = 'void'; $Config{'d_volatile'} = undef; -$Config{'d_vprintf'} = 'define'; $Config{'d_charvspr'} = 'define'; +$Config{'d_vprintf'} = 'define'; $Config{'d_wait4'} = 'define'; $Config{'d_waitpid'} = 'define'; +$Config{'dlobj'} = 'dl.o'; +$Config{'dlsrc'} = 'dl.c'; +$Config{'usedl'} = 'define'; $Config{'gidtype'} = 'gid_t'; $Config{'groupstype'} = 'int'; +$Config{'h_fcntl'} = 'false'; +$Config{'h_sysfile'} = 'true'; +$Config{'i_dbm'} = 'define'; +$Config{'d_dirnamlen'} = undef; +$Config{'i_dirent'} = 'define'; +$Config{'i_dlfcn'} = 'define'; $Config{'i_fcntl'} = undef; $Config{'i_gdbm'} = undef; $Config{'i_grp'} = 'define'; +$Config{'i_ndbm'} = 'define'; $Config{'i_niin'} = 'define'; $Config{'i_sysin'} = undef; -$Config{'i_pwd'} = 'define'; -$Config{'d_pwquota'} = undef; $Config{'d_pwage'} = 'define'; $Config{'d_pwchange'} = undef; $Config{'d_pwclass'} = undef; -$Config{'d_pwexpire'} = undef; $Config{'d_pwcomment'} = 'define'; -$Config{'i_sys_file'} = 'define'; +$Config{'d_pwexpire'} = undef; +$Config{'d_pwquota'} = undef; +$Config{'i_pwd'} = 'define'; +$Config{'i_stdarg'} = undef; +$Config{'i_stddef'} = 'define'; +$Config{'i_string'} = 'define'; +$Config{'strings'} = '/usr/include/string.h'; +$Config{'i_sysdir'} = 'define'; +$Config{'i_sysfile'} = 'define'; +$Config{'d_voidtty'} = ''; +$Config{'i_bsdioctl'} = ''; $Config{'i_sysioctl'} = 'define'; +$Config{'i_syssockio'} = ''; +$Config{'i_sysndir'} = undef; +$Config{'i_sysselct'} = undef; +$Config{'i_sgtty'} = undef; +$Config{'i_termio'} = undef; +$Config{'i_termios'} = 'define'; +$Config{'i_systime'} = 'define'; +$Config{'i_systimek'} = undef; $Config{'i_time'} = undef; -$Config{'i_sys_time'} = 'define'; -$Config{'i_sys_select'} = undef; -$Config{'d_systimekernel'} = undef; +$Config{'timeincl'} = '/usr/include/sys/time.h '; $Config{'i_utime'} = 'define'; $Config{'i_varargs'} = 'define'; +$Config{'i_varhdr'} = 'varargs.h'; $Config{'i_vfork'} = 'define'; $Config{'intsize'} = '4'; -$Config{'libc'} = '/usr/lib/libc.so.1.7'; -$Config{'nm_opts'} = ''; -$Config{'libndir'} = ''; -$Config{'i_my_dir'} = undef; -$Config{'i_ndir'} = undef; -$Config{'i_sys_ndir'} = undef; -$Config{'i_dirent'} = 'define'; -$Config{'i_sys_dir'} = undef; -$Config{'d_dirnamlen'} = undef; -$Config{'ndirc'} = ''; -$Config{'ndiro'} = ''; -$Config{'mallocsrc'} = 'malloc.c'; +$Config{'lib'} = '/usr/local/lib'; +$Config{'libexp'} = '/usr/local/lib'; +$Config{'libc'} = '/usr/lib/libc.so.1.8.1'; +$Config{'libpth'} = ' /lib /usr/lib /usr/ucblib /usr/local/lib'; +$Config{'plibpth'} = ''; +$Config{'xlibpth'} = '/usr/lib/386 /lib/386'; +$Config{'libs'} = '-ldbm -ldl -lm -lposix'; $Config{'mallocobj'} = 'malloc.o'; -$Config{'d_mymalloc'} = 'define'; -$Config{'mallocptrtype'} = 'char'; -$Config{'mansrc'} = '/usr/man/manl'; -$Config{'manext'} = 'l'; +$Config{'mallocsrc'} = 'malloc.c'; +$Config{'malloctype'} = 'char *'; +$Config{'usemymalloc'} = 'y'; +$Config{'installmansrc'} = '/usr/local/man/man1'; +$Config{'manext'} = '1'; +$Config{'mansrc'} = '/usr/local/man/man1'; +$Config{'mansrcexp'} = '/usr/local/man/man1'; +$Config{'huge'} = ''; +$Config{'large'} = ''; +$Config{'medium'} = ''; $Config{'models'} = 'none'; -$Config{'split'} = ''; $Config{'small'} = ''; -$Config{'medium'} = ''; -$Config{'large'} = ''; -$Config{'huge'} = ''; -$Config{'optimize'} = '-g'; -$Config{'ccflags'} = '-DDEBUGGING -DHAS_SDBM'; -$Config{'cppflags'} = '-DDEBUGGING -DHAS_SDBM'; -$Config{'ldflags'} = ''; -$Config{'cc'} = 'cc'; -$Config{'nativegcc'} = ''; -$Config{'libs'} = '-ldbm -lm -lposix'; -$Config{'n'} = '-n'; +$Config{'split'} = ''; +$Config{'mydomain'} = ''; +$Config{'myhostname'} = 'scalpel'; +$Config{'phostname'} = 'hostname'; $Config{'c'} = ''; +$Config{'n'} = '-n'; +$Config{'groupcat'} = ''; +$Config{'hostcat'} = 'ypcat hosts'; +$Config{'passcat'} = ''; $Config{'package'} = 'perl'; +$Config{'spackage'} = ''; +$Config{'installprivlib'} = '/usr/local/lib/perl'; +$Config{'privlib'} = '/usr/local/lib/perl'; +$Config{'privlibexp'} = '/usr/local/lib/perl'; +$Config{'prototype'} = undef; $Config{'randbits'} = '31'; +$Config{'installscript'} = '/usr/local/bin'; $Config{'scriptdir'} = '/usr/local/bin'; -$Config{'installscr'} = '/usr/local/bin'; +$Config{'scriptdirexp'} = '/usr/local/bin'; $Config{'sig_name'} = 'ZERO HUP INT QUIT ILL TRAP ABRT EMT FPE KILL BUS SEGV SYS PIPE ALRM TERM URG STOP TSTP CONT CLD TTIN TTOU IO XCPU XFSZ VTALRM PROF WINCH LOST USR1 USR2'; -$Config{'spitshell'} = 'cat'; -$Config{'shsharp'} = 'true'; $Config{'sharpbang'} = '#!'; +$Config{'shsharp'} = 'true'; +$Config{'spitshell'} = 'cat'; $Config{'startsh'} = '#!/bin/sh'; $Config{'stdchar'} = 'unsigned char'; +$Config{'sysman'} = '/usr/man/man1'; $Config{'uidtype'} = 'uid_t'; -$Config{'usrinclude'} = '/usr/include'; -$Config{'inclPath'} = ''; -$Config{'void'} = ''; -$Config{'voidhave'} = '7'; -$Config{'voidwant'} = '7'; -$Config{'w_localtim'} = '1'; -$Config{'w_s_timevl'} = '1'; -$Config{'w_s_tm'} = '1'; -$Config{'yacc'} = '/bin/yacc'; -$Config{'lib'} = ''; -$Config{'privlib'} = '/usr/local/lib/perl'; -$Config{'installprivlib'} = '/usr/local/lib/perl'; -$Config{'PATCHLEVEL'} = 34; +$Config{'nm_opt'} = ''; +$Config{'runnm'} = 'true'; +$Config{'usenm'} = 'true'; +$Config{'incpath'} = ''; +$Config{'mips'} = ''; +$Config{'mips_type'} = ''; +$Config{'usrinc'} = '/usr/include'; +$Config{'defvoidused'} = '15'; +$Config{'voidflags'} = '15'; +$Config{'yacc'} = 'yacc'; +$Config{'yaccflags'} = ''; +$Config{'PATCHLEVEL'} = 0; $Config{'CONFIG'} = true diff --git a/lib/English.pm b/lib/English.pm index 959e5b6e1c..ba89b164b5 100644 --- a/lib/English.pm +++ b/lib/English.pm @@ -5,7 +5,6 @@ require Exporter; @EXPORT = qw( *ARG - $MAGIC $MATCH $PREMATCH $POSTMATCH @@ -58,7 +57,6 @@ require Exporter; # The ground of all being. - *MAGIC = \$_ ; *ARG = *_ ; # Matching. diff --git a/lib/FileHandle.pm b/lib/FileHandle.pm index b975c2b990..2452a15a1f 100644 --- a/lib/FileHandle.pm +++ b/lib/FileHandle.pm @@ -3,15 +3,32 @@ package FileHandle; BEGIN { require 5.000; require English; import English; + require Exporter; } -@ISA = (); + +@ISA = (Exporter); +@EXPORT = qw( + print + autoflush + output_field_separator + output_record_separator + input_record_separator + input_line_number + format_page_number + format_lines_per_page + format_lines_left + format_name + format_top_name + format_line_break_characters + format_formfeed +); sub print { local($this) = shift; print $this @_; } -sub output_autoflush { +sub autoflush { local($old) = select($_[0]); local($prev) = $OUTPUT_AUTOFLUSH; $OUTPUT_AUTOFLUSH = @_ > 1 ? $_[1] : 1; diff --git a/lib/POSIX.pm b/lib/POSIX.pm index bf5d35568c..4d08f25e5c 100644 --- a/lib/POSIX.pm +++ b/lib/POSIX.pm @@ -52,7 +52,7 @@ $H{limits_h} = [qw( ARG_MAX CHAR_BIT CHAR_MAX CHAR_MIN CHILD_MAX _POSIX_STREADM_MAX _POSIX_TZNAME_MAX)]; $H{locale_h} = [qw(LC_ALL LC_COLLATE LC_CTYPE LC_MONETARY LC_NUMERIC - LC_TIME NULL localeconf setlocale)]; + LC_TIME NULL localeconv setlocale)]; $H{math_h} = [qw(HUGE_VAL acos asin atan2 atan ceil cos cosh exp fabs floor fmod frexp ldexp log10 log modf pow sin sinh @@ -66,8 +66,7 @@ $H{signal_h} = [qw(SA_NOCLDSTOP SIGABRT SIGALRM SIGCHLD SIGCONT SIGFPE SIGHUP SIGILL SIGINT SIGKILL SIGPIPE SIGQUIT SIGSEGV SIGSTOP SIGTERM SIGTSTP SIGTTIN SIGTTOU SIGUSR1 SIGUSR2 SIG_BLOCK SIG_DFL SIG_ERR SIG_IGN SIG_SETMASK SIG_UNBLOCK - kill raise sigaction sigaddset sigdelset sigemptyset - sigfillset sigismember signal sigpending sigprocmask + kill raise sigaction signal sigpending sigprocmask sigsuspend)]; $H{stdarg_h} = [qw()]; @@ -170,15 +169,943 @@ sub import { Exporter::import($this,@list); } +sub AUTOLOAD { + if ($AUTOLOAD =~ /::(_?[a-z])/) { + $AutoLoader::AUTOLOAD = $AUTOLOAD; + goto &AutoLoader::AUTOLOAD + } + local $constname = $AUTOLOAD; + $constname =~ s/.*:://; + $val = constant($constname, $_[0]); + if ($! != 0) { + ($pack,$file,$line) = caller; + if ($! =~ /Invalid/) { + die "$constname is not a valid POSIX macro at $file line $line.\n"; + } + else { + die "Your vendor has not defined POSIX macro $constname, used at $file line $line.\n"; + } + } + eval "sub $AUTOLOAD { $val }"; + goto &$AUTOLOAD; +} + bootstrap POSIX; -sub usage { local ($mess, $pack, $file, $line) = @_; - die "Usage: POSIX::$_[0] at $file line $line\n"; +sub usage { + local ($mess, $pack, $file, $line) = @_; + die "Usage: POSIX::$mess at $file line $line\n"; +} + +sub unimpl { + local ($mess, $pack, $file, $line) = @_; + $mess =~ s/xxx//; + die "Unimplemented: POSIX::$mess at $file line $line\n"; +} + +$gensym = "SYM000"; + +sub gensym { + $gensym++; +} + +sub ungensym { + delete $_POSIX{$_[0]}; } 1; +package POSIX::SigAction; + +sub new { + bless {HANDLER => $_[1], MASK => $_[2], FLAGS => $_[3]}; +} __END__ + +sub assert { + usage "assert(expr)", caller if @_ != 1; + if (!$_[0]) { + local ($pack,$file,$line) = caller; + die "Assertion failed at $file line $line\n"; + } +} + +sub tolower { + usage "tolower(string)", caller if @_ != 1; + lc($_[0]); +} + +sub toupper { + usage "toupper(string)", caller if @_ != 1; + uc($_[0]); +} + +sub closedir { + usage "closedir(dirhandle)", caller if @_ != 1; + closedir($_[0]); + ungensym($_[0]); +} + +sub opendir { + usage "opendir(directory)", caller if @_ != 1; + local($dirhandle) = &gensym; + opendir($dirhandle, $_[0]) + ? $dirhandle + : (ungensym($dirhandle), undef); +} + +sub readdir { + usage "readdir(dirhandle)", caller if @_ != 1; + readdir($_[0]); +} + +sub rewinddir { + usage "rewinddir(dirhandle)", caller if @_ != 1; + rewinddir($_[0]); +} + +sub errno { + usage "errno()", caller if @_ != 0; + $! + 0; +} + +sub creat { + usage "creat(filename, mode)", caller if @_ != 2; + &open($_[0], &O_WRONLY | &O_CREAT | &O_TRUNC, $_[2]); +} + +sub fcntl { + usage "fcntl(filehandle, cmd, arg)", caller if @_ != 3; + fcntl($_[0], $_[1], $_[2]); +} + +sub getgrgid { + usage "getgrgid(gid)", caller if @_ != 1; + getgrgid($_[0]); +} + +sub getgrnam { + usage "getgrnam(name)", caller if @_ != 1; + getgrnam($_[0]); +} + +sub atan2 { + usage "atan2(x,y)", caller if @_ != 2; + atan2($_[0], $_[1]); +} + +sub cos { + usage "cos(x)", caller if @_ != 1; + cos($_[0]); +} + +sub exp { + usage "exp(x)", caller if @_ != 1; + exp($_[0]); +} + +sub fabs { + usage "fabs(x)", caller if @_ != 1; + abs($_[0]); +} + +sub log { + usage "log(x)", caller if @_ != 1; + log($_[0]); +} + +sub pow { + usage "pow(x,exponent)", caller if @_ != 2; + $_[0] ** $_[1]; +} + +sub sin { + usage "sin(x)", caller if @_ != 1; + sin($_[0]); +} + +sub sqrt { + usage "sqrt(x)", caller if @_ != 1; + sqrt($_[0]); +} + +sub tan { + usage "tan(x)", caller if @_ != 1; + tan($_[0]); +} + +sub getpwnam { + usage "getpwnam(name)", caller if @_ != 1; + getpwnam($_[0]); +} + +sub getpwuid { + usage "getpwuid(uid)", caller if @_ != 1; + getpwuid($_[0]); +} + +sub longjmp { + unimpl "longjmp() is C-specific: use die instead", caller; +} + +sub setjmp { + unimpl "setjmp() is C-specific: use eval {} instead", caller; +} + +sub siglongjmp { + unimpl "siglongjmp() is C-specific: use die instead", caller; +} + +sub sigsetjmp { + unimpl "sigsetjmp() is C-specific: use eval {} instead", caller; +} + +sub kill { + usage "kill(pid, sig)", caller if @_ != 2; + kill $_[1], $_[0]; +} + +sub raise { + usage "raise(sig)", caller if @_ != 1; + kill $$, $_[0]; # Is this good enough? +} + +sub offsetof { + unimpl "offsetof() is C-specific, stopped", caller; +} + +sub clearerr { + usage "clearerr(filehandle)", caller if @_ != 1; + seek($_[0], 0, 1); +} + +sub fclose { + unimpl "fclose() is C-specific--use close instead", caller; +} + +sub feof { + usage "feof(filehandle)", caller if @_ != 1; + eof($_[0]); +} + +sub fgetc { + usage "fgetc(filehandle)", caller if @_ != 1; + getc($_[0]); +} + +sub fgetpos { + unimpl "fgetpos(xxx)", caller if @_ != 123; + fgetpos($_[0]); +} + +sub fgets { + usage "fgets(filehandle)", caller if @_ != 1; + local($handle) = @_; + scalar <$handle>; +} + +sub fileno { + usage "fileno(filehandle)", caller if @_ != 1; + fileno($_[0]); +} + +sub fopen { + unimpl "fopen() is C-specific--use open instead", caller; +} + +sub fprintf { + unimpl "fprintf() is C-specific--use printf instead", caller; +} + +sub fputc { + unimpl "fputc() is C-specific--use print instead", caller; +} + +sub fputs { + unimpl "fputs() is C-specific--use print instead", caller; + usage "fputs(string, handle)", caller if @_ != 2; + local($handle) = pop; + print $handle @_; +} + +sub fread { + unimpl "fread() is C-specific--use read instead", caller; + unimpl "fread(xxx)", caller if @_ != 123; + fread($_[0]); +} + +sub freopen { + unimpl "freopen() is C-specific--use open instead", caller; + unimpl "freopen(xxx)", caller if @_ != 123; + freopen($_[0]); +} + +sub fscanf { + unimpl "fscanf() is C-specific--use <> and regular expressions instead", caller; + unimpl "fscanf(xxx)", caller if @_ != 123; + fscanf($_[0]); +} + +sub fseek { + unimpl "fseek() is C-specific--use seek instead", caller; + unimpl "fseek(xxx)", caller if @_ != 123; + fseek($_[0]); +} + +sub fsetpos { + unimpl "fsetpos() is C-specific--use seek instead", caller; + unimpl "fsetpos(xxx)", caller if @_ != 123; + fsetpos($_[0]); +} + +sub ftell { + unimpl "ftell() is C-specific--use tell instead", caller; + unimpl "ftell(xxx)", caller if @_ != 123; + ftell($_[0]); +} + +sub fwrite { + unimpl "fwrite() is C-specific--use print instead", caller; + unimpl "fwrite(xxx)", caller if @_ != 123; + fwrite($_[0]); +} + +sub getc { + usage "getc(handle)", caller if @_ != 1; + getc($_[0]); +} + +sub getchar { + usage "getchar()", caller if @_ != 0; + getc(STDIN); +} + +sub gets { + usage "gets(handle)", caller if @_ != 1; + local($handle) = shift; + scalar <$handle>; +} + +sub perror { + unimpl "perror() is C-specific--print $! instead", caller; + unimpl "perror(xxx)", caller if @_ != 123; + perror($_[0]); +} + +sub printf { + usage "printf(pattern, args...)", caller if @_ < 1; + printf STDOUT @_; +} + +sub putc { + unimpl "putc() is C-specific--use print instead", caller; + unimpl "putc(xxx)", caller if @_ != 123; + putc($_[0]); +} + +sub putchar { + unimpl "putchar() is C-specific--use print instead", caller; + unimpl "putchar(xxx)", caller if @_ != 123; + putchar($_[0]); +} + +sub puts { + unimpl "puts() is C-specific--use print instead", caller; + unimpl "puts(xxx)", caller if @_ != 123; + puts($_[0]); +} + +sub remove { + unimpl "remove(xxx)", caller if @_ != 123; + remove($_[0]); +} + +sub rename { + unimpl "rename(xxx)", caller if @_ != 123; + rename($_[0]); +} + +sub rewind { + unimpl "rewind(xxx)", caller if @_ != 123; + rewind($_[0]); +} + +sub scanf { + unimpl "scanf(xxx)", caller if @_ != 123; + scanf($_[0]); +} + +sub setbuf { + unimpl "setbuf(xxx)", caller if @_ != 123; + setbuf($_[0]); +} + +sub setvbuf { + unimpl "setvbuf(xxx)", caller if @_ != 123; + setvbuf($_[0]); +} + +sub sprintf { + unimpl "sprintf(xxx)", caller if @_ != 123; + sprintf($_[0]); +} + +sub sscanf { + unimpl "sscanf(xxx)", caller if @_ != 123; + sscanf($_[0]); +} + +sub tmpfile { + unimpl "tmpfile(xxx)", caller if @_ != 123; + tmpfile($_[0]); +} + +sub tmpnam { + unimpl "tmpnam(xxx)", caller if @_ != 123; + tmpnam($_[0]); +} + +sub ungetc { + unimpl "ungetc(xxx)", caller if @_ != 123; + ungetc($_[0]); +} + +sub vfprintf { + unimpl "vfprintf(xxx)", caller if @_ != 123; + vfprintf($_[0]); +} + +sub vprintf { + unimpl "vprintf(xxx)", caller if @_ != 123; + vprintf($_[0]); +} + +sub vsprintf { + unimpl "vsprintf(xxx)", caller if @_ != 123; + vsprintf($_[0]); +} + +sub abort { + unimpl "abort(xxx)", caller if @_ != 123; + abort($_[0]); +} + +sub abs { + usage "abs(x)", caller if @_ != 1; + abs($_[0]); +} + +sub atexit { + unimpl "atexit() is C-specific: use END {} instead", caller; +} + +sub atof { + unimpl "atof() is C-specific, stopped", caller; +} + +sub atoi { + unimpl "atoi() is C-specific, stopped", caller; +} + +sub atol { + unimpl "atol() is C-specific, stopped", caller; +} + +sub bsearch { + unimpl "bsearch(xxx)", caller if @_ != 123; + bsearch($_[0]); +} + +sub calloc { + unimpl "calloc(xxx)", caller if @_ != 123; + calloc($_[0]); +} + +sub div { + unimpl "div(xxx)", caller if @_ != 123; + div($_[0]); +} + +sub exit { + unimpl "exit(xxx)", caller if @_ != 123; + exit($_[0]); +} + +sub free { + unimpl "free(xxx)", caller if @_ != 123; + free($_[0]); +} + +sub getenv { + unimpl "getenv(xxx)", caller if @_ != 123; + getenv($_[0]); +} + +sub labs { + unimpl "labs(xxx)", caller if @_ != 123; + labs($_[0]); +} + +sub ldiv { + unimpl "ldiv(xxx)", caller if @_ != 123; + ldiv($_[0]); +} + +sub malloc { + unimpl "malloc(xxx)", caller if @_ != 123; + malloc($_[0]); +} + +sub mblen { + unimpl "mblen(xxx)", caller if @_ != 123; + mblen($_[0]); +} + +sub mbstowcs { + unimpl "mbstowcs(xxx)", caller if @_ != 123; + mbstowcs($_[0]); +} + +sub mbtowc { + unimpl "mbtowc(xxx)", caller if @_ != 123; + mbtowc($_[0]); +} + +sub qsort { + unimpl "qsort(xxx)", caller if @_ != 123; + qsort($_[0]); +} + +sub rand { + unimpl "rand(xxx)", caller if @_ != 123; + rand($_[0]); +} + +sub realloc { + unimpl "realloc(xxx)", caller if @_ != 123; + realloc($_[0]); +} + +sub srand { + unimpl "srand(xxx)", caller if @_ != 123; + srand($_[0]); +} + +sub strtod { + unimpl "strtod(xxx)", caller if @_ != 123; + strtod($_[0]); +} + +sub strtol { + unimpl "strtol(xxx)", caller if @_ != 123; + strtol($_[0]); +} + +sub stroul { + unimpl "stroul(xxx)", caller if @_ != 123; + stroul($_[0]); +} + +sub system { + unimpl "system(xxx)", caller if @_ != 123; + system($_[0]); +} + +sub wcstombs { + unimpl "wcstombs(xxx)", caller if @_ != 123; + wcstombs($_[0]); +} + +sub wctomb { + unimpl "wctomb(xxx)", caller if @_ != 123; + wctomb($_[0]); +} + +sub memchr { + unimpl "memchr(xxx)", caller if @_ != 123; + memchr($_[0]); +} + +sub memcmp { + unimpl "memcmp(xxx)", caller if @_ != 123; + memcmp($_[0]); +} + +sub memcpy { + unimpl "memcpy(xxx)", caller if @_ != 123; + memcpy($_[0]); +} + +sub memmove { + unimpl "memmove(xxx)", caller if @_ != 123; + memmove($_[0]); +} + +sub memset { + unimpl "memset(xxx)", caller if @_ != 123; + memset($_[0]); +} + +sub strcat { + unimpl "strcat(xxx)", caller if @_ != 123; + strcat($_[0]); +} + +sub strchr { + unimpl "strchr(xxx)", caller if @_ != 123; + strchr($_[0]); +} + +sub strcmp { + unimpl "strcmp(xxx)", caller if @_ != 123; + strcmp($_[0]); +} + +sub strcoll { + unimpl "strcoll(xxx)", caller if @_ != 123; + strcoll($_[0]); +} + +sub strcpy { + unimpl "strcpy(xxx)", caller if @_ != 123; + strcpy($_[0]); +} + +sub strcspn { + unimpl "strcspn(xxx)", caller if @_ != 123; + strcspn($_[0]); +} + +sub strerror { + unimpl "strerror(xxx)", caller if @_ != 123; + strerror($_[0]); +} + +sub strlen { + unimpl "strlen(xxx)", caller if @_ != 123; + strlen($_[0]); +} + +sub strncat { + unimpl "strncat(xxx)", caller if @_ != 123; + strncat($_[0]); +} + +sub strncmp { + unimpl "strncmp(xxx)", caller if @_ != 123; + strncmp($_[0]); +} + +sub strncpy { + unimpl "strncpy(xxx)", caller if @_ != 123; + strncpy($_[0]); +} + +sub strpbrk { + unimpl "strpbrk(xxx)", caller if @_ != 123; + strpbrk($_[0]); +} + +sub strrchr { + unimpl "strrchr(xxx)", caller if @_ != 123; + strrchr($_[0]); +} + +sub strspn { + unimpl "strspn(xxx)", caller if @_ != 123; + strspn($_[0]); +} + +sub strstr { + unimpl "strstr(xxx)", caller if @_ != 123; + strstr($_[0]); +} + +sub strtok { + unimpl "strtok(xxx)", caller if @_ != 123; + strtok($_[0]); +} + +sub strxfrm { + unimpl "strxfrm(xxx)", caller if @_ != 123; + strxfrm($_[0]); +} + +sub chmod { + unimpl "chmod(xxx)", caller if @_ != 123; + chmod($_[0]); +} + +sub fstat { + unimpl "fstat(xxx)", caller if @_ != 123; + fstat($_[0]); +} + +sub mkdir { + unimpl "mkdir(xxx)", caller if @_ != 123; + mkdir($_[0]); +} + +sub mkfifo { + unimpl "mkfifo(xxx)", caller if @_ != 123; + mkfifo($_[0]); +} + +sub stat { + unimpl "stat(xxx)", caller if @_ != 123; + stat($_[0]); +} + +sub umask { + unimpl "umask(xxx)", caller if @_ != 123; + umask($_[0]); +} + +sub times { + unimpl "times(xxx)", caller if @_ != 123; + times($_[0]); +} + +sub wait { + unimpl "wait(xxx)", caller if @_ != 123; + wait($_[0]); +} + +sub waitpid { + unimpl "waitpid(xxx)", caller if @_ != 123; + waitpid($_[0]); +} + +sub cfgetispeed { + unimpl "cfgetispeed(xxx)", caller if @_ != 123; + cfgetispeed($_[0]); +} + +sub cfgetospeed { + unimpl "cfgetospeed(xxx)", caller if @_ != 123; + cfgetospeed($_[0]); +} + +sub cfsetispeed { + unimpl "cfsetispeed(xxx)", caller if @_ != 123; + cfsetispeed($_[0]); +} + +sub cfsetospeed { + unimpl "cfsetospeed(xxx)", caller if @_ != 123; + cfsetospeed($_[0]); +} + +sub tcdrain { + unimpl "tcdrain(xxx)", caller if @_ != 123; + tcdrain($_[0]); +} + +sub tcflow { + unimpl "tcflow(xxx)", caller if @_ != 123; + tcflow($_[0]); +} + +sub tcflush { + unimpl "tcflush(xxx)", caller if @_ != 123; + tcflush($_[0]); +} + +sub tcgetattr { + unimpl "tcgetattr(xxx)", caller if @_ != 123; + tcgetattr($_[0]); +} + +sub tcsendbreak { + unimpl "tcsendbreak(xxx)", caller if @_ != 123; + tcsendbreak($_[0]); +} + +sub tcsetattr { + unimpl "tcsetattr(xxx)", caller if @_ != 123; + tcsetattr($_[0]); +} + +sub asctime { + unimpl "asctime(xxx)", caller if @_ != 123; + asctime($_[0]); +} + +sub clock { + unimpl "clock(xxx)", caller if @_ != 123; + clock($_[0]); +} + +sub ctime { + unimpl "ctime(xxx)", caller if @_ != 123; + ctime($_[0]); +} + +sub difftime { + unimpl "difftime(xxx)", caller if @_ != 123; + difftime($_[0]); +} + +sub gmtime { + unimpl "gmtime(xxx)", caller if @_ != 123; + gmtime($_[0]); +} + +sub localtime { + unimpl "localtime(xxx)", caller if @_ != 123; + localtime($_[0]); +} + +sub mktime { + unimpl "mktime(xxx)", caller if @_ != 123; + mktime($_[0]); +} + +sub strftime { + unimpl "strftime(xxx)", caller if @_ != 123; + strftime($_[0]); +} + +sub time { + unimpl "time(xxx)", caller if @_ != 123; + time($_[0]); +} + +sub tzset { + unimpl "tzset(xxx)", caller if @_ != 123; + tzset($_[0]); +} + +sub tzname { + unimpl "tzname(xxx)", caller if @_ != 123; + tzname($_[0]); +} + +sub _exit { + unimpl "_exit(xxx)", caller if @_ != 123; + _exit($_[0]); +} + +sub access { + unimpl "access(xxx)", caller if @_ != 123; + access($_[0]); +} + +sub alarm { + unimpl "alarm(xxx)", caller if @_ != 123; + alarm($_[0]); +} + +sub chdir { + unimpl "chdir(xxx)", caller if @_ != 123; + chdir($_[0]); +} + +sub chown { + unimpl "chown(xxx)", caller if @_ != 123; + chown($_[0]); +} + +sub close { + unimpl "close(xxx)", caller if @_ != 123; + close($_[0]); +} + +sub ctermid { + unimpl "ctermid(xxx)", caller if @_ != 123; + ctermid($_[0]); +} + +sub cuserid { + unimpl "cuserid(xxx)", caller if @_ != 123; + cuserid($_[0]); +} + +sub dup2 { + unimpl "dup2(xxx)", caller if @_ != 123; + dup2($_[0]); +} + +sub dup { + unimpl "dup(xxx)", caller if @_ != 123; + dup($_[0]); +} + +sub execl { + unimpl "execl(xxx)", caller if @_ != 123; + execl($_[0]); +} + +sub execle { + unimpl "execle(xxx)", caller if @_ != 123; + execle($_[0]); +} + +sub execlp { + unimpl "execlp(xxx)", caller if @_ != 123; + execlp($_[0]); +} + +sub execv { + unimpl "execv(xxx)", caller if @_ != 123; + execv($_[0]); +} + +sub execve { + unimpl "execve(xxx)", caller if @_ != 123; + execve($_[0]); +} + +sub execvp { + unimpl "execvp(xxx)", caller if @_ != 123; + execvp($_[0]); +} + +sub fork { + usage "fork()", caller if @_ != 0; + fork; +} + +sub fpathconf { + unimpl "fpathconf(xxx)", caller if @_ != 123; + fpathconf($_[0]); +} + +sub getcwd { + unimpl "getcwd(xxx)", caller if @_ != 123; + getcwd($_[0]); +} + +sub getegid { + unimpl "getegid(xxx)", caller if @_ != 123; + getegid($_[0]); +} + +sub geteuid { + unimpl "geteuid(xxx)", caller if @_ != 123; + geteuid($_[0]); +} + +sub getgid { + unimpl "getgid(xxx)", caller if @_ != 123; + getgid($_[0]); +} + +sub getgroups { + unimpl "getgroups(xxx)", caller if @_ != 123; + getgroups($_[0]); +} + +sub getlogin { + unimpl "getlogin(xxx)", caller if @_ != 123; + getlogin($_[0]); +} + +sub getpgrp { + unimpl "getpgrp(xxx)", caller if @_ != 123; + getpgrp($_[0]); +} + sub getpid { usage "getpid()", caller if @_ != 0; $$; @@ -189,12 +1116,108 @@ sub getppid { getppid; } -sub fork { - usage "fork()", caller if @_ != 0; - fork; +sub getuid { + unimpl "getuid(xxx)", caller if @_ != 123; + getuid($_[0]); } -sub kill { - usage "kill(pid, sig)", caller if @_ != 2; - kill $_[1], $_[0]; +sub isatty { + unimpl "isatty(xxx)", caller if @_ != 123; + isatty($_[0]); +} + +sub link { + unimpl "link(xxx)", caller if @_ != 123; + link($_[0]); +} + +sub lseek { + unimpl "lseek(xxx)", caller if @_ != 123; + lseek($_[0]); +} + +sub pathconf { + unimpl "pathconf(xxx)", caller if @_ != 123; + pathconf($_[0]); +} + +sub pause { + unimpl "pause(xxx)", caller if @_ != 123; + pause($_[0]); +} + +sub pipe { + unimpl "pipe(xxx)", caller if @_ != 123; + pipe($_[0]); +} + +sub read { + unimpl "read(xxx)", caller if @_ != 123; + read($_[0]); +} + +sub rmdir { + unimpl "rmdir(xxx)", caller if @_ != 123; + rmdir($_[0]); +} + +sub setgid { + unimpl "setgid(xxx)", caller if @_ != 123; + setgid($_[0]); +} + +sub setpgid { + unimpl "setpgid(xxx)", caller if @_ != 123; + setpgid($_[0]); +} + +sub setsid { + unimpl "setsid(xxx)", caller if @_ != 123; + setsid($_[0]); +} + +sub setuid { + unimpl "setuid(xxx)", caller if @_ != 123; + setuid($_[0]); +} + +sub sleep { + unimpl "sleep(xxx)", caller if @_ != 123; + sleep($_[0]); +} + +sub sysconf { + unimpl "sysconf(xxx)", caller if @_ != 123; + sysconf($_[0]); } + +sub tcgetpgrp { + unimpl "tcgetpgrp(xxx)", caller if @_ != 123; + tcgetpgrp($_[0]); +} + +sub tcsetpgrp { + unimpl "tcsetpgrp(xxx)", caller if @_ != 123; + tcsetpgrp($_[0]); +} + +sub ttyname { + unimpl "ttyname(xxx)", caller if @_ != 123; + ttyname($_[0]); +} + +sub unlink { + unimpl "unlink(xxx)", caller if @_ != 123; + unlink($_[0]); +} + +sub write { + unimpl "write(xxx)", caller if @_ != 123; + write($_[0]); +} + +sub utime { + unimpl "utime(xxx)", caller if @_ != 123; + utime($_[0]); +} + diff --git a/lib/auto/POSIX/_exit b/lib/auto/POSIX/_exit new file mode 100644 index 0000000000..a860527257 --- /dev/null +++ b/lib/auto/POSIX/_exit @@ -0,0 +1,9 @@ +package POSIX; + +sub _exit { + unimpl "_exit(xxx)", caller if @_ != 123; + _exit($_[0]); +} + + +1; diff --git a/lib/auto/README b/lib/auto/README new file mode 100644 index 0000000000..b217acc5cd --- /dev/null +++ b/lib/auto/README @@ -0,0 +1,2 @@ +Everything down here is derived from elsewhere. If you modify anything +down here it will someday be overwritten. diff --git a/lib/dotsh.pl.art b/lib/dotsh.pl.art new file mode 100644 index 0000000000..4f0f188e3c --- /dev/null +++ b/lib/dotsh.pl.art @@ -0,0 +1,154 @@ +Article 19995 of comp.lang.perl: +Newsgroups: comp.lang.perl +Path: netlabs!news.cerf.net!mvb.saic.com!MathWorks.Com!europa.eng.gtefsd.com!howland.reston.ans.net!news.ans.net!malgudi.oar.net!chemabs!skf26 +From: skf26@cas.org (Scott Frost) +Subject: HOW TO source shell scripts into Perl +Message-ID: <1994Mar21.191518.11636@chemabs.uucp> +Followup-To: scott.frost@cas.org +Keywords: Shell, Source, Dot +Sender: usenet@chemabs.uucp +Organization: Chemical Abstracts Service +Date: Mon, 21 Mar 1994 19:15:18 GMT +Lines: 139 + +A few days ago I posted a request for information on how to source +a shell script into a perl script. In general, the responses indicated that +it could not be done (although one came pretty close to the actual solution). + +A fellow staff member (who I was posting the request for) wasn't satisfied with +the response and came up with a way. + +Before I indicate how he solved the problem, let me suggest some alternative +methods of resolving this issue, + + 1. Hard code the environment variables directly in your PERL script. This + is easy but unreliable. System administrators could change the + production shell script environment variables and your PERL script would + be hosed. + + 2. Create a shell wrapper that dots the shell script into your current + environment and then invoke your perl script. This approach is easy + to do, fairly full proof, but an affront to serious PERL programmers + who believe PERL is God's gift to man (or at least Larry's :-) ). + +Chuck's solution involves running the script in the appropriate shell +environment, dumping the shell's environment variables to a file, and then +reading the environment variables into PERL's environment. + +It supports ksh, sh, csh, and zsh shells. It'll look at the first line of +the file to be executed to determine the shell to run it under, if not found, +it'll look at the SHELL environment variable. If the shell is not one of the +four listed, it'll warn you and attempt to run the shell script under /bin/sh. + + A typical usage might look like this, + #!/usr/bin/perl + + # Make sure dotsh.pl is placed in your /usr/perl/lib + require "dotsh.pl"; + + print "SHELL_ENV_VAR = $SHELL_ENV_VAR\n" ; + &dotsh('/tmp/foo') ; # script to run + print "SHELL_ENV_VAR = $SHELL_ENV_VAR\n" ; + + /tmp/foo looks like this: + #!/bin/ksh + export SHELL_ENV_VAR="hi mom" + +The actual dotsh.pl script follows (BTW, this is now public domain): +# +# @(#)dotsh.pl 03/19/94 +# +# Author: Charles Collins +# +# Description: +# This routine takes a shell script and 'dots' it into the current perl +# environment. This makes it possible to use existing system scripts +# to alter environment variables on the fly. +# +# Usage: +# &dotsh ('ShellScript', 'DependentVariable(s)'); +# +# where +# +# 'ShellScript' is the full name of the shell script to be dotted +# +# 'DependentVariable(s)' is an optional list of shell variables in the +# form VARIABLE=VALUE,VARIABLE=VALUE,... that 'ShellScript' is +# dependent upon. These variables MUST be defined using shell syntax. +# +# Example: +# &dotsh ('/tmp/foo', 'arg1'); +# &dotsh ('/tmp/foo'); +# &dotsh ('/tmp/foo arg1 ... argN'); +# +sub dotsh { + local(@sh) = @_; + local($tmp,$key,$shell,*dotsh,$command,$args,$vars) = ''; + $dotsh = shift(@sh); + @dotsh = split (/\s/, $dotsh); + $command = shift (@dotsh); + $args = join (" ", @dotsh); + $vars = join ("\n", @sh); + open (_SH_ENV, "$command") || die "Could not open $dotsh!\n"; + chop($_ = <_SH_ENV>); + $shell = "$1 -c" if ($_ =~ /^\#\!\s*(\S+(\/sh|\/ksh|\/zsh|\/csh))\s*$/); + close (_SH_ENV); + if (!$shell) { + if ($ENV{'SHELL'} =~ /\/sh$|\/ksh$|\/zsh$|\/csh$/) { + $shell = "$ENV{'SHELL'} -c"; + } else { + print "SHELL not recognized!\nUsing /bin/sh...\n"; + $shell = "/bin/sh -c"; + } + } + if (length($vars) > 0) { + system "$shell \"$vars;. $command $args; set > /tmp/_sh_env$$\""; + } else { + system "$shell \". $command $args; set > /tmp/_sh_env$$\""; + } + + open (_SH_ENV, "/tmp/_sh_env$$") || die "Could not open /tmp/_sh_env$$!\n"; + while (<_SH_ENV>) { + chop; + /=/; + $ENV{$`} = $'; + } + close (_SH_ENV); + system "rm -f /tmp/_sh_env$$"; + + foreach $key (keys(ENV)) { + $tmp .= "\$$key = \$ENV{'$key'};" if $key =~ /^[A-Za-z]\w*$/; + } + eval $tmp; +} +1; + + + + + + + + + + + + + + + + + + + + + + + + + + +-- +Scott K. Frost INET: scott.frost@cas.org + + diff --git a/lib/quotewords.pl.art b/lib/quotewords.pl.art new file mode 100644 index 0000000000..65e9f0abc8 --- /dev/null +++ b/lib/quotewords.pl.art @@ -0,0 +1,146 @@ +Article 20075 of comp.lang.perl: +Newsgroups: comp.lang.perl +Path: netlabs!news.cerf.net!ihnp4.ucsd.edu!swrinde!sgiblab!rpal.rockwell.com!imagen!pomeranz +From: pomeranz@imagen.com (Hal Pomeranz) +Subject: quotewords.pl [REVISED] +Message-ID: <1994Mar23.071634.23171@aqm.com> +Sender: usenet@aqm.com +Nntp-Posting-Host: imagen +Organization: QMS Inc., Santa Clara +Date: Wed, 23 Mar 1994 07:16:34 GMT +Lines: 132 + + +ARRGH! The version I posted earlier tonight contained an error, so +I've sent out a cancel to chase it down and kill it. Please use this +version dated "23 March 1994". + +quotewords.pl is a generic replacement for shellwords.pl. +"ewords() allows you to specify a delimiter, which may be a +regular expression, and returns a list of words broken on that +delimiter ignoring any instances of the delimiter which may appear +within a quoted string. There's a boolean flag to tell the function +whether or not you want it to strip quotes and backslashes or retain +them. + +I've also included a revised version of &shellwords() (written in +terms of "ewords() of course) which is 99% the same as the +original version. The only difference is that the new version will +not default to using $_ if no arguments are supplied. + +Share and enjoy... + +============================================================================== + Hal Pomeranz pomeranz@sclara.qms.com pomeranz@cs.swarthmore.edu +System/Network Manager "All I can say is that my life is pretty plain. + QMS Santa Clara I like watchin' the puddles gather rain." Blind Melon +============================================================================== + +# quotewords.pl +# +# Usage: +# require 'quotes.pl'; +# @words = "ewords($delim, $keep, @lines); +# @words = &shellwords(@lines); + +# Hal Pomeranz (pomeranz@netcom.com), 23 March 1994 +# Permission to use and distribute under the same terms as Perl. +# No warranty expressed or implied. + +# Basically an update and generalization of the old shellwords.pl. +# Much code shamelessly stolen from the old version (author unknown). +# +# "ewords() accepts a delimiter (which can be a regular expression) +# and a list of lines and then breaks those lines up into a list of +# words ignoring delimiters that appear inside quotes. +# +# The $keep argument is a boolean flag. If true, the quotes are kept +# with each word, otherwise quotes are stripped in the splitting process. +# $keep also defines whether unprotected backslashes are retained. +# +# A &shellwords() replacement is included to demonstrate the new package. +# This version differs from the original in that it will _NOT_ default +# to using $_ if no arguments are given. I personally find the old behavior +# to be a mis-feature. + +package quotewords; + +sub main'shellwords { + local(@lines) = @_; + $lines[$#lines] =~ s/\s+$//; + &main'quotewords('\s+', 0, @lines); +} + + +# "ewords() works by simply jamming all of @lines into a single +# string in $_ and then pulling off words a bit at a time until $_ +# is exhausted. +# +# The inner "for" loop builds up each word (or $field) one $snippet +# at a time. A $snippet is a quoted string, a backslashed character, +# or an unquoted string. We fall out of the "for" loop when we reach +# the end of $_ or when we hit a delimiter. Falling out of the "for" +# loop, we push the $field we've been building up onto the list of +# @words we'll be returning, and then loop back and pull another word +# off of $_. +# +# The first two cases inside the "for" loop deal with quoted strings. +# The first case matches a double quoted string, removes it from $_, +# and assigns the double quoted string to $snippet in the body of the +# conditional. The second case handles single quoted strings. In +# the third case we've found a quote at the current beginning of $_, +# but it didn't match the quoted string regexps in the first two cases, +# so it must be an unbalanced quote and we die with an error (which can +# be caught by eval()). +# +# The next case handles backslashed characters, and the next case is the +# exit case on reaching the end of the string or finding a delimiter. +# +# Otherwise, we've found an unquoted thing and we pull of characters one +# at a time until we reach something that could start another $snippet-- +# a quote of some sort, a backslash, or the delimiter. This one character +# at a time behavior was necessary if the delimiter was going to be a +# regexp (love to hear it if you can figure out a better way). + +sub main'quotewords { + local($delim, $keep, @lines) = @_; + local(@words,$snippet,$field,$_); + + $_ = join('', @lines); + while ($_) { + $field = ''; + for (;;) { + $snippet = ''; + if (s/^"(([^"\\]|\\[\\"])*)"//) { + $snippet = $1; + $snippet = "\"$snippet\"" if ($keep); + } + elsif (s/^'(([^'\\]|\\[\\'])*)'//) { + $snippet = $1; + $snippet = "'$snippet'" if ($keep); + } + elsif (/^["']/) { + die "Unmatched quote\n"; + } + elsif (s/^\\(.)//) { + $snippet = $1; + $snippet = "\\$snippet" if ($keep); + } + elsif (!$_ || s/^$delim//) { + last; + } + else { + while ($_ && !(/^$delim/ || /^['"\\]/)) { + $snippet .= substr($_, 0, 1); + substr($_, 0, 1) = ''; + } + } + $field .= $snippet; + } + push(@words, $field); + } + @words; +} +1; + + diff --git a/lib/soundex.pl.art b/lib/soundex.pl.art new file mode 100644 index 0000000000..1cc0b9e53c --- /dev/null +++ b/lib/soundex.pl.art @@ -0,0 +1,285 @@ +Article 20106 of comp.lang.perl: +Path: netlabs!news.cerf.net!ihnp4.ucsd.edu!mvb.saic.com!MathWorks.Com!noc.near.net!newshost.meiko.com!not-for-mail +From: mike@meiko.com (Mike Stok) +Newsgroups: comp.lang.perl +Subject: Soundex (again :-) +Date: 23 Mar 1994 19:44:35 -0500 +Organization: Meiko Scientific, Inc., MA +Lines: 272 +Message-ID: <2mqnpj$qk4@hibbert.meiko.com> +NNTP-Posting-Host: hibbert.meiko.com + +Thanks to Rich Pinder for finding a little bug in my +soundex code I posted a while back. This showed up when he compared it +with the output from Oracle's soundex function, and were caused by leading +characters which were different but shared the same soundex code. + +Here's a fixed shar file... + +Mike + +#!/bin/sh +# This is a shell archive (produced by shar 3.49) +# To extract the files from this archive, save it to a file, remove +# everything above the "!/bin/sh" line above, and type "sh file_name". +# +# made 03/24/1994 00:35 UTC by Mike.Stok@meiko.concord.ma.us +# Source directory /tmp_mnt/develop/sw/misc/mike/soundex +# +# existing files will NOT be overwritten unless -c is specified +# +# This shar contains: +# length mode name +# ------ ---------- ------------------------------------------ +# 1677 -r--r--r-- soundex.pl +# 2408 -r-xr-xr-x soundex.t +# +# ============= soundex.pl ============== +if test -f 'soundex.pl' -a X"$1" != X"-c"; then + echo 'x - skipping soundex.pl (File already exists)' +else +echo 'x - extracting soundex.pl (Text)' +sed 's/^X//' << 'SHAR_EOF' > 'soundex.pl' && +package soundex; +X +;# $Id: soundex.pl,v 1.2 1994/03/24 00:30:27 mike Exp $ +;# +;# Implementation of soundex algorithm as described by Knuth in volume +;# 3 of The Art of Computer Programming, with ideas stolen from Ian +;# Phillips . +;# +;# Mike Stok , 2 March 1994. +;# +;# Knuth's test cases are: +;# +;# Euler, Ellery -> E460 +;# Gauss, Ghosh -> G200 +;# Hilbert, Heilbronn -> H416 +;# Knuth, Kant -> K530 +;# Lloyd, Ladd -> L300 +;# Lukasiewicz, Lissajous -> L222 +;# +;# $Log: soundex.pl,v $ +;# Revision 1.2 1994/03/24 00:30:27 mike +;# Subtle bug (any excuse :-) spotted by Rich Pinder +;# in the way I handles leasing characters which were different but had +;# the same soundex code. This showed up comparing it with Oracle's +;# soundex output. +;# +;# Revision 1.1 1994/03/02 13:01:30 mike +;# Initial revision +;# +;# +;############################################################################## +X +;# $soundex'noCode is used to indicate a string doesn't have a soundex +;# code, I like undef other people may want to set it to 'Z000'. +X +$noCode = undef; +X +;# main'soundex +;# +;# usage: +;# +;# @codes = &main'soundex (@wordList); +;# $code = &main'soundex ($word); +;# +;# This strenuously avoids $[ +X +sub main'soundex +{ +X local (@s, $f, $fc, $_) = @_; +X +X foreach (@s) +X { +X tr/a-z/A-Z/; +X tr/A-Z//cd; +X +X if ($_ eq '') +X { +X $_ = $noCode; +X } +X else +X { +X ($f) = /^(.)/; +X tr/AEHIOUWYBFPVCGJKQSXZDTLMNR/00000000111122222222334556/; +X ($fc) = /^(.)/; +X s/^$fc+//; +X tr///cs; +X tr/0//d; +X $_ = $f . $_ . '000'; +X s/^(.{4}).*/$1/; +X } +X } +X +X wantarray ? @s : shift @s; +} +X +1; +SHAR_EOF +chmod 0444 soundex.pl || +echo 'restore of soundex.pl failed' +Wc_c="`wc -c < 'soundex.pl'`" +test 1677 -eq "$Wc_c" || + echo 'soundex.pl: original size 1677, current size' "$Wc_c" +fi +# ============= soundex.t ============== +if test -f 'soundex.t' -a X"$1" != X"-c"; then + echo 'x - skipping soundex.t (File already exists)' +else +echo 'x - extracting soundex.t (Text)' +sed 's/^X//' << 'SHAR_EOF' > 'soundex.t' && +#!./perl +;# +;# $Id: soundex.t,v 1.2 1994/03/24 00:30:27 mike Exp $ +;# +;# test module for soundex.pl +;# +;# $Log: soundex.t,v $ +;# Revision 1.2 1994/03/24 00:30:27 mike +;# Subtle bug (any excuse :-) spotted by Rich Pinder +;# in the way I handles leasing characters which were different but had +;# the same soundex code. This showed up comparing it with Oracle's +;# soundex output. +;# +;# Revision 1.1 1994/03/02 13:03:02 mike +;# Initial revision +;# +;# +X +require '../lib/soundex.pl'; +X +$test = 0; +print "1..13\n"; +X +while () +{ +X chop; +X next if /^\s*;?#/; +X next if /^\s*$/; +X +X ++$test; +X $bad = 0; +X +X if (/^eval\s+/) +X { +X ($try = $_) =~ s/^eval\s+//; +X +X eval ($try); +X if ($@) +X { +X $bad++; +X print "not ok $test\n"; +X print "# eval '$try' returned $@"; +X } +X } +X elsif (/^\(/) +X { +X ($in, $out) = split (':'); +X +X $try = "\@expect = $out; \@got = &soundex $in;"; +X eval ($try); +X +X if (@expect != @got) +X { +X $bad++; +X print "not ok $test\n"; +X print "# expected ", scalar @expect, " results, got ", scalar @got, "\n"; +X print "# expected (", join (', ', @expect), +X ") got (", join (', ', @got), ")\n"; +X } +X else +X { +X while (@got) +X { +X $expect = shift @expect; +X $got = shift @got; +X +X if ($expect ne $got) +X { +X $bad++; +X print "not ok $test\n"; +X print "# expected $expect, got $got\n"; +X } +X } +X } +X } +X else +X { +X ($in, $out) = split (':'); +X +X $try = "\$expect = $out; \$got = &soundex ($in);"; +X eval ($try); +X +X if ($expect ne $got) +X { +X $bad++; +X print "not ok $test\n"; +X print "# expected $expect, got $got\n"; +X } +X } +X +X print "ok $test\n" unless $bad; +} +X +__END__ +# +# 1..6 +# +# Knuth's test cases, scalar in, scalar out +# +'Euler':'E460' +'Gauss':'G200' +'Hilbert':'H416' +'Knuth':'K530' +'Lloyd':'L300' +'Lukasiewicz':'L222' +# +# 7..8 +# +# check default bad code +# +'2 + 2 = 4':undef +undef:undef +# +# 9 +# +# check array in, array out +# +('Ellery', 'Ghosh', 'Heilbronn', 'Kant', 'Ladd', 'Lissajous'):('E460', 'G200', 'H416', 'K530', 'L300', 'L222') +# +# 10 +# +# check array with explicit undef +# +('Mike', undef, 'Stok'):('M200', undef, 'S320') +# +# 11..12 +# +# check setting $soundex'noCode +# +eval $soundex'noCode = 'Z000'; +('Mike', undef, 'Stok'):('M200', 'Z000', 'S320') +# +# 13 +# +# a subtle difference between me & oracle, spotted by Rich Pinder +# +# +CZARKOWSKA:C622 +SHAR_EOF +chmod 0555 soundex.t || +echo 'restore of soundex.t failed' +Wc_c="`wc -c < 'soundex.t'`" +test 2408 -eq "$Wc_c" || + echo 'soundex.t: original size 2408, current size' "$Wc_c" +fi +exit 0 + +-- +The "usual disclaimers" apply. | Meiko +Mike Stok | 130C Baker Ave. Ext +Mike.Stok@meiko.concord.ma.us | Concord, MA 01742 +Meiko tel: (508) 371 0088 | + + -- cgit v1.2.1