diff options
Diffstat (limited to 'contrib/perl5/eg')
65 files changed, 0 insertions, 3523 deletions
diff --git a/contrib/perl5/eg/ADB b/contrib/perl5/eg/ADB deleted file mode 100644 index e8130e1..0000000 --- a/contrib/perl5/eg/ADB +++ /dev/null @@ -1,8 +0,0 @@ -#!/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"; diff --git a/contrib/perl5/eg/README b/contrib/perl5/eg/README deleted file mode 100644 index 15eb655..0000000 --- a/contrib/perl5/eg/README +++ /dev/null @@ -1,22 +0,0 @@ -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?? diff --git a/contrib/perl5/eg/cgi/RunMeFirst b/contrib/perl5/eg/cgi/RunMeFirst deleted file mode 100755 index 018b11b..0000000 --- a/contrib/perl5/eg/cgi/RunMeFirst +++ /dev/null @@ -1,36 +0,0 @@ -#!/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; -} diff --git a/contrib/perl5/eg/cgi/caution.xbm b/contrib/perl5/eg/cgi/caution.xbm deleted file mode 100644 index 87fcdbe..0000000 --- a/contrib/perl5/eg/cgi/caution.xbm +++ /dev/null @@ -1,12 +0,0 @@ -#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}; diff --git a/contrib/perl5/eg/cgi/clickable_image.cgi b/contrib/perl5/eg/cgi/clickable_image.cgi deleted file mode 100644 index 81daf09..0000000 --- a/contrib/perl5/eg/cgi/clickable_image.cgi +++ /dev/null @@ -1,26 +0,0 @@ -#!/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; diff --git a/contrib/perl5/eg/cgi/cookie.cgi b/contrib/perl5/eg/cgi/cookie.cgi deleted file mode 100644 index 98adda1..0000000 --- a/contrib/perl5/eg/cgi/cookie.cgi +++ /dev/null @@ -1,88 +0,0 @@ -#!/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; - - diff --git a/contrib/perl5/eg/cgi/crash.cgi b/contrib/perl5/eg/cgi/crash.cgi deleted file mode 100644 index 64f03c7..0000000 --- a/contrib/perl5/eg/cgi/crash.cgi +++ /dev/null @@ -1,6 +0,0 @@ -#!/usr/local/bin/perl - -use CGI::Carp qw(fatalsToBrowser); - -# This line invokes a fatal error message at compile time. -foo bar baz; diff --git a/contrib/perl5/eg/cgi/customize.cgi b/contrib/perl5/eg/cgi/customize.cgi deleted file mode 100644 index c1c8187..0000000 --- a/contrib/perl5/eg/cgi/customize.cgi +++ /dev/null @@ -1,92 +0,0 @@ -#!/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; diff --git a/contrib/perl5/eg/cgi/diff_upload.cgi b/contrib/perl5/eg/cgi/diff_upload.cgi deleted file mode 100644 index 913f9ca..0000000 --- a/contrib/perl5/eg/cgi/diff_upload.cgi +++ /dev/null @@ -1,68 +0,0 @@ -#!/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/>/>/g; s/</</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; -} diff --git a/contrib/perl5/eg/cgi/dna_small_gif.uu b/contrib/perl5/eg/cgi/dna_small_gif.uu deleted file mode 100644 index 1745c73..0000000 --- a/contrib/perl5/eg/cgi/dna_small_gif.uu +++ /dev/null @@ -1,63 +0,0 @@ -begin 444 dna_small.gif -M1TE&.#=A)0`J`.<``+9%&Y<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 diff --git a/contrib/perl5/eg/cgi/file_upload.cgi b/contrib/perl5/eg/cgi/file_upload.cgi deleted file mode 100644 index 3037de7..0000000 --- a/contrib/perl5/eg/cgi/file_upload.cgi +++ /dev/null @@ -1,71 +0,0 @@ -#!/usr/local/bin/perl -w - -use strict 'refs'; -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 or greater, or IE 4.0 or greater."), - 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.'; - -my @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 (my $file = param('filename')) { - my %stats; - my $tmpfile=tmpFileName($file); - my $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; - diff --git a/contrib/perl5/eg/cgi/frameset.cgi b/contrib/perl5/eg/cgi/frameset.cgi deleted file mode 100644 index fc86e92..0000000 --- a/contrib/perl5/eg/cgi/frameset.cgi +++ /dev/null @@ -1,81 +0,0 @@ -#!/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"; -} - diff --git a/contrib/perl5/eg/cgi/index.html b/contrib/perl5/eg/cgi/index.html deleted file mode 100644 index 133ecc4..0000000 --- a/contrib/perl5/eg/cgi/index.html +++ /dev/null @@ -1,119 +0,0 @@ -<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 Work with Netscape Navigator 2.0 and higher, -or Internet Explorer 3.0 and higher</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: Wed Jun 23 15:31:47 EDT 1999 -<!-- hhmts end --> -</BODY> </HTML> diff --git a/contrib/perl5/eg/cgi/internal_links.cgi b/contrib/perl5/eg/cgi/internal_links.cgi deleted file mode 100644 index 4806966..0000000 --- a/contrib/perl5/eg/cgi/internal_links.cgi +++ /dev/null @@ -1,33 +0,0 @@ -#!/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; - diff --git a/contrib/perl5/eg/cgi/javascript.cgi b/contrib/perl5/eg/cgi/javascript.cgi deleted file mode 100644 index 91c2b9e..0000000 --- a/contrib/perl5/eg/cgi/javascript.cgi +++ /dev/null @@ -1,105 +0,0 @@ -#!/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; -} - diff --git a/contrib/perl5/eg/cgi/monty.cgi b/contrib/perl5/eg/cgi/monty.cgi deleted file mode 100644 index 693c258..0000000 --- a/contrib/perl5/eg/cgi/monty.cgi +++ /dev/null @@ -1,84 +0,0 @@ -#!/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 - ; -} diff --git a/contrib/perl5/eg/cgi/multiple_forms.cgi b/contrib/perl5/eg/cgi/multiple_forms.cgi deleted file mode 100644 index b38bf93..0000000 --- a/contrib/perl5/eg/cgi/multiple_forms.cgi +++ /dev/null @@ -1,54 +0,0 @@ -#!/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; - - - diff --git a/contrib/perl5/eg/cgi/nph-clock.cgi b/contrib/perl5/eg/cgi/nph-clock.cgi deleted file mode 100644 index 55a2fbe..0000000 --- a/contrib/perl5/eg/cgi/nph-clock.cgi +++ /dev/null @@ -1,18 +0,0 @@ -#!/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(); -} - diff --git a/contrib/perl5/eg/cgi/nph-multipart.cgi b/contrib/perl5/eg/cgi/nph-multipart.cgi deleted file mode 100755 index f8cea59..0000000 --- a/contrib/perl5/eg/cgi/nph-multipart.cgi +++ /dev/null @@ -1,10 +0,0 @@ -#!/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; -} diff --git a/contrib/perl5/eg/cgi/popup.cgi b/contrib/perl5/eg/cgi/popup.cgi deleted file mode 100644 index 88cea1d..0000000 --- a/contrib/perl5/eg/cgi/popup.cgi +++ /dev/null @@ -1,32 +0,0 @@ -#!/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; diff --git a/contrib/perl5/eg/cgi/save_state.cgi b/contrib/perl5/eg/cgi/save_state.cgi deleted file mode 100644 index 85bacaf..0000000 --- a/contrib/perl5/eg/cgi/save_state.cgi +++ /dev/null @@ -1,67 +0,0 @@ -#!/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"; -} diff --git a/contrib/perl5/eg/cgi/tryit.cgi b/contrib/perl5/eg/cgi/tryit.cgi deleted file mode 100644 index 83c620c..0000000 --- a/contrib/perl5/eg/cgi/tryit.cgi +++ /dev/null @@ -1,37 +0,0 @@ -#!/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; - - diff --git a/contrib/perl5/eg/cgi/wilogo_gif.uu b/contrib/perl5/eg/cgi/wilogo_gif.uu deleted file mode 100644 index c5d1042..0000000 --- a/contrib/perl5/eg/cgi/wilogo_gif.uu +++ /dev/null @@ -1,13 +0,0 @@ -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 diff --git a/contrib/perl5/eg/changes b/contrib/perl5/eg/changes deleted file mode 100644 index 901e1ed..0000000 --- a/contrib/perl5/eg/changes +++ /dev/null @@ -1,34 +0,0 @@ -#!/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); -} - diff --git a/contrib/perl5/eg/client b/contrib/perl5/eg/client deleted file mode 100755 index 5900c90..0000000 --- a/contrib/perl5/eg/client +++ /dev/null @@ -1,34 +0,0 @@ -#!./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; } diff --git a/contrib/perl5/eg/down b/contrib/perl5/eg/down deleted file mode 100755 index bbb0d06..0000000 --- a/contrib/perl5/eg/down +++ /dev/null @@ -1,30 +0,0 @@ -#!/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; -} diff --git a/contrib/perl5/eg/dus b/contrib/perl5/eg/dus deleted file mode 100644 index 3025e2b..0000000 --- a/contrib/perl5/eg/dus +++ /dev/null @@ -1,22 +0,0 @@ -#!/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; diff --git a/contrib/perl5/eg/findcp b/contrib/perl5/eg/findcp deleted file mode 100644 index 5dba040..0000000 --- a/contrib/perl5/eg/findcp +++ /dev/null @@ -1,53 +0,0 @@ -#!/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(); -} diff --git a/contrib/perl5/eg/findtar b/contrib/perl5/eg/findtar deleted file mode 100644 index 6462f66..0000000 --- a/contrib/perl5/eg/findtar +++ /dev/null @@ -1,17 +0,0 @@ -#!/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"; -} diff --git a/contrib/perl5/eg/g/gcp b/contrib/perl5/eg/g/gcp deleted file mode 100644 index d18b6f6..0000000 --- a/contrib/perl5/eg/g/gcp +++ /dev/null @@ -1,114 +0,0 @@ -#!/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+"; -} diff --git a/contrib/perl5/eg/g/gcp.man b/contrib/perl5/eg/g/gcp.man deleted file mode 100644 index 1198554..0000000 --- a/contrib/perl5/eg/g/gcp.man +++ /dev/null @@ -1,77 +0,0 @@ -.\" $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. diff --git a/contrib/perl5/eg/g/ged b/contrib/perl5/eg/g/ged deleted file mode 100644 index 07ac88f..0000000 --- a/contrib/perl5/eg/g/ged +++ /dev/null @@ -1,21 +0,0 @@ -#!/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"; diff --git a/contrib/perl5/eg/g/ghosts b/contrib/perl5/eg/g/ghosts deleted file mode 100644 index 96ec771..0000000 --- a/contrib/perl5/eg/g/ghosts +++ /dev/null @@ -1,33 +0,0 @@ -# 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 diff --git a/contrib/perl5/eg/g/gsh b/contrib/perl5/eg/g/gsh deleted file mode 100644 index 4bc5d87..0000000 --- a/contrib/perl5/eg/g/gsh +++ /dev/null @@ -1,117 +0,0 @@ -#! /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, $$; -} diff --git a/contrib/perl5/eg/g/gsh.man b/contrib/perl5/eg/g/gsh.man deleted file mode 100644 index 2958707..0000000 --- a/contrib/perl5/eg/g/gsh.man +++ /dev/null @@ -1,80 +0,0 @@ -.\" $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. diff --git a/contrib/perl5/eg/muck b/contrib/perl5/eg/muck deleted file mode 100644 index 873539b..0000000 --- a/contrib/perl5/eg/muck +++ /dev/null @@ -1,141 +0,0 @@ -#!../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; -} diff --git a/contrib/perl5/eg/muck.man b/contrib/perl5/eg/muck.man deleted file mode 100644 index 02ae428..0000000 --- a/contrib/perl5/eg/muck.man +++ /dev/null @@ -1,21 +0,0 @@ -.\" $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. diff --git a/contrib/perl5/eg/myrup b/contrib/perl5/eg/myrup deleted file mode 100644 index 2cbdf75..0000000 --- a/contrib/perl5/eg/myrup +++ /dev/null @@ -1,29 +0,0 @@ -#!/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; - } -} diff --git a/contrib/perl5/eg/nih b/contrib/perl5/eg/nih deleted file mode 100644 index 4475c49..0000000 --- a/contrib/perl5/eg/nih +++ /dev/null @@ -1,11 +0,0 @@ -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; diff --git a/contrib/perl5/eg/relink b/contrib/perl5/eg/relink deleted file mode 100644 index 2c5793f..0000000 --- a/contrib/perl5/eg/relink +++ /dev/null @@ -1,82 +0,0 @@ -#!/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 diff --git a/contrib/perl5/eg/rename b/contrib/perl5/eg/rename deleted file mode 100755 index 10e97f7..0000000 --- a/contrib/perl5/eg/rename +++ /dev/null @@ -1,74 +0,0 @@ -#!/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 diff --git a/contrib/perl5/eg/rmfrom b/contrib/perl5/eg/rmfrom deleted file mode 100644 index 7178e77..0000000 --- a/contrib/perl5/eg/rmfrom +++ /dev/null @@ -1,7 +0,0 @@ -#!/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; diff --git a/contrib/perl5/eg/scan/scan_df b/contrib/perl5/eg/scan/scan_df deleted file mode 100644 index c221cdc..0000000 --- a/contrib/perl5/eg/scan/scan_df +++ /dev/null @@ -1,51 +0,0 @@ -#!/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'); diff --git a/contrib/perl5/eg/scan/scan_last b/contrib/perl5/eg/scan/scan_last deleted file mode 100644 index 4d15ca0..0000000 --- a/contrib/perl5/eg/scan/scan_last +++ /dev/null @@ -1,57 +0,0 @@ -#!/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; - } -} diff --git a/contrib/perl5/eg/scan/scan_messages b/contrib/perl5/eg/scan/scan_messages deleted file mode 100644 index 6cf0997..0000000 --- a/contrib/perl5/eg/scan/scan_messages +++ /dev/null @@ -1,222 +0,0 @@ -#!/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`; diff --git a/contrib/perl5/eg/scan/scan_passwd b/contrib/perl5/eg/scan/scan_passwd deleted file mode 100644 index 50f6fc8..0000000 --- a/contrib/perl5/eg/scan/scan_passwd +++ /dev/null @@ -1,30 +0,0 @@ -#!/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: $_"; - } - } -} diff --git a/contrib/perl5/eg/scan/scan_ps b/contrib/perl5/eg/scan/scan_ps deleted file mode 100644 index 18b5cb2..0000000 --- a/contrib/perl5/eg/scan/scan_ps +++ /dev/null @@ -1,32 +0,0 @@ -#!/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 diff --git a/contrib/perl5/eg/scan/scan_sudo b/contrib/perl5/eg/scan/scan_sudo deleted file mode 100644 index 5b143e9..0000000 --- a/contrib/perl5/eg/scan/scan_sudo +++ /dev/null @@ -1,54 +0,0 @@ -#!/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`; diff --git a/contrib/perl5/eg/scan/scan_suid b/contrib/perl5/eg/scan/scan_suid deleted file mode 100644 index c10aa58..0000000 --- a/contrib/perl5/eg/scan/scan_suid +++ /dev/null @@ -1,84 +0,0 @@ -#!/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; - diff --git a/contrib/perl5/eg/scan/scanner b/contrib/perl5/eg/scan/scanner deleted file mode 100644 index e73cdc8..0000000 --- a/contrib/perl5/eg/scan/scanner +++ /dev/null @@ -1,87 +0,0 @@ -#!/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; - } - } - } -} diff --git a/contrib/perl5/eg/server b/contrib/perl5/eg/server deleted file mode 100755 index 49a140a..0000000 --- a/contrib/perl5/eg/server +++ /dev/null @@ -1,27 +0,0 @@ -#!./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; - } -} diff --git a/contrib/perl5/eg/shmkill b/contrib/perl5/eg/shmkill deleted file mode 100644 index b91ee6f..0000000 --- a/contrib/perl5/eg/shmkill +++ /dev/null @@ -1,24 +0,0 @@ -#!/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; diff --git a/contrib/perl5/eg/sysvipc/README b/contrib/perl5/eg/sysvipc/README deleted file mode 100644 index 54094f1..0000000 --- a/contrib/perl5/eg/sysvipc/README +++ /dev/null @@ -1,9 +0,0 @@ -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> - - diff --git a/contrib/perl5/eg/sysvipc/ipcmsg b/contrib/perl5/eg/sysvipc/ipcmsg deleted file mode 100644 index 646d8b6..0000000 --- a/contrib/perl5/eg/sysvipc/ipcmsg +++ /dev/null @@ -1,47 +0,0 @@ -#!/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; -} diff --git a/contrib/perl5/eg/sysvipc/ipcsem b/contrib/perl5/eg/sysvipc/ipcsem deleted file mode 100644 index e0dc551..0000000 --- a/contrib/perl5/eg/sysvipc/ipcsem +++ /dev/null @@ -1,46 +0,0 @@ -#!/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; -} diff --git a/contrib/perl5/eg/sysvipc/ipcshm b/contrib/perl5/eg/sysvipc/ipcshm deleted file mode 100644 index ecc1ba4..0000000 --- a/contrib/perl5/eg/sysvipc/ipcshm +++ /dev/null @@ -1,50 +0,0 @@ -#!/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; -} diff --git a/contrib/perl5/eg/travesty b/contrib/perl5/eg/travesty deleted file mode 100644 index 7e6f983..0000000 --- a/contrib/perl5/eg/travesty +++ /dev/null @@ -1,46 +0,0 @@ -#!/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; - } - } -} diff --git a/contrib/perl5/eg/unuc b/contrib/perl5/eg/unuc deleted file mode 100755 index ae5c652..0000000 --- a/contrib/perl5/eg/unuc +++ /dev/null @@ -1,186 +0,0 @@ -#!/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 diff --git a/contrib/perl5/eg/uudecode b/contrib/perl5/eg/uudecode deleted file mode 100644 index 3b3cb60..0000000 --- a/contrib/perl5/eg/uudecode +++ /dev/null @@ -1,15 +0,0 @@ -#!/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"; -} - diff --git a/contrib/perl5/eg/van/empty b/contrib/perl5/eg/van/empty deleted file mode 100644 index d699319..0000000 --- a/contrib/perl5/eg/van/empty +++ /dev/null @@ -1,45 +0,0 @@ -#!/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(' ',@_)); -} - diff --git a/contrib/perl5/eg/van/unvanish b/contrib/perl5/eg/van/unvanish deleted file mode 100644 index acb1603..0000000 --- a/contrib/perl5/eg/van/unvanish +++ /dev/null @@ -1,66 +0,0 @@ -#!/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; diff --git a/contrib/perl5/eg/van/vanexp b/contrib/perl5/eg/van/vanexp deleted file mode 100644 index 415b73b..0000000 --- a/contrib/perl5/eg/van/vanexp +++ /dev/null @@ -1,21 +0,0 @@ -#!/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 {} \;`; -} diff --git a/contrib/perl5/eg/van/vanish b/contrib/perl5/eg/van/vanish deleted file mode 100644 index 09b9679..0000000 --- a/contrib/perl5/eg/van/vanish +++ /dev/null @@ -1,65 +0,0 @@ -#!/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; diff --git a/contrib/perl5/eg/who b/contrib/perl5/eg/who deleted file mode 100644 index ac15246..0000000 --- a/contrib/perl5/eg/who +++ /dev/null @@ -1,13 +0,0 @@ -#!/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; - } -} diff --git a/contrib/perl5/eg/wrapsuid b/contrib/perl5/eg/wrapsuid deleted file mode 100755 index 3b1fc6e..0000000 --- a/contrib/perl5/eg/wrapsuid +++ /dev/null @@ -1,104 +0,0 @@ -#!/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 |
