diff options
Diffstat (limited to 'contrib/perl5/eg')
65 files changed, 3520 insertions, 0 deletions
diff --git a/contrib/perl5/eg/ADB b/contrib/perl5/eg/ADB new file mode 100644 index 0000000..e8130e1 --- /dev/null +++ b/contrib/perl5/eg/ADB @@ -0,0 +1,8 @@ +#!/usr/bin/perl + +# $RCSfile: ADB,v $$Revision: 4.1 $$Date: 92/08/07 17:20:06 $ + +# This script is only useful when used in your crash directory. + +$num = shift; +exec 'adb', '-k', "vmunix.$num", "vmcore.$num"; diff --git a/contrib/perl5/eg/README b/contrib/perl5/eg/README new file mode 100644 index 0000000..15eb655 --- /dev/null +++ b/contrib/perl5/eg/README @@ -0,0 +1,22 @@ +Although supplied with the perl package, the perl scripts in this eg +directory and its subdirectories are placed in the public domain, and +you may do anything with them that you wish. + +This stuff is supplied on an as-is basis--little attempt has been made to make +any of it portable. It's mostly here to give you an idea of what perl code +looks like, and what tricks and idioms are used. + +System administrators responsible for many computers will enjoy the items +down in the g directory very much. The scan directory contains the beginnings +of a system to check on and report various kinds of anomalies. + +If you machine doesn't support #!, the first thing you'll want to do is +replace the #! with a couple of lines that look like this: + + eval 'exec /usr/bin/perl -S $0 ${1+"$@"}' + if $running_under_some_shell; + +being sure to include any flags that were on the #! line. A supplied script +called "nih" will translate perl scripts in place for you: + + nih g/g?? diff --git a/contrib/perl5/eg/cgi/RunMeFirst b/contrib/perl5/eg/cgi/RunMeFirst new file mode 100755 index 0000000..018b11b --- /dev/null +++ b/contrib/perl5/eg/cgi/RunMeFirst @@ -0,0 +1,36 @@ +#!/usr/local/bin/perl + +# Make a world-writeable directory for saving state. +$ww = 'WORLD_WRITABLE'; +unless (-w $ww) { + $u = umask 0; + mkdir $ww, 0777; + umask $u; +} + +# Decode the sample image. +for $uu (<*.uu>) { + unless (open UU, "<$uu") { warn "Can't open $uu: $!\n"; next } + while (<UU>) { + chomp; + if (/^begin\s+\d+\s+(.+)$/) { + $bin = $1; + last; + } + } + unless (open BIN, "> $bin") { warn "Can't create $bin: $!\n"; next } + binmode BIN; + while (<UU>) { + chomp; + last if /^end/; + print BIN unpack "u", $_; + } + close BIN; + close UU; +} + +# Create symlinks from *.txt to *.cgi for documentation purposes. +foreach (<*.cgi>) { + ($target = $_) =~ s/cgi$/txt/i; + symlink $_, $target unless -e $target; +} diff --git a/contrib/perl5/eg/cgi/caution.xbm b/contrib/perl5/eg/cgi/caution.xbm new file mode 100644 index 0000000..87fcdbe --- /dev/null +++ b/contrib/perl5/eg/cgi/caution.xbm @@ -0,0 +1,12 @@ +#define caution_width 32 +#define caution_height 32 +static char caution_bits[] = { + 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xe0,0x00,0x00,0x00,0x10,0x01, + 0x00,0x00,0x08,0x07,0x00,0x00,0x08,0x0e,0x00,0x00,0x04,0x0e,0x00,0x00,0x04, + 0x1c,0x00,0x00,0x02,0x1c,0x00,0x00,0xe2,0x38,0x00,0x00,0xf1,0x39,0x00,0x00, + 0xf1,0x71,0x00,0x80,0xf0,0x71,0x00,0x80,0xf0,0xe1,0x00,0x40,0xf0,0xe1,0x00, + 0x40,0xf0,0xc1,0x01,0x20,0xf0,0xc1,0x01,0x20,0xf0,0x81,0x03,0x10,0xe0,0x80, + 0x03,0x10,0xe0,0x00,0x07,0x08,0xe0,0x00,0x07,0x08,0xe0,0x00,0x0e,0x04,0x00, + 0x00,0x0e,0x04,0xe0,0x00,0x1c,0x02,0xf0,0x01,0x1c,0x02,0xf0,0x01,0x38,0x01, + 0xe0,0x00,0x38,0x01,0x00,0x00,0x70,0x01,0x00,0x00,0x70,0xff,0xff,0xff,0x7f, + 0xf8,0xff,0xff,0x3f,0x00,0x00,0x00,0x00}; diff --git a/contrib/perl5/eg/cgi/clickable_image.cgi b/contrib/perl5/eg/cgi/clickable_image.cgi new file mode 100644 index 0000000..81daf09 --- /dev/null +++ b/contrib/perl5/eg/cgi/clickable_image.cgi @@ -0,0 +1,26 @@ +#!/usr/local/bin/perl + +use CGI; +$query = new CGI; +print $query->header; +print $query->start_html("A Clickable Image"); +print <<END; +<H1>A Clickable Image</H1> +</A> +END +print "Sorry, this isn't very exciting!\n"; + +print $query->startform; +print $query->image_button('picture',"./wilogo.gif"); +print "Give me a: ",$query->popup_menu('letter',['A','B','C','D','E','W']),"\n"; # +print "<P>Magnification: ",$query->radio_group('magnification',['1X','2X','4X','20X']),"\n"; +print "<HR>\n"; + +if ($query->param) { + print "<P>Magnification, <EM>",$query->param('magnification'),"</EM>\n"; + print "<P>Selected Letter, <EM>",$query->param('letter'),"</EM>\n"; + ($x,$y) = ($query->param('picture.x'),$query->param('picture.y')); + print "<P>Selected Position <EM>($x,$y)</EM>\n"; +} + +print $query->end_html; diff --git a/contrib/perl5/eg/cgi/cookie.cgi b/contrib/perl5/eg/cgi/cookie.cgi new file mode 100644 index 0000000..98adda1 --- /dev/null +++ b/contrib/perl5/eg/cgi/cookie.cgi @@ -0,0 +1,88 @@ +#!/usr/local/bin/perl + +use CGI qw(:standard); + +@ANIMALS=sort qw/lion tiger bear pig porcupine ferret zebra gnu ostrich + emu moa goat weasel yak chicken sheep hyena dodo lounge-lizard + squirrel rat mouse hedgehog racoon baboon kangaroo hippopotamus + giraffe/; + +# Recover the previous animals from the magic cookie. +# The cookie has been formatted as an associative array +# mapping animal name to the number of animals. +%zoo = cookie('animals'); + +# Recover the new animal(s) from the parameter 'new_animal' +@new = param('new_animals'); + +# If the action is 'add', then add new animals to the zoo. Otherwise +# delete them. +foreach (@new) { + if (param('action') eq 'Add') { + $zoo{$_}++; + } elsif (param('action') eq 'Delete') { + $zoo{$_}-- if $zoo{$_}; + delete $zoo{$_} unless $zoo{$_}; + } +} + +# Add new animals to old, and put them in a cookie +$the_cookie = cookie(-name=>'animals', + -value=>\%zoo, + -expires=>'+1h'); + +# Print the header, incorporating the cookie and the expiration date... +print header(-cookie=>$the_cookie); + +# Now we're ready to create our HTML page. +print start_html('Animal crackers'); + +print <<EOF; +<h1>Animal Crackers</h1> +Choose the animals you want to add to the zoo, and click "add". +Come back to this page any time within the next hour and the list of +animals in the zoo will be resurrected. You can even quit Netscape +completely! +<p> +Try adding the same animal several times to the list. Does this +remind you vaguely of a shopping cart? +<p> +<em>This script only works with Netscape browsers</em> +<p> +<center> +<table border> +<tr><th>Add/Delete<th>Current Contents +EOF + ; + +print "<tr><td>",start_form; +print scrolling_list(-name=>'new_animals', + -values=>[@ANIMALS], + -multiple=>1, + -override=>1, + -size=>10),"<br>"; +print submit(-name=>'action',-value=>'Delete'), + submit(-name=>'action',-value=>'Add'); +print end_form; + +print "<td>"; +if (%zoo) { # make a table + print "<ul>\n"; + foreach (sort keys %zoo) { + print "<li>$zoo{$_} $_\n"; + } + print "</ul>\n"; +} else { + print "<strong>The zoo is empty.</strong>\n"; +} +print "</table></center>"; + +print <<EOF; +<hr> +<ADDRESS>Lincoln D. Stein</ADDRESS><BR> +<A HREF="./">More Examples</A> +EOF + ; +print end_html; + + diff --git a/contrib/perl5/eg/cgi/crash.cgi b/contrib/perl5/eg/cgi/crash.cgi new file mode 100644 index 0000000..64f03c7 --- /dev/null +++ b/contrib/perl5/eg/cgi/crash.cgi @@ -0,0 +1,6 @@ +#!/usr/local/bin/perl + +use CGI::Carp qw(fatalsToBrowser); + +# This line invokes a fatal error message at compile time. +foo bar baz; diff --git a/contrib/perl5/eg/cgi/customize.cgi b/contrib/perl5/eg/cgi/customize.cgi new file mode 100644 index 0000000..c1c8187 --- /dev/null +++ b/contrib/perl5/eg/cgi/customize.cgi @@ -0,0 +1,92 @@ +#!/usr/local/bin/perl + +use CGI qw(:standard :html3); + +# Some constants to use in our form. +@colors=qw/aqua black blue fuschia gray green lime maroon navy olive + purple red silver teal white yellow/; +@sizes=("<default>",1..7); + +# recover the "preferences" cookie. +%preferences = cookie('preferences'); + +# If the user wants to change the background color or her +# name, they will appear among our CGI parameters. +foreach ('text','background','name','size') { + $preferences{$_} = param($_) || $preferences{$_}; +} + +# Set some defaults +$preferences{'background'} = $preferences{'background'} || 'silver'; +$preferences{'text'} = $preferences{'text'} || 'black'; + +# Refresh the cookie so that it doesn't expire. This also +# makes any changes the user made permanent. +$the_cookie = cookie(-name=>'preferences', + -value=>\%preferences, + -expires=>'+30d'); +print header(-cookie=>$the_cookie); + +# Adjust the title to incorporate the user's name, if provided. +$title = $preferences{'name'} ? + "Welcome back, $preferences{name}!" : "Customizable Page"; + +# Create the HTML page. We use several of Netscape's +# extended tags to control the background color and the +# font size. It's safe to use Netscape features here because +# cookies don't work anywhere else anyway. +print start_html(-title=>$title, + -bgcolor=>$preferences{'background'}, + -text=>$preferences{'text'} + ); + +print basefont({SIZE=>$preferences{size}}) if $preferences{'size'} > 0; + +print h1($title),<<END; +You can change the appearance of this page by submitting +the fill-out form below. If you return to this page any time +within 30 days, your preferences will be restored. +END + ; + +# Create the form +print hr(), + start_form, + + "Your first name: ", + textfield(-name=>'name', + -default=>$preferences{'name'}, + -size=>30),br, + + table( + TR( + td("Preferred"), + td("Page color:"), + td(popup_menu(-name=>'background', + -values=>\@colors, + -default=>$preferences{'background'}) + ), + ), + TR( + td(''), + td("Text color:"), + td(popup_menu(-name=>'text', + -values=>\@colors, + -default=>$preferences{'text'}) + ) + ), + TR( + td(''), + td("Font size:"), + td(popup_menu(-name=>'size', + -values=>\@sizes, + -default=>$preferences{'size'}) + ) + ) + ), + + submit(-label=>'Set preferences'), + hr; + +print a({HREF=>"/"},'Go to the home page'); +print end_html; diff --git a/contrib/perl5/eg/cgi/diff_upload.cgi b/contrib/perl5/eg/cgi/diff_upload.cgi new file mode 100644 index 0000000..913f9ca --- /dev/null +++ b/contrib/perl5/eg/cgi/diff_upload.cgi @@ -0,0 +1,68 @@ +#!/usr/local/bin/perl + +$DIFF = "/usr/bin/diff"; +$PERL = "/usr/bin/perl"; + +use CGI qw(:standard); +use CGI::Carp; + +print header; +print start_html("File Diff Example"); +print "<strong>Version </strong>$CGI::VERSION<p>"; + +print <<EOF; +<H1>File Diff Example</H1> +Enter two files. When you press "submit" their diff will be +produced. +EOF + ; + +# Start a multipart form. +print start_multipart_form; +print "File #1:",filefield(-name=>'file1',-size=>45),"<BR>\n"; +print "File #2:",filefield(-name=>'file2',-size=>45),"<BR>\n"; +print "Diff type: ",radio_group(-name=>'type', + -value=>['context','normal']),"<br>\n"; +print reset,submit(-name=>'submit',-value=>'Do Diff'); +print endform; + +# Process the form if there is a file name entered +$file1 = param('file1'); +$file2 = param('file2'); + +$|=1; # for buffering +if ($file1 && $file2) { + $realfile1 = tmpFileName($file1); + $realfile2 = tmpFileName($file2); + print "<HR>\n"; + print "<H2>$file1 vs $file2</H2>\n"; + + print "<PRE>\n"; + $options = "-c" if param('type') eq 'context'; + system "$DIFF $options $realfile1 $realfile2 | $PERL -pe 's/>/>/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 new file mode 100644 index 0000000..d3ce24c --- /dev/null +++ b/contrib/perl5/eg/cgi/dna.small.gif.uu @@ -0,0 +1,63 @@ +begin 444 dna.small.gif +M1TE&.#=A)0`J`.<``+9%&Y<R0M<F'ID\,!<07%<G1:P<0Q`A2Q`P;"L9/L$: +M,"480N5"&RL7:4LD0T,G144[7BHL2B4?3\0I+"</)BQ.9KD0/S878\96$Z\@ +M(:\1*RL:3L0W&QL?2#4?9>@_&A$_5<I"&C`A3*,3-A`//9X<)\@Q(L`@.#\E +M7K,R*R\T6)H++1L72T8=4207:T`G=JX..MD^&!$_;^)2$#T=7S`79AL7.A$3 +M1-=%#^,Q&QT_:C8=1!L86]\R#4M":4H76R,515HZ4"477G@T,J\;(X(@/$\7 +M."4A2N9;$"DZ6RL34-8I$34A73P86I84/\87%1`0/V,B2"0<0N!(%QPH91<6 +M2=!5$3(=73(E23`/,!L4.=$Z'-MH%>`Y#3$=2"=#59M((H88,GP\/]X^&+$R +M$"(79"DF33(93"$86=%;&"T4/=Y"&\\A$Q4Z4!`62*T4-Q4B9+X1*BH96SP? +M1<0D/3(F<-TM$!`=5:H.(!<64C$W?#8J3*`S(S<@3=8V%K$](QT.6Q`43AL4 +M1:$D,;<0,\X9&,8])\@=$A(U244S5U,D6Q<V;]\I&&<K/8!*.R044>=/#YH> +M08$I1B,09S$35R(:4C0?<19$7<D^#Q`>5!()-;4702M`=;56)A`25,0K%"X< +M83`N>K`H'HDS*1`40,M&%!<@7M,_$A<N2L)%%18E4^<M$A@=5=0Q$Q`E311* +M2L8E&2D<7Q\A7P\80B48,%E/8[1-'J4/-"H<3"PA1$,T?Q<15R44,R,A4AL/ +M,^M4%2,07!L+,[\[&!P4520I:C(9.=54$[,2/M-)&RP?7M=(%1$J8<-,%2H@ +M4B,=51436^]2"!X<1A<44RD</>E+#%0>0S0/:4PJ9I,F-6DG420Y<"@09R,0 +M-V$R/R4M<:\H0!(H410Z:AT27&4Q9"L@;=1%(MA-$M5+#RL4+M8Z&AT<7[<: +M(-QA&2,36R$++B(84!0:5ALO:K$A.]X?&!$84V@;/SX<6Q`;2$(B2QD21W4J +M1=TW&@```````````````"P`````)0`J```(_@!]:(N'18\W%15T$1N'C)V? +M0_HH,<$G9YBX!C6<3;+T@AZ-)K@\O*"!KP^$>"KVA`L3*8P3)^5ZA)@B:AH+ +M9];F7.$Q+!`!0=*<E3'5K(:EHS2N%"AP*Y(\&##H6(!A:!XU99B*H?%4IDF? +M!8'<"-F%9I*TH8A83:*TXYD!J83D$0ICI-NE(:O8I6&FJ$64$M5$M%!3PU,F +M2UJD"9I41E824WT2G?BV-!$(!`=,+<IF!P>.%",&P7J"9XB82L5,48F5K,:" +M'94FU='6;!*R3T->E"%&95DR"`/6P,I0PDF)0SG8($$RJN0R`FI(H7$A2]VD +M*^^L_6(T3U*V%XH"_AB:HDS8H$AO5@R:P,8.I%^.:*AC(>Z!'":6RC`1L@W- +M%1Q/,%(.'5+1`<D^74R@P2#?T*'/$"%@\(L5Y?RAB!SO3#*,-6CL44\4]C1# +MR0Q3C&&"!AH08@(#:Y2C@`&1---,.#)\T84=R##`0",H++8#)34,@X80R:"` +M0A<]?'#.!";`TDH.8QBB0354A!,*)WI0\<D\YJRQ3PE[V",(.D#48$T9GO22 +MA0.BC,)'*]3TP,`^\_#QA0P@>`/"*]=<HX\3"C!BAQV%5",$+Z0,0X,UL3SB +M#B[NN$'/,A&,$L,Y[-BASR(@<**("E^,0(<&;[QA0@^,3%",#2S8H,01_LX0 +M`(0:W%`@13#TN+'#&LK@0$T0VER##50*Q/%-%%&H$`0#K7"`!B^X/`),()F0 +M0PNT[K#BRBS1-!("`^=,$8`D="B`QRW?1**+-I?(X$@(L(R2AQ8+Y,*#-*YX +MH(00'1Q!CSI,U'!%)^_%4(X&FUB@01$.@*!#$I?4D48I&1BA!2*HD%))(.+T +MYTEOT3B#PB/U4(,$%QD0(<\QX^CRBC=)@%`!&+:<<TH&M*C1"RJX'-'.'`YX +M<H0@<)#"0CX+I%`*-%:4L@XFS`#[11M?U-))"&RP84LWZL!A1A^YH.*)!)3< +MHXX6L]P3"!I`H/!`*>90`PD.F'3SR@-AG)`&_A=3'"**#[J(P<<I@YCA2@32 +M!,*+Q9H`(XT2'O2RS"CGS.U9!K>0^C0&S/#1""(ZI)'&*6,,$842N%Q!@3NK +M"R'%%4KP0D(Q?"`S!3)<I#!!".68$T(IMHP#>BVE(/$+)#-80<PTLBRP^@$> +M<+,`-[QH$LP+0_P!1C>=S("!,N>8XP<8H6131!B;3`#&#)"DTH(L5#P0S#W+ +MQ)*`$K1HHD4^;E!2QP%:B``&4H$,/Y2C$Y*(1%0(00A)@```77B"*$0@#3>P +MP&PU4`,^H!","P!!$')0P^H6((I5L"$'.;``';[Q!@-\PP"<B$<]EG"(#*C" +M%-(@0":\L0U?D&`#_L50@33.(`4M4``=&4@'+-9!!P9JP`#9T$4H=*$+!#1B +M'3A(`SYH`81'B.,(XJ@"":0(CDRPH@/<"$88V+"%$N#A&)MPX0N2H`L]C&,< +MEW"$%6:0BCV@XPIH>$0?)M$`<92!%OG8Q3#@(`U2C*)%9-!`&`K`!!EP0@80 +M2,0M;I$.:"C#"D.@P#UJ``]GT"*,K%B&*0+!@TFH8VV*0$(:_/`)?7@#'.'0 +M@R[H8``\:&`,=NC"*"B@!2TTHP5]N((TEH&`<)B"!PU`0RQ(P8MNS``9K6@% +M'W31AG%$(BZ2&((PA-&#'I"A&`F8!DD\\`H6-,.,X'B'%,+R#FX4`PS&_L!$ +M.4R0#7W<0@%O2,07$($#9@C3"%C8P!5H88\]J$,"-E!;(.X@C5T<`!65V,40 +M,'&(0C!"`1JP@"3TH`T9=&,5JRC$-]+1`U%TP@@[^,$>Z$&*0%1A%XFK`BFD +MX0L6Y"(#A_A$#[JPC@%\@1@02`(SJ#&&.`A@'\&$!AALX(4Y="`/TA"",UA! +M@%W<8!*\$`$@C%""+G1A"9AP!"<>9@ME*)$0F\C!$I8`B3\TP@%'@$(QH$`" +M)8@#'(B0ACB`P`,@%&,'9"##)S`1!&)\`0)^&,,^+$`("QC"#D\X!":HX0!< +ML(`&-O!%,&H@BS#F0AI'`!LO^"`,/OS!%KJ0_H0HEA`E27Q#%T%X0"%"@`1E +M2,`!:F!%+Q#A!G)40A!HP`4OFK`#-13#`?I(QCW38(Q/9&``%0#!);01BE>$ +M@!TZNL81$G`!-]2!&&5@A1N&T0Q<,$$$%*!``BR1A5$PPPH<74$%]*`#$.RA +M`(VP@#`X$(`7``(%T=@`.5Q`C@:0`P[)D$4'$H`."MB#"908Q=X@,01B9$(7 +MG'A%`#8!"QSL@PUAL,0==M"")CQCP4)0QQUDP806H&,!T]A!`EH@AC2P`P,^ +MT`,*NN%-&&T!&L@X!!Y^<(4.D(,%E>A`,T20C#IXL`6-:,`5F+"#!W"@'%OH +MA`IJ$5(#;`(;AV/'FA103(EV+(,>GHB&&ZJ`!D'<X0[-N$(N@)$+4$C@`<(` +M$(&/<8Q;7$,1UT"``+>P!57`X1F9D`4<W$`"4MP@$ZYX\B-"004Y2$`.HT@% +M)@IAB#><0!]FB(<I.(&`(7P"%GPPQ3)F`0YB0"$0@8"")L!Q!RH`8A&AL,8L +BR!$$,@@#&5OX!1V.\85XA.,.,A##!T2!AP@LXP#;"`@`.P`` +end diff --git a/contrib/perl5/eg/cgi/file_upload.cgi b/contrib/perl5/eg/cgi/file_upload.cgi new file mode 100644 index 0000000..f6bbbe0 --- /dev/null +++ b/contrib/perl5/eg/cgi/file_upload.cgi @@ -0,0 +1,69 @@ +#!/usr/local/bin/perl -w + +use lib '..'; +use CGI qw(:standard); +use CGI::Carp qw/fatalsToBrowser/; + +print header(); +print start_html("File Upload Example"); +print strong("Version "),$CGI::VERSION,p; + +print h1("File Upload Example"), + 'This example demonstrates how to prompt the remote user to + select a remote file for uploading. ', + strong("This feature only works with Netscape 2.0 browsers."), + p, + 'Select the ',cite('browser'),' button to choose a text file + to upload. When you press the submit button, this script + will count the number of lines, words, and characters in + the file.'; + +@types = ('count lines','count words','count characters'); + +# Start a multipart form. +print start_multipart_form(), + "Enter the file to process:", + filefield('filename','',45), + br, + checkbox_group('count',\@types,\@types), + p, + reset,submit('submit','Process File'), + endform; + +# Process the form if there is a file name entered +if ($file = param('filename')) { + $tmpfile=tmpFileName($file); + $mimetype = uploadInfo($file)->{'Content-Type'} || ''; + print hr(), + h2($file), + h3($tmpfile), + h4("MIME Type:",em($mimetype)); + + my($lines,$words,$characters,@words) = (0,0,0,0); + while (<$file>) { + $lines++; + $words += @words=split(/\s+/); + $characters += length($_); + } + close $file; + grep($stats{$_}++,param('count')); + if (%stats) { + print strong("Lines: "),$lines,br if $stats{'count lines'}; + print strong("Words: "),$words,br if $stats{'count words'}; + print strong("Characters: "),$characters,br if $stats{'count characters'}; + } else { + print strong("No statistics selected."); + } +} + +# print cite("URL parameters: "),url_param(); + +print hr(), + a({href=>"../cgi_docs.html"},"CGI documentation"), + hr, + address( + a({href=>'/~lstein'},"Lincoln D. Stein")), + br, + 'Last modified July 17, 1996', + end_html; + diff --git a/contrib/perl5/eg/cgi/frameset.cgi b/contrib/perl5/eg/cgi/frameset.cgi new file mode 100644 index 0000000..fc86e92 --- /dev/null +++ b/contrib/perl5/eg/cgi/frameset.cgi @@ -0,0 +1,81 @@ +#!/usr/local/bin/perl + +use CGI; +$query = new CGI; +print $query->header; +$TITLE="Frameset Example"; + +# We use the path information to distinguish between calls +# to the script to: +# (1) create the frameset +# (2) create the query form +# (3) create the query response + +$path_info = $query->path_info; + +# If no path information is provided, then we create +# a side-by-side frame set +if (!$path_info) { + &print_frameset; + exit 0; +} + +# If we get here, then we either create the query form +# or we create the response. +&print_html_header; +&print_query if $path_info=~/query/; +&print_response if $path_info=~/response/; +&print_end; + + +# Create the frameset +sub print_frameset { + $script_name = $query->script_name; + print <<EOF; +<html><head><title>$TITLE</title></head> +<frameset cols="50,50"> +<frame src="$script_name/query" name="query"> +<frame src="$script_name/response" name="response"> +</frameset> +EOF + ; + exit 0; +} + +sub print_html_header { + print $query->start_html($TITLE); +} + +sub print_end { + print qq{<P><hr><A HREF="../index.html" TARGET="_top">More Examples</A>}; + print $query->end_html; +} + +sub print_query { + $script_name = $query->script_name; + print "<H1>Frameset Query</H1>\n"; + print $query->startform(-action=>"$script_name/response",-TARGET=>"response"); + print "What's your name? ",$query->textfield('name'); + print "<P>What's the combination?<P>", + $query->checkbox_group(-name=>'words', + -values=>['eenie','meenie','minie','moe']); + + print "<P>What's your favorite color? ", + $query->popup_menu(-name=>'color', + -values=>['red','green','blue','chartreuse']), + "<P>"; + print $query->submit; + print $query->endform; +} + +sub print_response { + print "<H1>Frameset Result</H1>\n"; + unless ($query->param) { + print "<b>No query submitted yet.</b>"; + return; + } + print "Your name is <EM>",$query->param(name),"</EM>\n"; + print "<P>The keywords are: <EM>",join(", ",$query->param(words)),"</EM>\n"; + print "<P>Your favorite color is <EM>",$query->param(color),"</EM>\n"; +} + diff --git a/contrib/perl5/eg/cgi/index.html b/contrib/perl5/eg/cgi/index.html new file mode 100644 index 0000000..75e2d30 --- /dev/null +++ b/contrib/perl5/eg/cgi/index.html @@ -0,0 +1,118 @@ +<HTML> <HEAD> +<TITLE>More Examples of Scripts Created with CGI.pm</TITLE> +</HEAD> + +<BODY> +<H1>More Examples of Scripts Created with CGI.pm</H1> + +<H2> Basic Non Sequitur Questionnaire</H2> +<UL> + <LI> <A HREF="tryit.cgi">Try the script</A> + <LI> <A HREF="tryit.txt">Look at its source code</A> +</UL> + +<H2> Advanced Non Sequitur Questionnaire</H2> +<UL> + <LI> <A HREF="monty.cgi">Try the script</A> + <LI> <A HREF="monty.txt">Look at its source code</A> +</UL> + +<H2> Save and restore the state of a form to a file</H2> +<UL> + <LI> <A HREF="save_state.cgi">Try the script</A> + <LI> <A HREF="save_state.txt">Look at its source code</A> +</UL> + +<H2> Server Push</H2> +<ul> + <li><a href="nph-multipart.cgi">Try the script</a> + <li><a href="nph-multipart.txt">Look at its source code</a> +</ul> + +<H2> Read the coordinates from a clickable image map</H2> +<UL> + <LI> <A HREF="clickable_image.cgi">Try the script</A> + <LI> <A HREF="clickable_image.txt">Look at its source code</A> +</UL> + +<H2> Multiple independent forms on the same page</H2> +<UL> + <LI> <A HREF="multiple_forms.cgi">Try the script</A> + <LI> <A HREF="multiple_forms.txt">Look at its source code</A> +</UL> + +<H2> How to maintain state on a page with internal links</H2> +<UL> + <LI> <A HREF="internal_links.cgi">Try the script</A> + <LI> <A HREF="internal_links.txt">Look at its source code</A> +</UL> + +<h2>Echo fatal script errors to the browser</h2> +<em>This script deliberately generates a compile-time error.</em> +<ul> + <li><a href="crash.cgi">Try the script</a> + <li><a href="crash.txt">Look at its source code</a> +</ul> + +<EM>The Following Scripts only Work with Netscape 2.0 & Internet Explorer only!</EM> + +<H2> Prompt for a file to upload and process it</H2> +<UL> + <LI> <A HREF="file_upload.cgi">Try the script</A> + <LI> <A HREF="file_upload.txt">Look at its source code</A> +</UL> + +<h2> A Continuously-Updated Page using Server Push</h2> +<ul> + <li><a href="nph-clock.cgi">Try the script</a> + <li><a href="nph-clock.txt">Look at its source code</a> +</ul> + +<h2>Compute the "diff" between two uploaded files</h2> +<ul> + <li><a href="diff_upload.cgi">Try the script</a> + <li><a href="diff_upload.txt">Look at its source code</a> +</ul> + +<h2>Maintain state over a long period with a cookie</h2> +<ul> + <li><a href="cookie.cgi">Try the script</a> + <li><a href="cookie.txt">Look at its source code</a> +</ul> + +<h2>Permanently customize the appearance of a page with a cookie</h2> +<ul> + <li><a href="customize.cgi">Try the script</a> + <li><a href="customize.txt">Look at its source code</a> +</ul> + +<h2> Popup the response in a new window</h2> +<ul> + <li><a href="popup.cgi">Try the script</a> + <li><a href="popup.txt">Look at its source code</a> +</ul> + +<h2> Side-by-side form and response using frames</h2> +<ul> + <li><a href="frameset.cgi">Try the script</a> + <li><a href="frameset.txt">Look at its source code</a> +</ul> + +<h2>Verify the Contents of a fill-out form with JavaScript</h2> +<ul> + <li><a href="javascript.cgi">Try the script</a> + <li><a href="javascript.txt">Look at its source code</a> +</ul> + +<HR> +<MENU> + <LI> <A HREF="../cgi_docs.html">CGI.pm documentation</A> + <LI> <A HREF="../../CGI.pm.tar.gz">Download the CGI.pm distribution</A> +</MENU> +<HR> +<ADDRESS>Lincoln D. Stein, lstein@genome.wi.mit.edu<br> +<a href="/">Whitehead Institute/MIT Center for Genome Research</a></ADDRESS> +<!-- hhmts start --> +Last modified: Tue May 19 22:16:43 EDT 1998 +<!-- hhmts end --> +</BODY> </HTML> diff --git a/contrib/perl5/eg/cgi/internal_links.cgi b/contrib/perl5/eg/cgi/internal_links.cgi new file mode 100644 index 0000000..4806966 --- /dev/null +++ b/contrib/perl5/eg/cgi/internal_links.cgi @@ -0,0 +1,33 @@ +#!/usr/local/bin/perl + +use CGI; +$query = new CGI; + +# We generate a regular HTML file containing a very long list +# and a popup menu that does nothing except to show that we +# don't lose the state information. +print $query->header; +print $query->start_html("Internal Links Example"); +print "<H1>Internal Links Example</H1>\n"; +print "Click <cite>Submit Query</cite> to create a state. Then scroll down and", + " click on any of the <cite>Jump to top</cite> links. This is not very exciting."; + +print "<A NAME=\"start\"></A>\n"; # an anchor point at the top + +# pick a default starting value; +$query->param('amenu','FOO1') unless $query->param('amenu'); + +print $query->startform; +print $query->popup_menu('amenu',[('FOO1'..'FOO9')]); +print $query->submit,$query->endform; + +# We create a long boring list for the purposes of illustration. +$myself = $query->self_url; +print "<OL>\n"; +for (1..100) { + print qq{<LI>List item #$_ <A HREF="$myself#start">Jump to top</A>\n}; +} +print "</OL>\n"; + +print $query->end_html; + diff --git a/contrib/perl5/eg/cgi/javascript.cgi b/contrib/perl5/eg/cgi/javascript.cgi new file mode 100644 index 0000000..91c2b9e --- /dev/null +++ b/contrib/perl5/eg/cgi/javascript.cgi @@ -0,0 +1,105 @@ +#!/usr/local/bin/perl + +# This script illustrates how to use JavaScript to validate fill-out +# forms. +use CGI qw(:standard); + +# Here's the javascript code that we include in the document. +$JSCRIPT=<<EOF; + // validate that the user is the right age. Return + // false to prevent the form from being submitted. + function validateForm() { + var today = new Date(); + var birthday = validateDate(document.form1.birthdate); + if (birthday == 0) { + document.form1.birthdate.focus() + document.form1.birthdate.select(); + return false; + } + var milliseconds = today.getTime()-birthday; + var years = milliseconds/(1000 * 60 * 60 * 24 * 365.25); + if ((years > 20) || (years < 5)) { + alert("You must be between the ages of 5 and 20 to submit this form"); + document.form1.birthdate.focus(); + document.form1.birthdate.select(); + return false; + } + // Since we've calculated the age in years already, + // we might as well send it up to our CGI script. + document.form1.age.value=Math.floor(years); + return true; + } + + // make sure that the contents of the supplied + // field contain a valid date. + function validateDate(element) { + var date = Date.parse(element.value); + if (0 == date) { + alert("Please enter date in format MMM DD, YY"); + element.focus(); + element.select(); + } + return date; + } + + // Compliments, compliments + function doPraise(element) { + if (element.checked) { + self.status=element.value + " is an excellent choice!"; + return true; + } else { + return false; + } + } + + function checkColor(element) { + var color = element.options[element.selectedIndex].text; + if (color == "blonde") { + if (confirm("Is it true that blondes have more fun?")) + alert("Darn. That leaves me out."); + } else + alert(color + " is a fine choice!"); + } +EOF + ; + +# here's where the execution begins +print header; +print start_html(-title=>'Personal Profile',-script=>$JSCRIPT); + +print h1("Big Brother Wants to Know All About You"), + strong("Note: "),"This page uses JavaScript and requires ", + "Netscape 2.0 or higher to do anything special."; + +&print_prompt(); +print hr; +&print_response() if param; +print end_html; + +sub print_prompt { + print start_form(-name=>'form1', + -onSubmit=>"return validateForm()"),"\n"; + print "Birthdate (e.g. Jan 3, 1972): ", + textfield(-name=>'birthdate', + -onBlur=>"validateDate(this)"),"<p>\n"; + print "Sex: ",radio_group(-name=>'gender', + -value=>[qw/male female/], + -onClick=>"doPraise(this)"),"<p>\n"; + print "Hair color: ",popup_menu(-name=>'color', + -value=>[qw/brunette blonde red gray/], + -default=>'red', + -onChange=>"checkColor(this)"),"<p>\n"; + print hidden(-name=>'age',-value=>0); + print submit(); + print end_form; +} + +sub print_response { + import_names('Q'); + print h2("Your profile"), + "You claim to be a ",b($Q::age)," year old ",b($Q::color,$Q::gender),".", + "You should be ashamed of yourself for lying so ", + "blatantly to big brother!", + hr; +} + diff --git a/contrib/perl5/eg/cgi/monty.cgi b/contrib/perl5/eg/cgi/monty.cgi new file mode 100644 index 0000000..693c258 --- /dev/null +++ b/contrib/perl5/eg/cgi/monty.cgi @@ -0,0 +1,84 @@ +#!/usr/local/bin/perl + +use CGI; +use CGI::Carp qw/fatalsToBrowser/; + +$query = new CGI; + +print $query->header; +print $query->start_html("Example CGI.pm Form"); +print "<H1> Example CGI.pm Form</H1>\n"; +&print_prompt($query); +&do_work($query); +&print_tail; +print $query->end_html; + +sub print_prompt { + my($query) = @_; + + print $query->start_form; + print "<EM>What's your name?</EM><BR>"; + print $query->textfield('name'); + print $query->checkbox('Not my real name'); + + print "<P><EM>Where can you find English Sparrows?</EM><BR>"; + print $query->checkbox_group( + -name=>'Sparrow locations', + -Values=>[England,France,Spain,Asia,Hoboken], + -linebreak=>'yes', + -defaults=>[England,Asia]); + + print "<P><EM>How far can they fly?</EM><BR>", + $query->radio_group( + -name=>'how far', + -Values=>['10 ft','1 mile','10 miles','real far'], + -default=>'1 mile'); + + print "<P><EM>What's your favorite color?</EM> "; + print $query->popup_menu(-name=>'Color', + -Values=>['black','brown','red','yellow'], + -default=>'red'); + + print $query->hidden('Reference','Monty Python and the Holy Grail'); + + print "<P><EM>What have you got there?</EM><BR>"; + print $query->scrolling_list( + -name=>'possessions', + -Values=>['A Coconut','A Grail','An Icon', + 'A Sword','A Ticket'], + -size=>5, + -multiple=>'true'); + + print "<P><EM>Any parting comments?</EM><BR>"; + print $query->textarea(-name=>'Comments', + -rows=>10, + -columns=>50); + + print "<P>",$query->reset; + print $query->submit('Action','Shout'); + print $query->submit('Action','Scream'); + print $query->endform; + print "<HR>\n"; + } + +sub do_work { + my($query) = @_; + my(@values,$key); + + print "<H2>Here are the current settings in this form</H2>"; + + foreach $key ($query->param) { + print "<STRONG>$key</STRONG> -> "; + @values = $query->param($key); + print join(", ",@values),"<BR>\n"; + } +} + +sub print_tail { + print <<END; +<HR> +<ADDRESS>Lincoln D. Stein</ADDRESS><BR> +<A HREF="/">Home Page</A> +END + ; +} diff --git a/contrib/perl5/eg/cgi/multiple_forms.cgi b/contrib/perl5/eg/cgi/multiple_forms.cgi new file mode 100644 index 0000000..b38bf93 --- /dev/null +++ b/contrib/perl5/eg/cgi/multiple_forms.cgi @@ -0,0 +1,54 @@ +#!/usr/local/bin/perl + +use CGI; + +$query = new CGI; +print $query->header; +print $query->start_html('Multiple Forms'); +print "<H1>Multiple Forms</H1>\n"; + +# Print the first form +print $query->startform; +$name = $query->remote_user || 'anonymous@' . $query->remote_host; + +print "What's your name? ",$query->textfield('name',$name,50); +print "<P>What's the combination?<P>", + $query->checkbox_group('words',['eenie','meenie','minie','moe']); +print "<P>What's your favorite color? ", + $query->popup_menu('color',['red','green','blue','chartreuse']), + "<P>"; +print $query->submit('form_1','Send Form 1'); +print $query->endform; + +# Print the second form +print "<HR>\n"; +print $query->startform; +print "Some radio buttons: ",$query->radio_group('radio buttons', + [qw{one two three four five}],'three'),"\n"; +print "<P>What's the password? ",$query->password_field('pass','secret'); +print $query->defaults,$query->submit('form_2','Send Form 2'),"\n"; +print $query->endform; + +print "<HR>\n"; + +$query->import_names('Q'); +if ($Q::form_1) { + print "<H2>Form 1 Submitted</H2>\n"; + print "Your name is <EM>$Q::name</EM>\n"; + print "<P>The combination is: <EM>{",join(",",@Q::words),"}</EM>\n"; + print "<P>Your favorite color is <EM>$Q::color</EM>\n"; +} elsif ($Q::form_2) { + print <<EOF; +<H2>Form 2 Submitted</H2> +<P>The value of the radio buttons is <EM>$Q::radio_buttons</EM> +<P>The secret password is <EM>$Q::pass</EM> +EOF + ; +} +print qq{<P><A HREF="./">Other examples</A>}; +print qq{<P><A HREF="../cgi_docs.html">Go to the documentation</A>}; + +print $query->end_html; + + + diff --git a/contrib/perl5/eg/cgi/nph-clock.cgi b/contrib/perl5/eg/cgi/nph-clock.cgi new file mode 100644 index 0000000..55a2fbe --- /dev/null +++ b/contrib/perl5/eg/cgi/nph-clock.cgi @@ -0,0 +1,18 @@ +#!/usr/local/bin/perl -w + +use CGI::Push qw(:standard :html3); + +do_push(-next_page=>\&draw_time,-delay=>1); + +sub draw_time { + my $time = `/bin/date`; + return start_html('Tick Tock'), + div({-align=>CENTER}, + h1('Virtual Clock'), + h2($time) + ), + hr, + a({-href=>'index.html'},'More examples'), + end_html(); +} + diff --git a/contrib/perl5/eg/cgi/nph-multipart.cgi b/contrib/perl5/eg/cgi/nph-multipart.cgi new file mode 100755 index 0000000..f8cea59 --- /dev/null +++ b/contrib/perl5/eg/cgi/nph-multipart.cgi @@ -0,0 +1,10 @@ +#!/usr/local/bin/perl +use CGI qw/:push -nph/; +$| = 1; +print multipart_init(-boundary=>'----------------here we go!'); +while (1) { + print multipart_start(-type=>'text/plain'), + "The current time is ",scalar(localtime),"\n", + multipart_end; + sleep 1; +} diff --git a/contrib/perl5/eg/cgi/popup.cgi b/contrib/perl5/eg/cgi/popup.cgi new file mode 100644 index 0000000..88cea1d --- /dev/null +++ b/contrib/perl5/eg/cgi/popup.cgi @@ -0,0 +1,32 @@ +#!/usr/local/bin/perl + +use CGI; +$query = new CGI; +print $query->header; +print $query->start_html('Popup Window'); + + +if (!$query->param) { + print "<H1>Ask your Question</H1>\n"; + print $query->startform(-target=>'_new'); + print "What's your name? ",$query->textfield('name'); + print "<P>What's the combination?<P>", + $query->checkbox_group(-name=>'words', + -values=>['eenie','meenie','minie','moe'], + -defaults=>['eenie','moe']); + + print "<P>What's your favorite color? ", + $query->popup_menu(-name=>'color', + -values=>['red','green','blue','chartreuse']), + "<P>"; + print $query->submit; + print $query->endform; + +} else { + print "<H1>And the Answer is...</H1>\n"; + print "Your name is <EM>",$query->param(name),"</EM>\n"; + print "<P>The keywords are: <EM>",join(", ",$query->param(words)),"</EM>\n"; + print "<P>Your favorite color is <EM>",$query->param(color),"</EM>\n"; +} +print qq{<P><A HREF="cgi_docs.html">Go to the documentation</A>}; +print $query->end_html; diff --git a/contrib/perl5/eg/cgi/save_state.cgi b/contrib/perl5/eg/cgi/save_state.cgi new file mode 100644 index 0000000..85bacaf --- /dev/null +++ b/contrib/perl5/eg/cgi/save_state.cgi @@ -0,0 +1,67 @@ +#!/usr/local/bin/perl + +use CGI; +$query = new CGI; + +print $query->header; +print $query->start_html("Save and Restore Example"); +print "<H1>Save and Restore Example</H1>\n"; + +# Here's where we take action on the previous request +&save_parameters($query) if $query->param('action') eq 'SAVE'; +$query = &restore_parameters($query) if $query->param('action') eq 'RESTORE'; + +# Here's where we create the form +print $query->start_multipart_form; +print "Popup 1: ",$query->popup_menu('popup1',[qw{red green purple magenta orange chartreuse brown}]),"\n"; +print "Popup 2: ",$query->popup_menu('popup2',[qw{lion tiger bear zebra potto wildebeest frog emu gazelle}]),"\n"; +print "<P>"; +$default_name = $query->remote_addr . '.sav'; +print "Save/restore state from file: ",$query->textfield('savefile',$default_name),"\n"; +print "<P>"; +print $query->submit('action','SAVE'),$query->submit('action','RESTORE'); +print "<P>",$query->defaults; +print $query->endform; + +# Here we print out a bit at the end +print $query->end_html; + +sub save_parameters { + local($query) = @_; + local($filename) = &clean_name($query->param('savefile')); + if (open(FILE,">$filename")) { + $query->save(FILE); + close FILE; + print "<STRONG>State has been saved to file $filename</STRONG>\n"; + print "<P>If you remember this name you can restore the state later.\n"; + } else { + print "<STRONG>Error:</STRONG> couldn't write to file $filename: $!\n"; + } +} + +sub restore_parameters { + local($query) = @_; + local($filename) = &clean_name($query->param('savefile')); + if (open(FILE,$filename)) { + $query = new CGI(FILE); # Throw out the old query, replace it with a new one + close FILE; + print "<STRONG>State has been restored from file $filename</STRONG>\n"; + } else { + print "<STRONG>Error:</STRONG> couldn't restore file $filename: $!\n"; + } + return $query; +} + + +# Very important subroutine -- get rid of all the naughty +# metacharacters from the file name. If there are, we +# complain bitterly and die. +sub clean_name { + local($name) = @_; + unless ($name=~/^[\w\._\-]+$/) { + print "<STRONG>$name has naughty characters. Only "; + print "alphanumerics are allowed. You can't use absolute names.</STRONG>"; + die "Attempt to use naughty characters"; + } + return "WORLD_WRITABLE/$name"; +} diff --git a/contrib/perl5/eg/cgi/tryit.cgi b/contrib/perl5/eg/cgi/tryit.cgi new file mode 100644 index 0000000..83c620c --- /dev/null +++ b/contrib/perl5/eg/cgi/tryit.cgi @@ -0,0 +1,37 @@ +#!/usr/local/bin/perl + +use CGI ':standard'; + +print header; +print start_html('A Simple Example'), + h1('A Simple Example'), + start_form, + "What's your name? ",textfield('name'), + p, + "What's the combination?", + p, + checkbox_group(-name=>'words', + -values=>['eenie','meenie','minie','moe'], + -defaults=>['eenie','minie']), + p, + "What's your favorite color? ", + popup_menu(-name=>'color', + -values=>['red','green','blue','chartreuse']), + p, + submit, + end_form, + hr; + +if (param()) { + print + "Your name is: ",em(param('name')), + p, + "The keywords are: ",em(join(", ",param('words'))), + p, + "Your favorite color is: ",em(param('color')), + hr; +} +print a({href=>'../cgi_docs.html'},'Go to the documentation'); +print end_html; + + diff --git a/contrib/perl5/eg/cgi/wilogo.gif.uu b/contrib/perl5/eg/cgi/wilogo.gif.uu new file mode 100644 index 0000000..c5d1042 --- /dev/null +++ b/contrib/perl5/eg/cgi/wilogo.gif.uu @@ -0,0 +1,13 @@ +begin 444 wilogo.gif +M1TE&.#=A7@!$`(```'X2F?___RP`````7@!$```"_D2.J<#MKF)ZU,A3,[OO +M(IUY']A%9"6AW$F)+#2]Y:BNLF6_\;WMH<?#I72^VP+D"@*)F&"O25KRDM&B +M[%C-7;4_J)*6'4ZE&O`W8"1OQ5UGPWRBIKDPM!MW9J]-[;LUKL;$5W.'YQ3( +M(O<&-^>F*(A55\BX%UEI^;<VB0BH1RFX2=<IELE4^*0'N?-I>OJ8N%(*Z^4G +M.OJJ>8HZ.(>;JRMD><E[!KQHB^3;:APL6Z8\RKPK/)O:*-WLW&7]*\UYR]J) +M?<P=1MR-_6VN76,WGAV^32W^3CZ_SCY3;W__C-R^CU^\%M#T!9PVL(ZZ&>X" +M%A1XSM]!A?T8/C0T$1XMJG\B&G+,"-&C/(VS0(842;`)M'S>_OE8F#"=2S#* +M8LHLAS'D1Y,42UGY9O,F-T:X@@JEE@D1RW>/D@8R.DZ-+*E0CQ:9JJ5JU!SQ +MR&BU2D.;E*4'ER0TNY%G2A/Y.G[=VG%81+5K_UG$21<A6;=YP9'5B++O7:@7 +M\]J5]]?DX7:)%<]5%=B/55>-GQW55;$8L\RW6J8-9>QM7<^A/SMZK!ESY$,+ +(KPA.EJ```#L` +end diff --git a/contrib/perl5/eg/changes b/contrib/perl5/eg/changes new file mode 100644 index 0000000..901e1ed --- /dev/null +++ b/contrib/perl5/eg/changes @@ -0,0 +1,34 @@ +#!/usr/bin/perl -P + +# $RCSfile: changes,v $$Revision: 4.1 $$Date: 92/08/07 17:20:08 $ + +($dir, $days) = @ARGV; +$dir = '/' if $dir eq ''; +$days = '14' if $days eq ''; + +# Masscomps do things differently from Suns + +#if defined(mc300) || defined(mc500) || defined(mc700) +open(Find, "find $dir -mtime -$days -print |") || + die "changes: can't run find"; +#else +open(Find, "find $dir \\( -fstype nfs -prune \\) -o -mtime -$days -ls |") || + die "changes: can't run find"; +#endif + +while (<Find>) { + +#if defined(mc300) || defined(mc500) || defined(mc700) + $x = `/bin/ls -ild $_`; + $_ = $x; + ($inode,$perm,$links,$owner,$group,$size,$month,$day,$time,$name) + = split(' '); +#else + ($inode,$blocks,$perm,$links,$owner,$group,$size,$month,$day,$time,$name) + = split(' '); +#endif + + printf("%10s%3s %-8s %-8s%9s %3s %2s %s\n", + $perm,$links,$owner,$group,$size,$month,$day,$name); +} + diff --git a/contrib/perl5/eg/client b/contrib/perl5/eg/client new file mode 100755 index 0000000..5900c90 --- /dev/null +++ b/contrib/perl5/eg/client @@ -0,0 +1,34 @@ +#!./perl + +$pat = 'S n C4 x8'; +$inet = 2; +$echo = 7; +$smtp = 25; +$nntp = 119; +$test = 2345; + +$SIG{'INT'} = 'dokill'; + +$this = pack($pat,$inet,0, 128,149,13,43); +$that = pack($pat,$inet,$test,127,0,0,1); + +if (socket(S,2,1,6)) { print "socket ok\n"; } else { die $!; } +if (bind(S,$this)) { print "bind ok\n"; } else { die $!; } +if (connect(S,$that)) { print "connect ok\n"; } else { die $!; } + +select(S); $| = 1; select(stdout); + +if ($child = fork) { + while (<STDIN>) { + print S; + } + sleep 3; + do dokill(); +} +else { + while (<S>) { + print; + } +} + +sub dokill { kill 9,$child if $child; } diff --git a/contrib/perl5/eg/down b/contrib/perl5/eg/down new file mode 100755 index 0000000..bbb0d06 --- /dev/null +++ b/contrib/perl5/eg/down @@ -0,0 +1,30 @@ +#!/usr/bin/perl + +$| = 1; +if ($#ARGV >= 0) { + $cmd = join(' ',@ARGV); +} +else { + print "Command: "; + $cmd = <stdin>; + chop($cmd); + while ($cmd =~ s/\\$//) { + print "+ "; + $cmd .= <stdin>; + chop($cmd); + } +} +$cwd = `pwd`; chop($cwd); + +open(FIND,'find . -type d -print|') || die "Can't run find"; + +while (<FIND>) { + chop; + unless (chdir $_) { + print stderr "Can't cd to $_\n"; + next; + } + print "\t--> ",$_,"\n"; + system $cmd; + chdir $cwd; +} diff --git a/contrib/perl5/eg/dus b/contrib/perl5/eg/dus new file mode 100644 index 0000000..3025e2b --- /dev/null +++ b/contrib/perl5/eg/dus @@ -0,0 +1,22 @@ +#!/usr/bin/perl + +# $RCSfile: dus,v $$Revision: 4.1 $$Date: 92/08/07 17:20:11 $ + +# This script does a du -s on any directories in the current directory that +# are not mount points for another filesystem. + +($mydev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, + $blksize,$blocks) = stat('.'); + +open(ls,'ls -F1|'); + +while (<ls>) { + chop; + next unless s|/$||; + ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, + $blksize,$blocks) = stat($_); + next unless $dev == $mydev; + push(@ary,$_); +} + +exec 'du', '-s', @ary; diff --git a/contrib/perl5/eg/findcp b/contrib/perl5/eg/findcp new file mode 100644 index 0000000..5dba040 --- /dev/null +++ b/contrib/perl5/eg/findcp @@ -0,0 +1,53 @@ +#!/usr/bin/perl + +# $RCSfile: findcp,v $$Revision: 4.1 $$Date: 92/08/07 17:20:12 $ + +# This is a wrapper around the find command that pretends find has a switch +# of the form -cp host:destination. It presumes your find implements -ls. +# It uses tar to do the actual copy. If your tar knows about the I switch +# you may prefer to use findtar, since this one has to do the tar in batches. + +sub copy { + `tar cf - $list | rsh $desthost cd $destdir '&&' tar xBpf -`; +} + +$sourcedir = $ARGV[0]; +if ($sourcedir =~ /^\//) { + $ARGV[0] = '.'; + unless (chdir($sourcedir)) { die "Can't find directory $sourcedir: $!"; } +} + +$args = join(' ',@ARGV); +if ($args =~ s/-cp *([^ ]+)/-ls/) { + $dest = $1; + if ($dest =~ /(.*):(.*)/) { + $desthost = $1; + $destdir = $2; + } + else { + die "Malformed destination--should be host:directory"; + } +} +else { + die("No destination specified"); +} + +open(find,"find $args |") || die "Can't run find for you: $!"; + +while (<find>) { + @x = split(' '); + if ($x[2] =~ /^d/) { next;} + chop($filename = $x[10]); + if (length($list) > 5000) { + do copy(); + $list = ''; + } + else { + $list .= ' '; + } + $list .= $filename; +} + +if ($list) { + do copy(); +} diff --git a/contrib/perl5/eg/findtar b/contrib/perl5/eg/findtar new file mode 100644 index 0000000..6462f66 --- /dev/null +++ b/contrib/perl5/eg/findtar @@ -0,0 +1,17 @@ +#!/usr/bin/perl + +# $RCSfile: findtar,v $$Revision: 4.1 $$Date: 92/08/07 17:20:13 $ + +# findtar takes find-style arguments and spits out a tarfile on stdout. +# It won't work unless your find supports -ls and your tar the I flag. + +$args = join(' ',@ARGV); +open(find,"/usr/bin/find $args -ls |") || die "Can't run find for you."; + +open(tar,"| /bin/tar cIf - -") || die "Can't run tar for you: $!"; + +while (<find>) { + @x = split(' '); + if ($x[2] =~ /^d/) { print tar '-d ';} + print tar $x[10],"\n"; +} diff --git a/contrib/perl5/eg/g/gcp b/contrib/perl5/eg/g/gcp new file mode 100644 index 0000000..d18b6f6 --- /dev/null +++ b/contrib/perl5/eg/g/gcp @@ -0,0 +1,114 @@ +#!/usr/bin/perl + +# $RCSfile: gcp,v $$Revision: 4.1 $$Date: 92/08/07 17:20:15 $ + +# Here is a script to do global rcps. See man page. + +$#ARGV >= 1 || die "Not enough arguments.\n"; + +if ($ARGV[0] eq '-r') { + $rcp = 'rcp -r'; + shift; +} else { + $rcp = 'rcp'; +} +$args = $rcp; +$dest = $ARGV[$#ARGV]; + +$SIG{'QUIT'} = 'CLEANUP'; +$SIG{'INT'} = 'CONT'; + +while ($arg = shift) { + if ($arg =~ /^([-a-zA-Z0-9_+]+):/) { + if ($systype && $systype ne $1) { + die "Can't mix system type specifers ($systype vs $1).\n"; + } + $#ARGV < 0 || $arg !~ /:$/ || die "No source file specified.\n"; + $systype = $1; + $args .= " $arg"; + } else { + if ($#ARGV >= 0) { + if ($arg =~ /^[\/~]/) { + $arg =~ /^(.*)\// && ($dir = $1); + } else { + if (!$pwd) { + chop($pwd = `pwd`); + } + $dir = $pwd; + } + } + if ($olddir && $dir ne $olddir && $dest =~ /:$/) { + $args .= " $dest$olddir; $rcp"; + } + $olddir = $dir; + $args .= " $arg"; + } +} + +die "No system type specified.\n" unless $systype; + +$args =~ s/:$/:$olddir/; + +chop($thishost = `hostname`); + +$one_of_these = ":$systype:"; +if ($systype =~ s/\+/[+]/g) { + $one_of_these =~ s/\+/:/g; +} +$one_of_these =~ s/-/:-/g; + +@ARGV = (); +push(@ARGV,'.grem') if -f '.grem'; +push(@ARGV,'.ghosts') if -f '.ghosts'; +push(@ARGV,'/etc/ghosts'); + +$remainder = ''; + +line: while (<>) { + s/[ \t]*\n//; + if (!$_ || /^#/) { + next line; + } + if (/^([a-zA-Z_0-9]+)=(.+)/) { + $name = $1; $repl = $2; + $repl =~ s/\+/:/g; + $repl =~ s/-/:-/g; + $one_of_these =~ s/:$name:/:$repl:/; + $repl =~ s/:/:-/g; + $one_of_these =~ s/:-$name:/:-$repl:/g; + next line; + } + @gh = split(' '); + $host = $gh[0]; + next line if $host eq $thishost; # should handle aliases too + $wanted = 0; + foreach $class (@gh) { + $wanted++ if index($one_of_these,":$class:") >= 0; + $wanted = -9999 if index($one_of_these,":-$class:") >= 0; + } + if ($wanted > 0) { + ($cmd = $args) =~ s/[ \t]$systype:/ $host:/g; + print "$cmd\n"; + $result = `$cmd 2>&1`; + $remainder .= "$host+" if + $result =~ /Connection timed out|Permission denied/; + print $result; + } +} + +if ($remainder) { + chop($remainder); + open(grem,">.grem") || (printf stderr "Can't create .grem: $!\n"); + print grem 'rem=', $remainder, "\n"; + close(grem); + print 'rem=', $remainder, "\n"; +} + +sub CLEANUP { + exit; +} + +sub CONT { + print "Continuing...\n"; # Just ignore the signal that kills rcp + $remainder .= "$host+"; +} diff --git a/contrib/perl5/eg/g/gcp.man b/contrib/perl5/eg/g/gcp.man new file mode 100644 index 0000000..1198554 --- /dev/null +++ b/contrib/perl5/eg/g/gcp.man @@ -0,0 +1,77 @@ +.\" $RCSfile: gcp.man,v $$Revision: 4.1 $$Date: 92/08/07 17:20:17 $ +.TH GCP 1C "13 May 1988" +.SH NAME +gcp \- global file copy +.SH SYNOPSIS +.B gcp +file1 file2 +.br +.B gcp +[ +.B \-r +] file ... directory +.SH DESCRIPTION +.I gcp +works just like rcp(1C) except that you may specify a set of hosts to copy files +from or to. +The host sets are defined in the file /etc/ghosts. +(An individual host name can be used as a set containing one member.) +You can give a command like + + gcp /etc/motd sun: + +to copy your /etc/motd file to /etc/motd on all the Suns. +If, on the other hand, you say + + gcp /a/foo /b/bar sun:/tmp + +then your files will be copied to /tmp on all the Suns. +The general rule is that if you don't specify the destination directory, +files go to the same directory they are in currently. +.P +You may specify the union of two or more sets by using + as follows: + + gcp /a/foo /b/bar 750+mc: + +which will copy /a/foo to /a/foo on all 750's and Masscomps, and then copy +/b/bar to /b/bar on all 750's and Masscomps. +.P +Commonly used sets should be defined in /etc/ghosts. +For example, you could add a line that says + + pep=manny+moe+jack + +Another way to do that would be to add the word "pep" after each of the host +entries: + + manny sun3 pep +.br + moe sun3 pep +.br + jack sun3 pep + +Hosts and sets of host can also be excluded: + + foo=sun-sun2 + +Any host so excluded will never be included, even if a subsequent set on the +line includes it: + + foo=abc+def +.br + bar=xyz-abc+foo + +comes out to xyz+def. + +You can define private host sets by creating .ghosts in your current directory +with entries just like /etc/ghosts. +Also, if there is a file .grem, it defines "rem" to be the remaining hosts +from the last gsh or gcp that didn't succeed everywhere. +.PP +Interrupting with a SIGINT will cause the rcp to the current host to be skipped +and execution resumed with the next host. +To stop completely, send a SIGQUIT. +.SH SEE ALSO +rcp(1C) +.SH BUGS +All the bugs of rcp, since it calls rcp. diff --git a/contrib/perl5/eg/g/ged b/contrib/perl5/eg/g/ged new file mode 100644 index 0000000..07ac88f --- /dev/null +++ b/contrib/perl5/eg/g/ged @@ -0,0 +1,21 @@ +#!/usr/bin/perl + +# $RCSfile: ged,v $$Revision: 4.1 $$Date: 92/08/07 17:20:18 $ + +# Does inplace edits on a set of files on a set of machines. +# +# Typical invokation: +# +# ged vax+sun /etc/passwd +# s/Freddy/Freddie/; +# ^D +# + +$class = shift; +$files = join(' ',@ARGV); + +die "Usage: ged class files <perlcmds\n" unless $files; + +exec "gsh", $class, "-d", "perl -pi.bak - $files"; + +die "Couldn't execute gsh for some reason, stopped"; diff --git a/contrib/perl5/eg/g/ghosts b/contrib/perl5/eg/g/ghosts new file mode 100644 index 0000000..96ec771 --- /dev/null +++ b/contrib/perl5/eg/g/ghosts @@ -0,0 +1,33 @@ +# This first section gives alternate sets defined in terms of the sets given +# by the second section. The order is important--all references must be +# forward references. + +Nnd=sun-nd +all=sun+mc+vax +baseline=sun+mc +sun=sun2+sun3 +vax=750+8600 +pep=manny+moe+jack + +# This second section defines the basic sets. Each host should have a line +# that specifies which sets it is a member of. Extra sets should be separated +# by white space. (The first section isn't strictly necessary, since all sets +# could be defined in the second section, but then it wouldn't be so readable.) + +basvax 8600 src +cdb0 sun3 sys +cdb1 sun3 sys +cdb2 sun3 sys +chief sun3 src +tis0 sun3 +manny sun3 sys +moe sun3 sys +jack sun3 sys +disney sun3 sys +huey sun3 nd +dewey sun3 nd +louie sun3 nd +bizet sun2 src sys +gif0 mc src +mc0 mc +dtv0 mc diff --git a/contrib/perl5/eg/g/gsh b/contrib/perl5/eg/g/gsh new file mode 100644 index 0000000..4bc5d87 --- /dev/null +++ b/contrib/perl5/eg/g/gsh @@ -0,0 +1,117 @@ +#! /usr/bin/perl + +# $RCSfile: gsh,v $$Revision: 4.1 $$Date: 92/08/07 17:20:20 $ + +# Do rsh globally--see man page + +$SIG{'QUIT'} = 'quit'; # install signal handler for SIGQUIT + +sub getswitches { + while ($ARGV[0] =~ /^-/) { # parse switches + $ARGV[0] =~ /^-h/ && ($showhost++,$silent++,shift(@ARGV),next); + $ARGV[0] =~ /^-s/ && ($silent++,shift(@ARGV),next); + $ARGV[0] =~ /^-d/ && ($dodist++,shift(@ARGV),next); + $ARGV[0] =~ /^-n/ && ($n=' -n',shift(@ARGV),next); + $ARGV[0] =~ /^-l/ && ($l=' -l ' . $ARGV[1],shift(@ARGV),shift(@ARGV), + next); + last; + } +} + +do getswitches(); # get any switches before class +$systype = shift; # get name representing set of hosts +do getswitches(); # same switches allowed after class + +if ($dodist) { # distribute input over all rshes? + `cat >/tmp/gsh$$`; # get input into a handy place + $dist = " </tmp/gsh$$"; # each rsh takes input from there +} + +$cmd = join(' ',@ARGV); # remaining args constitute the command +$cmd =~ s/'/'"'"'/g; # quote any embedded single quotes + +$one_of_these = ":$systype:"; # prepare to expand "macros" +$one_of_these =~ s/\+/:/g; # we hope to end up with list of +$one_of_these =~ s/-/:-/g; # colon separated attributes + +@ARGV = (); +push(@ARGV,'.grem') if -f '.grem'; +push(@ARGV,'.ghosts') if -f '.ghosts'; +push(@ARGV,'/etc/ghosts'); + +$remainder = ''; + +line: while (<>) { # for each line of ghosts + + s/[ \t]*\n//; # trim trailing whitespace + if (!$_ || /^#/) { # skip blank line or comment + next line; + } + + if (/^(\w+)=(.+)/) { # a macro line? + $name = $1; $repl = $2; + $repl =~ s/\+/:/g; + $repl =~ s/-/:-/g; + $one_of_these =~ s/:$name:/:$repl:/; # do expansion in "wanted" list + $repl =~ s/:/:-/g; + $one_of_these =~ s/:-$name:/:-$repl:/; + next line; + } + + # we have a normal line + + @attr = split(' '); # a list of attributes to match against + # which we put into an array + $host = $attr[0]; # the first attribute is the host name + if ($showhost) { + $showhost = "$host:\t"; + } + + $wanted = 0; + foreach $attr (@attr) { # iterate over attribute array + $wanted++ if index($one_of_these,":$attr:") >= 0; + $wanted = -9999 if index($one_of_these,":-$attr:") >= 0; + } + if ($wanted > 0) { + print "rsh $host$l$n '$cmd'\n" unless $silent; + $SIG{'INT'} = 'DEFAULT'; + if (open(PIPE,"rsh $host$l$n '$cmd'$dist 2>&1|")) { # start an rsh + $SIG{'INT'} = 'cont'; + for ($iter=0; <PIPE>; $iter++) { + unless ($iter) { + $remainder .= "$host+" + if /Connection timed out|Permission denied/; + } + print $showhost,$_; + } + close(PIPE); + } else { + print "(Can't execute rsh: $!)\n"; + $SIG{'INT'} = 'cont'; + } + } +} + +unlink "/tmp/gsh$$" if $dodist; + +if ($remainder) { + chop($remainder); + open(grem,">.grem") || (printf stderr "Can't make a .grem file: $!\n"); + print grem 'rem=', $remainder, "\n"; + close(grem); + print 'rem=', $remainder, "\n"; +} + +# here are a couple of subroutines that serve as signal handlers + +sub cont { + print "\rContinuing...\n"; + $remainder .= "$host+"; +} + +sub quit { + $| = 1; + print "\r"; + $SIG{'INT'} = ''; + kill 2, $$; +} diff --git a/contrib/perl5/eg/g/gsh.man b/contrib/perl5/eg/g/gsh.man new file mode 100644 index 0000000..2958707 --- /dev/null +++ b/contrib/perl5/eg/g/gsh.man @@ -0,0 +1,80 @@ +.\" $RCSfile: gsh.man,v $$Revision: 4.1 $$Date: 92/08/07 17:20:22 $ +.TH GSH 8 "13 May 1988" +.SH NAME +gsh \- global shell +.SH SYNOPSIS +.B gsh +[options] +.I host +[options] +.I command +.SH DESCRIPTION +.I gsh +works just like rsh(1C) except that you may specify a set of hosts to execute +the command on. +The host sets are defined in the file /etc/ghosts. +(An individual host name can be used as a set containing one member.) +You can give a command like + + gsh sun /etc/mungmotd + +to run /etc/mungmotd on all your Suns. +.P +You may specify the union of two or more sets by using + as follows: + + gsh 750+mc /etc/mungmotd + +which will run mungmotd on all 750's and Masscomps. +.P +Commonly used sets should be defined in /etc/ghosts. +For example, you could add a line that says + + pep=manny+moe+jack + +Another way to do that would be to add the word "pep" after each of the host +entries: + + manny sun3 pep +.br + moe sun3 pep +.br + jack sun3 pep + +Hosts and sets of host can also be excluded: + + foo=sun-sun2 + +Any host so excluded will never be included, even if a subsequent set on the +line includes it: + + foo=abc+def + bar=xyz-abc+foo + +comes out to xyz+def. + +You can define private host sets by creating .ghosts in your current directory +with entries just like /etc/ghosts. +Also, if there is a file .grem, it defines "rem" to be the remaining hosts +from the last gsh or gcp that didn't succeed everywhere. + +Options include all those defined by rsh, as well as + +.IP "\-d" 8 +Causes gsh to collect input till end of file, and then distribute that input +to each invokation of rsh. +.IP "\-h" 8 +Rather than print out the command followed by the output, merely prepends the +host name to each line of output. +.IP "\-s" 8 +Do work silently. +.PP +Interrupting with a SIGINT will cause the rsh to the current host to be skipped +and execution resumed with the next host. +To stop completely, send a SIGQUIT. +.SH SEE ALSO +rsh(1C) +.SH BUGS +All the bugs of rsh, since it calls rsh. + +Also, will not properly return data from the remote execution that contains +null characters. diff --git a/contrib/perl5/eg/muck b/contrib/perl5/eg/muck new file mode 100644 index 0000000..873539b --- /dev/null +++ b/contrib/perl5/eg/muck @@ -0,0 +1,141 @@ +#!../perl + +$M = '-M'; +$M = '-m' if -d '/usr/uts' && -f '/etc/master'; + +do 'getopt.pl'; +do Getopt('f'); + +if ($opt_f) { + $makefile = $opt_f; +} +elsif (-f 'makefile') { + $makefile = 'makefile'; +} +elsif (-f 'Makefile') { + $makefile = 'Makefile'; +} +else { + die "No makefile\n"; +} + +$MF = 'mf00'; + +while(($key,$val) = each(ENV)) { + $mac{$key} = $val; +} + +do scan($makefile); + +$co = $action{'.c.o'}; +$co = ' ' unless $co; + +$missing = "Missing dependencies:\n"; +foreach $key (sort keys(o)) { + if ($oc{$key}) { + $src = $oc{$key}; + $action = $action{$key}; + } + else { + $action = ''; + } + if (!$action) { + if ($co && ($c = $key) =~ s/\.o$/.c/ && -f $c) { + $src = $c; + $action = $co; + } + else { + print "No source found for $key $c\n"; + next; + } + } + $I = ''; + $D = ''; + $I .= $1 while $action =~ s/(-I\S+\s*)//; + $D .= $1 . ' ' while $action =~ s/(-D\w+)//; + if ($opt_v) { + $cmd = "Checking $key: cc $M $D $I $src"; + $cmd =~ s/\s\s+/ /g; + print stderr $cmd,"\n"; + } + open(CPP,"cc $M $D $I $src|") || die "Can't run C preprocessor: $!"; + while (<CPP>) { + ($name,$dep) = split; + $dep =~ s|^\./||; + (print $missing,"$key: $dep\n"),($missing='') + unless ($dep{"$key: $dep"} += 2) > 2; + } +} + +$extra = "\nExtraneous dependencies:\n"; +foreach $key (sort keys(dep)) { + if ($key =~ /\.o: .*\.h$/ && $dep{$key} == 1) { + print $extra,$key,"\n"; + $extra = ''; + } +} + +sub scan { + local($makefile) = @_; + local($MF) = $MF; + print stderr "Analyzing $makefile.\n" if $opt_v; + $MF++; + open($MF,$makefile) || die "Can't open $makefile: $!"; + while (<$MF>) { + chop; + chop($_ = $_ . <$MF>) while s/\\$//; + next if /^#/; + next if /^$/; + s/\$\((\w+):([^=)]*)=([^)]*)\)/do subst("$1","$2","$3")/eg; + s/\$\((\w+)\)/$mac{$1}/eg; + $mac{$1} = $2, next if /^(\w+)\s*=\s*(.*)/; + if (/^include\s+(.*)/) { + do scan($1); + print stderr "Continuing $makefile.\n" if $opt_v; + next; + } + if (/^([^:]+):\s*(.*)/) { + $left = $1; + $right = $2; + if ($right =~ /^([^;]*);(.*)/) { + $right = $1; + $action = $2; + } + else { + $action = ''; + } + while (<$MF>) { + last unless /^\t/; + chop; + chop($_ = $_ . <$MF>) while s/\\$//; + next if /^#/; + last if /^$/; + s/\$\((\w+):([^=)]*)=([^)]*)\)/do subst("$1","$2","$3")/eg; + s/\$\((\w+)\)/$mac{$1}/eg; + $action .= $_; + } + foreach $targ (split(' ',$left)) { + $targ =~ s|^\./||; + foreach $src (split(' ',$right)) { + $src =~ s|^\./||; + $deplist{$targ} .= ' ' . $src; + $dep{"$targ: $src"} = 1; + $o{$src} = 1 if $src =~ /\.o$/; + $oc{$targ} = $src if $targ =~ /\.o$/ && $src =~ /\.[yc]$/; + } + $action{$targ} .= $action; + } + redo if $_; + } + } + close($MF); +} + +sub subst { + local($foo,$from,$to) = @_; + $foo = $mac{$foo}; + $from =~ s/\./[.]/; + y/a/a/; + $foo =~ s/\b$from\b/$to/g; + $foo; +} diff --git a/contrib/perl5/eg/muck.man b/contrib/perl5/eg/muck.man new file mode 100644 index 0000000..02ae428 --- /dev/null +++ b/contrib/perl5/eg/muck.man @@ -0,0 +1,21 @@ +.\" $RCSfile: muck.man,v $$Revision: 4.1 $$Date: 92/08/07 17:20:23 $ +.TH MUCK 1 "10 Jan 1989" +.SH NAME +muck \- make usage checker +.SH SYNOPSIS +.B muck +[options] +.SH DESCRIPTION +.I muck +looks at your current makefile and complains if you've left out any dependencies +between .o and .h files. +It also complains about extraneous dependencies. +.PP +You can use the -f FILENAME option to specify an alternate name for your +makefile. +The -v option is a little more verbose about what muck is mucking around +with at the moment. +.SH SEE ALSO +make(1) +.SH BUGS +Only knows about .h, .c and .o files. diff --git a/contrib/perl5/eg/myrup b/contrib/perl5/eg/myrup new file mode 100644 index 0000000..2cbdf75 --- /dev/null +++ b/contrib/perl5/eg/myrup @@ -0,0 +1,29 @@ +#!/usr/bin/perl + +# $RCSfile: myrup,v $$Revision: 4.1 $$Date: 92/08/07 17:20:26 $ + +# This was a customization of ruptime requested by someone here who wanted +# to be able to find the least loaded machine easily. It uses the +# /etc/ghosts file that's defined for gsh and gcp to prune down the +# number of entries to those hosts we have administrative control over. + +print "node load (u)\n------- --------\n"; + +open(ghosts,'/etc/ghosts') || die "Can't open /etc/ghosts: $!"; +line: while (<ghosts>) { + next line if /^#/; + next line if /^$/; + next line if /=/; + ($host) = split; + $wanted{$host} = 1; +} + +open(ruptime,'ruptime|') || die "Can't run ruptime: $!"; +open(sort,'|sort +1n'); + +while (<ruptime>) { + ($host,$upness,$foo,$users,$foo,$foo,$load) = split(/[\s,]+/); + if ($wanted{$host} && $upness eq 'up') { + printf sort "%s\t%s (%d)\n", $host, $load, $users; + } +} diff --git a/contrib/perl5/eg/nih b/contrib/perl5/eg/nih new file mode 100644 index 0000000..4475c49 --- /dev/null +++ b/contrib/perl5/eg/nih @@ -0,0 +1,11 @@ +eval 'exec /usr/bin/perl -Spi.bak $0 ${1+"$@"}' + if $running_under_some_shell; + +# $RCSfile: nih,v $$Revision: 4.1 $$Date: 92/08/07 17:20:27 $ + +# This script makes #! scripts directly executable on machines that don't +# support #!. It edits in place any scripts mentioned on the command line. + +s[^#!(.*)] + [#!$1\neval 'exec $1 -S \$0 \${1+"\$@"}'\n\tif \$running_under_some_shell;] + if $. == 1; diff --git a/contrib/perl5/eg/relink b/contrib/perl5/eg/relink new file mode 100644 index 0000000..2c5793f --- /dev/null +++ b/contrib/perl5/eg/relink @@ -0,0 +1,82 @@ +#!/usr/bin/perl +'di'; +'ig00'; +# +# $RCSfile: relink,v $$Revision: 4.1 $$Date: 92/08/07 17:20:29 $ +# +# $Log: relink,v $ + +($op = shift) || die "Usage: relink perlexpr [filenames]\n"; +if (!@ARGV) { + @ARGV = <STDIN>; + chop(@ARGV); +} +for (@ARGV) { + next unless -l; # symbolic link? + $name = $_; + $_ = readlink($_); + $was = $_; + eval $op; + die $@ if $@; + if ($was ne $_) { + unlink($name); + symlink($_, $name); + } +} +############################################################################## + + # These next few lines are legal in both Perl and nroff. + +.00; # finish .ig + +'di \" finish diversion--previous line must be blank +.nr nl 0-1 \" fake up transition to first page again +.nr % 0 \" start at page 1 +';<<'.ex'; #__END__ ############# From here on it's a standard manual page ############ +.TH RELINK 1 "July 30, 1990" +.AT 3 +.SH LINK +relink \- relinks multiple symbolic links +.SH SYNOPSIS +.B relink perlexpr [symlinknames] +.SH DESCRIPTION +.I Relink +relinks the symbolic links given according to the rule specified as the +first argument. +The argument is a Perl expression which is expected to modify the $_ +string in Perl for at least some of the names specified. +For each symbolic link named on the command line, the Perl expression +will be executed on the contents of the symbolic link with that name. +If a given symbolic link's contents is not modified by the expression, +it will not be changed. +If a name given on the command line is not a symbolic link, it will be ignored. +If no names are given on the command line, names will be read +via standard input. +.PP +For example, to relink all symbolic links in the current directory +pointing to somewhere in X11R3 so that they point to X11R4, you might say +.nf + + relink 's/X11R3/X11R4/' * + +.fi +To change all occurences of links in the system from /usr/spool to /var/spool, +you'd say +.nf + + find / -type l -print | relink 's#/usr/spool#/var/spool#' + +.fi +.SH ENVIRONMENT +No environment variables are used. +.SH FILES +.SH AUTHOR +Larry Wall +.SH "SEE ALSO" +ln(1) +.br +perl(1) +.SH DIAGNOSTICS +If you give an invalid Perl expression you'll get a syntax error. +.SH BUGS +.ex diff --git a/contrib/perl5/eg/rename b/contrib/perl5/eg/rename new file mode 100755 index 0000000..10e97f7 --- /dev/null +++ b/contrib/perl5/eg/rename @@ -0,0 +1,74 @@ +#!/usr/bin/perl +'di'; +'ig00'; +# +# $RCSfile: rename,v $$Revision: 4.1 $$Date: 92/08/07 17:20:30 $ +# +# $Log: rename,v $ + +($op = shift) || die "Usage: rename perlexpr [filenames]\n"; +if (!@ARGV) { + @ARGV = <STDIN>; + chop(@ARGV); +} +for (@ARGV) { + $was = $_; + eval $op; + die $@ if $@; + rename($was,$_) unless $was eq $_; +} +############################################################################## + + # These next few lines are legal in both Perl and nroff. + +.00; # finish .ig + +'di \" finish diversion--previous line must be blank +.nr nl 0-1 \" fake up transition to first page again +.nr % 0 \" start at page 1 +';<<'.ex'; #__END__ ############# From here on it's a standard manual page ############ +.TH RENAME 1 "July 30, 1990" +.AT 3 +.SH NAME +rename \- renames multiple files +.SH SYNOPSIS +.B rename perlexpr [files] +.SH DESCRIPTION +.I Rename +renames the filenames supplied according to the rule specified as the +first argument. +The argument is a Perl expression which is expected to modify the $_ +string in Perl for at least some of the filenames specified. +If a given filename is not modified by the expression, it will not be +renamed. +If no filenames are given on the command line, filenames will be read +via standard input. +.PP +For example, to rename all files matching *.bak to strip the extension, +you might say +.nf + + rename 's/\e.bak$//' *.bak + +.fi +To translate uppercase names to lower, you'd use +.nf + + rename 'y/A-Z/a-z/' * + +.fi +.SH ENVIRONMENT +No environment variables are used. +.SH FILES +.SH AUTHOR +Larry Wall +.SH "SEE ALSO" +mv(1) +.br +perl(1) +.SH DIAGNOSTICS +If you give an invalid Perl expression you'll get a syntax error. +.SH BUGS +.I Rename +does not check for the existence of target filenames, so use with care. +.ex diff --git a/contrib/perl5/eg/rmfrom b/contrib/perl5/eg/rmfrom new file mode 100644 index 0000000..7178e77 --- /dev/null +++ b/contrib/perl5/eg/rmfrom @@ -0,0 +1,7 @@ +#!/usr/bin/perl -n + +# $RCSfile: rmfrom,v $$Revision: 4.1 $$Date: 92/08/07 17:20:31 $ + +# A handy (but dangerous) script to put after a find ... -print. + +chop; unlink; diff --git a/contrib/perl5/eg/scan/scan_df b/contrib/perl5/eg/scan/scan_df new file mode 100644 index 0000000..c221cdc --- /dev/null +++ b/contrib/perl5/eg/scan/scan_df @@ -0,0 +1,51 @@ +#!/usr/bin/perl -P + +# $RCSfile: scan_df,v $$Revision: 4.1 $$Date: 92/08/07 17:20:33 $ + +# This report points out filesystems that are in danger of overflowing. + +(chdir '/usr/adm/private/memories') || die "Can't cd to memories: $!\n"; +`df >newdf`; +open(Df, 'olddf'); + +while (<Df>) { + ($fs,$kbytes,$used,$avail,$capacity,$mounted_on) = split; + next if $fs =~ /:/; + next if $fs eq ''; + $oldused{$fs} = $used; +} + +open(Df, 'newdf') || die "scan_df: can't open newdf"; + +while (<Df>) { + ($fs,$kbytes,$used,$avail,$capacity,$mounted_on) = split; + next if $fs =~ /:/; + next if $fs eq ''; + $oldused = $oldused{$fs}; + next if ($oldused == $used && $capacity < 99); # inactive filesystem + if ($capacity >= 90) { +#if defined(mc300) || defined(mc500) || defined(mc700) + $_ = substr($_,0,13) . ' ' . substr($_,13,1000); + $kbytes /= 2; # translate blocks to K + $used /= 2; + $oldused /= 2; + $avail /= 2; +#endif + $diff = int($used - $oldused); + if ($avail < $diff * 2) { # mark specially if in danger + $mounted_on .= ' *'; + } + next if $diff < 50 && $mounted_on eq '/'; + $fs =~ s|/dev/||; + if ($diff >= 0) { + $diff = '(+' . $diff . ')'; + } + else { + $diff = '(' . $diff . ')'; + } + printf "%-8s%8d%8d %-8s%8d%7s %s\n", + $fs,$kbytes,$used,$diff,$avail,$capacity,$mounted_on; + } +} + +rename('newdf','olddf'); diff --git a/contrib/perl5/eg/scan/scan_last b/contrib/perl5/eg/scan/scan_last new file mode 100644 index 0000000..4d15ca0 --- /dev/null +++ b/contrib/perl5/eg/scan/scan_last @@ -0,0 +1,57 @@ +#!/usr/bin/perl -P + +# $RCSfile: scan_last,v $$Revision: 4.1 $$Date: 92/08/07 17:20:35 $ + +# This reports who was logged on at weird hours + +($dy, $mo, $lastdt) = split(/ +/,`date`); + +open(Last, 'exec last 2>&1 |') || die "scan_last: can't run last"; + +while (<Last>) { +#if defined(mc300) || defined(mc500) || defined(mc700) + $_ = substr($_,0,19) . substr($_,23,100); +#endif + next if /^$/; + (print),next if m|^/|; + $login = substr($_,0,8); + $tty = substr($_,10,7); + $from = substr($_,19,15); + $day = substr($_,36,3); + $mo = substr($_,40,3); + $dt = substr($_,44,2); + $hr = substr($_,47,2); + $min = substr($_,50,2); + $dash = substr($_,53,1); + $tohr = substr($_,55,2); + $tomin = substr($_,58,2); + $durhr = substr($_,63,2); + $durmin = substr($_,66,2); + + next unless $hr; + next if $login eq 'reboot '; + next if $login eq 'shutdown'; + + if ($dt != $lastdt) { + if ($lastdt < $dt) { + $seen += $dt - $lastdt; + } + else { + $seen++; + } + $lastdt = $dt; + } + + $inat = $hr + $min / 60; + if ($tohr =~ /^[a-z]/) { + $outat = 12; # something innocuous + } else { + $outat = $tohr + $tomin / 60; + } + + last if $seen + ($inat < 8) > 1; + + if ($inat < 5 || $inat > 21 || $outat < 6 || $outat > 23) { + print; + } +} diff --git a/contrib/perl5/eg/scan/scan_messages b/contrib/perl5/eg/scan/scan_messages new file mode 100644 index 0000000..6cf0997 --- /dev/null +++ b/contrib/perl5/eg/scan/scan_messages @@ -0,0 +1,222 @@ +#!/usr/bin/perl -P + +# $RCSfile: scan_messages,v $$Revision: 4.1 $$Date: 92/08/07 17:20:37 $ + +# This prints out extraordinary console messages. You'll need to customize. + +chdir('/usr/adm/private/memories') || die "Can't cd to memories: $!\n"; + +$maxpos = `cat oldmsgs 2>&1`; + +#if defined(mc300) || defined(mc500) || defined(mc700) +open(Msgs, '/dev/null') || die "scan_messages: can't open messages"; +#else +open(Msgs, '/usr/adm/messages') || die "scan_messages: can't open messages"; +#endif + +($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, + $blksize,$blocks) = stat(Msgs); + +if ($size < $maxpos) { # Did somebody truncate messages file? + $maxpos = 0; +} + +seek(Msgs,$maxpos,0); # Start where we left off last time. + +while (<Msgs>) { + s/\[(\d+)\]/#/ && s/$1/#/g; +#ifdef vax + $_ =~ s/[A-Z][a-z][a-z] +\w+ +[0-9:]+ +\w+ +//; + next if /root@.*:/; + next if /^vmunix: 4.3 BSD UNIX/; + next if /^vmunix: Copyright/; + next if /^vmunix: avail mem =/; + next if /^vmunix: SBIA0 at /; + next if /^vmunix: disk ra81 is/; + next if /^vmunix: dmf. at uba/; + next if /^vmunix: dmf.:.*asynch/; + next if /^vmunix: ex. at uba/; + next if /^vmunix: ex.: HW/; + next if /^vmunix: il. at uba/; + next if /^vmunix: il.: hardware/; + next if /^vmunix: ra. at uba/; + next if /^vmunix: ra.: media/; + next if /^vmunix: real mem/; + next if /^vmunix: syncing disks/; + next if /^vmunix: tms/; + next if /^vmunix: tmscp. at uba/; + next if /^vmunix: uba. at /; + next if /^vmunix: uda. at /; + next if /^vmunix: uda.: unit . ONLIN/; + next if /^vmunix: .*buffers containing/; + next if /^syslogd: .*newslog/; +#endif + next if /unknown service/; + next if /^\.\.\.$/; + if (/^[A-Z][a-z][a-z] [ 0-9][0-9] [ 0-9][0-9]:[0-9][0-9]/) { + $pfx = ''; + next; + } + next if /^[ \t]*$/; + next if /^[ 0-9]*done$/; + if (/^A/) { + next if /^Accounting [sr]/; + } + elsif (/^C/) { + next if /^Called from/; + next if /^Copyright/; + } + elsif (/^E/) { + next if /^End traceback/; + next if /^Ethernet address =/; + } + elsif (/^K/) { + next if /^KERNEL MODE/; + } + elsif (/^R/) { + next if /^Rebooting Unix/; + } + elsif (/^S/) { + next if /^Sun UNIX 4\.2 Release/; + } + elsif (/^W/) { + next if /^WARNING: clock gained/; + } + elsif (/^a/) { + next if /^arg /; + next if /^avail mem =/; + } + elsif (/^b/) { + next if /^bwtwo[0-9] at /; + } + elsif (/^c/) { + next if /^cgone[0-9] at /; + next if /^cdp[0-9] at /; + next if /^csr /; + } + elsif (/^d/) { + next if /^dcpa: init/; + next if /^done$/; + next if /^dts/; + next if /^dump i\/o error/; + next if /^dumping to dev/; + next if /^dump succeeded/; + $pfx = '*' if /^dev = /; + } + elsif (/^e/) { + next if /^end \*\*/; + next if /^error in copy/; + } + elsif (/^f/) { + next if /^found /; + } + elsif (/^i/) { + next if /^ib[0-9] at /; + next if /^ie[0-9] at /; + } + elsif (/^l/) { + next if /^le[0-9] at /; + } + elsif (/^m/) { + next if /^mem = /; + next if /^mt[0-9] at /; + next if /^mti[0-9] at /; + $pfx = '*' if /^mode = /; + } + elsif (/^n/) { + next if /^not found /; + } + elsif (/^p/) { + next if /^page map /; + next if /^pi[0-9] at /; + $pfx = '*' if /^panic/; + } + elsif (/^q/) { + next if /^qqq /; + } + elsif (/^r/) { + next if /^read /; + next if /^revarp: Requesting/; + next if /^root [od]/; + } + elsif (/^s/) { + next if /^sc[0-9] at /; + next if /^sd[0-9] at /; + next if /^sd[0-9]: </; + next if /^si[0-9] at /; + next if /^si_getstatus/; + next if /^sk[0-9] at /; + next if /^skioctl/; + next if /^skopen/; + next if /^skprobe/; + next if /^skread/; + next if /^skwrite/; + next if /^sky[0-9] at /; + next if /^st[0-9] at /; + next if /^st0:.*load/; + next if /^stat1 = /; + next if /^syncing disks/; + next if /^syslogd: going down on signal 15/; + } + elsif (/^t/) { + next if /^timeout [0-9]/; + next if /^tm[0-9] at /; + next if /^tod[0-9] at /; + next if /^tv [0-9]/; + $pfx = '*' if /^trap address/; + } + elsif (/^u/) { + next if /^unit nsk/; + next if /^use one of/; + $pfx = '' if /^using/; + next if /^using [0-9]+ buffers/; + } + elsif (/^x/) { + next if /^xy[0-9] at /; + next if /^write [0-9]/; + next if /^xy[0-9]: </; + next if /^xyc[0-9] at /; + } + elsif (/^y/) { + next if /^yyy [0-9]/; + } + elsif (/^z/) { + next if /^zs[0-9] at /; + } + $pfx = '*' if /^[a-z]+:$/; + s/pid [0-9]+: //; + if (/last message repeated ([0-9]+) time/) { + $seen{$last} += $1; + next; + } + s/^/$pfx/ if $pfx; + unless ($seen{$_}++) { + push(@seen,$_); + } + $last = $_; +} +$max = tell(Msgs); + +open(tmp,'|sort >oldmsgs.tmp') || die "Can't create tmp file: $!\n"; +while ($_ = pop(@seen)) { + print tmp $_; +} +close(tmp); +open(tmp,'oldmsgs.tmp') || die "Can't reopen tmp file: $!\n"; +while (<tmp>) { + if (/^nd:/) { + next if $seen{$_} < 20; + } + if (/NFS/) { + next if $seen{$_} < 20; + } + if (/no carrier/) { + next if $seen{$_} < 20; + } + if (/silo overflow/) { + next if $seen{$_} < 20; + } + print $seen{$_},":\t",$_; +} + +print `rm -f oldmsgs.tmp 2>&1; echo $max > oldmsgs 2>&1`; diff --git a/contrib/perl5/eg/scan/scan_passwd b/contrib/perl5/eg/scan/scan_passwd new file mode 100644 index 0000000..50f6fc8 --- /dev/null +++ b/contrib/perl5/eg/scan/scan_passwd @@ -0,0 +1,30 @@ +#!/usr/bin/perl + +# $RCSfile: scan_passwd,v $$Revision: 4.1 $$Date: 92/08/07 17:20:38 $ + +# This scans passwd file for security holes. + +open(Pass,'/etc/passwd') || die "Can't open passwd file: $!\n"; +# $dotriv = (`date` =~ /^Mon/); +$dotriv = 1; + +while (<Pass>) { + ($login,$pass,$uid,$gid,$gcos,$home,$shell) = split(/:/); + if ($shell eq '') { + print "Short: $_"; + } + next if /^[+]/; + if ($pass eq '') { + if (index(":sync:lpq:+:", ":$login:") < 0) { + print "No pass: $login\t$gcos\n"; + } + } + elsif ($dotriv && crypt($login,substr($pass,0,2)) eq $pass) { + print "Trivial: $login\t$gcos\n"; + } + if ($uid == 0) { + if ($login !~ /^.?root$/ && $pass ne '*') { + print "Extra root: $_"; + } + } +} diff --git a/contrib/perl5/eg/scan/scan_ps b/contrib/perl5/eg/scan/scan_ps new file mode 100644 index 0000000..18b5cb2 --- /dev/null +++ b/contrib/perl5/eg/scan/scan_ps @@ -0,0 +1,32 @@ +#!/usr/bin/perl -P + +# $RCSfile: scan_ps,v $$Revision: 4.1 $$Date: 92/08/07 17:20:40 $ + +# This looks for looping processes. + +#if defined(mc300) || defined(mc500) || defined(mc700) +open(Ps, '/bin/ps -el|') || die "scan_ps: can't run ps"; + +while (<Ps>) { + next if /rwhod/; + print if index(' T', substr($_,62,1)) < 0; +} +#else +open(Ps, '/bin/ps auxww|') || die "scan_ps: can't run ps"; + +while (<Ps>) { + next if /dataserver/; + next if /nfsd/; + next if /update/; + next if /ypserv/; + next if /rwhod/; + next if /routed/; + next if /pagedaemon/; +#ifdef vax + ($user,$pid,$cpu,$mem,$sz,$rss,$tt,$stat,$start,$time) = split; +#else + ($user,$pid,$cpu,$mem,$sz,$rss,$tt,$stat,$time) = split; +#endif + print if length($time) > 4; +} +#endif diff --git a/contrib/perl5/eg/scan/scan_sudo b/contrib/perl5/eg/scan/scan_sudo new file mode 100644 index 0000000..5b143e9 --- /dev/null +++ b/contrib/perl5/eg/scan/scan_sudo @@ -0,0 +1,54 @@ +#!/usr/bin/perl -P + +# $RCSfile: scan_sudo,v $$Revision: 4.1 $$Date: 92/08/07 17:20:42 $ + +# Analyze the sudo log. + +chdir('/usr/adm/private/memories') || die "Can't cd to memories: $!\n"; + +if (open(Oldsudo,'oldsudo')) { + $maxpos = <Oldsudo>; + close Oldsudo; +} +else { + $maxpos = 0; + `echo 0 >oldsudo`; +} + +unless (open(Sudo, '/usr/adm/sudo.log')) { + print "Somebody removed sudo.log!!!\n" if $maxpos; + exit 0; +} + +($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, + $blksize,$blocks) = stat(Sudo); + +if ($size < $maxpos) { + $maxpos = 0; + print "Somebody reset sudo.log!!!\n"; +} + +seek(Sudo,$maxpos,0); + +while (<Sudo>) { + s/^.* :[ \t]+//; + s/ipcrm.*/ipcrm/; + s/kill.*/kill/; + unless ($seen{$_}++) { + push(@seen,$_); + } + $last = $_; +} +$max = tell(Sudo); + +open(tmp,'|sort >oldsudo.tmp') || die "Can't create tmp file: $!\n"; +while ($_ = pop(@seen)) { + print tmp $_; +} +close(tmp); +open(tmp,'oldsudo.tmp') || die "Can't reopen tmp file: $!\n"; +while (<tmp>) { + print $seen{$_},":\t",$_; +} + +print `(rm -f oldsudo.tmp; echo $max > oldsudo) 2>&1`; diff --git a/contrib/perl5/eg/scan/scan_suid b/contrib/perl5/eg/scan/scan_suid new file mode 100644 index 0000000..c10aa58 --- /dev/null +++ b/contrib/perl5/eg/scan/scan_suid @@ -0,0 +1,84 @@ +#!/usr/bin/perl -P + +# $RCSfile: scan_suid,v $$Revision: 4.1 $$Date: 92/08/07 17:20:43 $ + +# Look for new setuid root files. + +chdir '/usr/adm/private/memories' || die "Can't cd to memories: $!\n"; + +($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, + $blksize,$blocks) = stat('oldsuid'); +if ($nlink) { + $lasttime = $mtime; + $tmp = $ctime - $atime; + if ($tmp <= 0 || $tmp >= 10) { + print "WARNING: somebody has read oldsuid!\n"; + } + $tmp = $ctime - $mtime; + if ($tmp <= 0 || $tmp >= 10) { + print "WARNING: somebody has modified oldsuid!!!\n"; + } +} else { + $lasttime = time - 60 * 60 * 24; # one day ago +} +$thistime = time; + +#if defined(mc300) || defined(mc500) || defined(mc700) +open(Find, 'find / -perm -04000 -print |') || + die "scan_find: can't run find"; +#else +open(Find, 'find / \( -fstype nfs -prune \) -o -perm -04000 -ls |') || + die "scan_find: can't run find"; +#endif + +open(suid, '>newsuid.tmp'); + +while (<Find>) { + +#if defined(mc300) || defined(mc500) || defined(mc700) + $x = `/bin/ls -il $_`; + $_ = $x; + s/^ *//; + ($inode,$perm,$links,$owner,$group,$size,$month,$day,$time,$name) + = split; +#else + s/^ *//; + ($inode,$blocks,$perm,$links,$owner,$group,$size,$month,$day,$time,$name) + = split; +#endif + + if ($perm =~ /[sS]/ && $owner eq 'root') { + ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, + $blksize,$blocks) = stat($name); + $foo = sprintf("%10s%3s %-8s %-8s%9s %3s %2s %s %s\n", + $perm,$links,$owner,$group,$size,$month,$day,$name,$inode); + print suid $foo; + if ($ctime > $lasttime) { + if ($ctime > $thistime) { + print "Future file: $foo"; + } + else { + $ct .= $foo; + } + } + } +} +close(suid); + +print `sort +7 -8 newsuid.tmp >newsuid 2>&1`; +$foo = `/bin/diff oldsuid newsuid 2>&1`; +print "Differences in suid info:\n",$foo if $foo; +print `mv oldsuid oldoldsuid 2>&1; mv newsuid oldsuid 2>&1`; +print `touch oldsuid 2>&1;sleep 2 2>&1;chmod o+w oldsuid 2>&1`; +print `rm -f newsuid.tmp 2>&1`; + +@ct = split(/\n/,$ct); +$ct = ''; +$* = 1; +while ($#ct >= 0) { + $tmp = shift(@ct); + unless ($foo =~ "^>.*$tmp\n") { $ct .= "$tmp\n"; } +} + +print "Inode changed since last time:\n",$ct if $ct; + diff --git a/contrib/perl5/eg/scan/scanner b/contrib/perl5/eg/scan/scanner new file mode 100644 index 0000000..e73cdc8 --- /dev/null +++ b/contrib/perl5/eg/scan/scanner @@ -0,0 +1,87 @@ +#!/usr/bin/perl + +# $RCSfile: scanner,v $$Revision: 4.1 $$Date: 92/08/07 17:20:44 $ + +# This runs all the scan_* routines on all the machines in /etc/ghosts. +# We run this every morning at about 6 am: + +# !/bin/sh +# cd /usr/adm/private +# decrypt scanner | perl >scan.out 2>&1 +# mail admin <scan.out + +# Note that the scan_* files should be encrypted with the key "-inquire", and +# scanner should be encrypted somehow so that people can't find that key. +# I leave it up to you to figure out how to unencrypt it before executing. + +$ENV{'PATH'} = '/bin:/usr/bin:/usr/local/bin:/usr/ucb:.'; + +$| = 1; # command buffering on stdout + +print "Subject: bizarre happenings\n\n"; + +(chdir '/usr/adm/private') || die "Can't cd to /usr/adm/private: $!\n"; + +if ($#ARGV >= 0) { + @scanlist = @ARGV; +} else { + @scanlist = split(/[ \t\n]+/,`echo scan_*`); +} + +scan: while ($scan = shift(@scanlist)) { + print "\n********** $scan **********\n"; + $showhost++; + + $systype = 'all'; + + open(ghosts, '/etc/ghosts') || die 'No /etc/ghosts file'; + + $one_of_these = ":$systype:"; + if ($systype =~ s/\+/[+]/g) { + $one_of_these =~ s/\+/:/g; + } + + line: while (<ghosts>) { + s/[ \t]*\n//; + if (!$_ || /^#/) { + next line; + } + if (/^([a-zA-Z_0-9]+)=(.+)/) { + $name = $1; $repl = $2; + $repl =~ s/\+/:/g; + $one_of_these =~ s/:$name:/:$repl:/; + next line; + } + @gh = split; + $host = $gh[0]; + if ($showhost) { $showhost = "$host:\t"; } + class: while ($class = pop(gh)) { + if (index($one_of_these,":$class:") >=0) { + $iter = 0; + `exec crypt -inquire <$scan >.x 2>/dev/null`; + unless (open(scan,'.x')) { + print "Can't run $scan: $!\n"; + next scan; + } + $cmd = <scan>; + unless ($cmd =~ s/#!(.*)\n/$1/) { + $cmd = '/usr/bin/perl'; + } + close(scan); + if (open(PIPE,"exec rsh $host '$cmd' <.x|")) { + sleep(5); + unlink '.x'; + while (<PIPE>) { + last if $iter++ > 1000; # must be looping + next if /^[0-9.]+u [0-9.]+s/; + print $showhost,$_; + } + close(PIPE); + } else { + print "(Can't execute rsh: $!)\n"; + } + last class; + } + } + } +} diff --git a/contrib/perl5/eg/server b/contrib/perl5/eg/server new file mode 100755 index 0000000..49a140a --- /dev/null +++ b/contrib/perl5/eg/server @@ -0,0 +1,27 @@ +#!./perl + +$pat = 'S n C4 x8'; +$inet = 2; +$echo = 7; +$smtp = 25; +$nntp = 119; + +$this = pack($pat,$inet,2345, 0,0,0,0); +select(NS); $| = 1; select(stdout); + +if (socket(S,2,1,6)) { print "socket ok\n"; } else { die $!; } +if (bind(S,$this)) { print "bind ok\n"; } else { die $!; } +if (listen(S,5)) { print "listen ok\n"; } else { die $!; } +for (;;) { + print "Listening again\n"; + if ($addr = accept(NS,S)) { print "accept ok\n"; } else { die $!; } + + @ary = unpack($pat,$addr); + $, = ' '; + print @ary; print "\n"; + + while (<NS>) { + print; + print NS; + } +} diff --git a/contrib/perl5/eg/shmkill b/contrib/perl5/eg/shmkill new file mode 100644 index 0000000..b91ee6f --- /dev/null +++ b/contrib/perl5/eg/shmkill @@ -0,0 +1,24 @@ +#!/usr/bin/perl + +# $RCSfile: shmkill,v $$Revision: 4.1 $$Date: 92/08/07 17:20:45 $ + +# A script to call from crontab periodically when people are leaving shared +# memory sitting around unattached. + +open(ipcs,'ipcs -m -o|') || die "Can't run ipcs: $!"; + +while (<ipcs>) { + $tmp = index($_,'NATTCH'); + $pos = $tmp if $tmp >= 0; + if (/^m/) { + ($m,$id,$key,$mode,$owner,$group,$attach) = split; + if ($attach != substr($_,$pos,6)) { + die "Different ipcs format--can't parse!\n"; + } + if ($attach == 0) { + push(@goners,'-m',$id); + } + } +} + +exec 'ipcrm', @goners if $#goners >= 0; diff --git a/contrib/perl5/eg/sysvipc/README b/contrib/perl5/eg/sysvipc/README new file mode 100644 index 0000000..54094f1 --- /dev/null +++ b/contrib/perl5/eg/sysvipc/README @@ -0,0 +1,9 @@ +FYEnjoyment, here are the test scripts I used while implementing SysV +IPC in Perl. Each of them must be run with the parameter "s" for +"send" or "r" for "receive"; in each case, the receiver is the server +and the sender is the client. + +-- +Chip Salzenberg at ComDev/TCT <chip@tct.uucp>, <uunet!ateng!tct!chip> + + diff --git a/contrib/perl5/eg/sysvipc/ipcmsg b/contrib/perl5/eg/sysvipc/ipcmsg new file mode 100644 index 0000000..646d8b6 --- /dev/null +++ b/contrib/perl5/eg/sysvipc/ipcmsg @@ -0,0 +1,47 @@ +#!/usr/bin/perl +eval 'exec /usr/bin/perl -S $0 ${1+"$@"}' + if $running_under_some_shell; + +require 'sys/ipc.ph'; +require 'sys/msg.ph'; + +$| = 1; + +$mode = shift; +die "usage: ipcmsg {r|s}\n" unless $mode =~ /^[rs]$/; +$send = ($mode eq "s"); + +$id = msgget(0x1234, ($send ? 0 : &IPC_CREAT) | 0644); +die "Can't get message queue: $!\n" unless defined($id); +print "message queue id: $id\n"; + +if ($send) { + while (<STDIN>) { + chop; + unless (msgsnd($id, pack("LA*", $., $_), 0)) { + die "Can't send message: $!\n"; + } + } +} +else { + $SIG{'INT'} = $SIG{'QUIT'} = "leave"; + for (;;) { + unless (msgrcv($id, $_, 512, 0, 0)) { + die "Can't receive message: $!\n"; + } + ($type, $message) = unpack("La*", $_); + printf "[%d] %s\n", $type, $message; + } +} + +&leave; + +sub leave { + if (!$send) { + $x = msgctl($id, &IPC_RMID, 0); + if (!defined($x) || $x < 0) { + die "Can't remove message queue: $!\n"; + } + } + exit; +} diff --git a/contrib/perl5/eg/sysvipc/ipcsem b/contrib/perl5/eg/sysvipc/ipcsem new file mode 100644 index 0000000..e0dc551 --- /dev/null +++ b/contrib/perl5/eg/sysvipc/ipcsem @@ -0,0 +1,46 @@ +#!/usr/bin/perl +eval 'exec /usr/bin/perl -S $0 ${1+"$@"}' + if $running_under_some_shell; + +require 'sys/ipc.ph'; +require 'sys/msg.ph'; + +$| = 1; + +$mode = shift; +die "usage: ipcmsg {r|s}\n" unless $mode =~ /^[rs]$/; +$signal = ($mode eq "s"); + +$id = semget(0x1234, 1, ($signal ? 0 : &IPC_CREAT) | 0644); +die "Can't get semaphore: $!\n" unless defined($id); +print "semaphore id: $id\n"; + +if ($signal) { + while (<STDIN>) { + print "Signalling\n"; + unless (semop($id, pack("sss", 0, 1, 0))) { + die "Can't signal semaphore: $!\n"; + } + } +} +else { + $SIG{'INT'} = $SIG{'QUIT'} = "leave"; + for (;;) { + unless (semop($id, pack("sss", 0, -1, 0))) { + die "Can't wait for semaphore: $!\n"; + } + print "Unblocked\n"; + } +} + +&leave; + +sub leave { + if (!$signal) { + $x = semctl($id, 0, &IPC_RMID, 0); + if (!defined($x) || $x < 0) { + die "Can't remove semaphore: $!\n"; + } + } + exit; +} diff --git a/contrib/perl5/eg/sysvipc/ipcshm b/contrib/perl5/eg/sysvipc/ipcshm new file mode 100644 index 0000000..ecc1ba4 --- /dev/null +++ b/contrib/perl5/eg/sysvipc/ipcshm @@ -0,0 +1,50 @@ +#!/usr/bin/perl +eval 'exec /usr/bin/perl -S $0 ${1+"$@"}' + if $running_under_some_shell; + +require 'sys/ipc.ph'; +require 'sys/shm.ph'; + +$| = 1; + +$mode = shift; +die "usage: ipcshm {r|s}\n" unless $mode =~ /^[rs]$/; +$send = ($mode eq "s"); + +$SIZE = 32; +$id = shmget(0x1234, $SIZE, ($send ? 0 : &IPC_CREAT) | 0644); +die "Can't get shared memory: $!\n" unless defined($id); +print "shared memory id: $id\n"; + +if ($send) { + while (<STDIN>) { + chop; + unless (shmwrite($id, pack("La*", length($_), $_), 0, $SIZE)) { + die "Can't write to shared memory: $!\n"; + } + } +} +else { + $SIG{'INT'} = $SIG{'QUIT'} = "leave"; + for (;;) { + $_ = <STDIN>; + unless (shmread($id, $_, 0, $SIZE)) { + die "Can't read shared memory: $!\n"; + } + $len = unpack("L", $_); + $message = substr($_, length(pack("L",0)), $len); + printf "[%d] %s\n", $len, $message; + } +} + +&leave; + +sub leave { + if (!$send) { + $x = shmctl($id, &IPC_RMID, 0); + if (!defined($x) || $x < 0) { + die "Can't remove shared memory: $!\n"; + } + } + exit; +} diff --git a/contrib/perl5/eg/travesty b/contrib/perl5/eg/travesty new file mode 100644 index 0000000..7e6f983 --- /dev/null +++ b/contrib/perl5/eg/travesty @@ -0,0 +1,46 @@ +#!/usr/bin/perl + +while (<>) { + next if /^\./; + next if /^From / .. /^$/; + next if /^Path: / .. /^$/; + s/^\W+//; + push(@ary,split(' ')); + while ($#ary > 1) { + $a = $p; + $p = $n; + $w = shift(@ary); + $n = $num{$w}; + if ($n eq '') { + push(@word,$w); + $n = pack('S',$#word); + $num{$w} = $n; + } + $lookup{$a . $p} .= $n; + } +} + +for (;;) { + $n = $lookup{$a . $p}; + ($foo,$n) = each(lookup) if $n eq ''; + $n = substr($n,int(rand(length($n))) & 0177776,2); + $a = $p; + $p = $n; + ($w) = unpack('S',$n); + $w = $word[$w]; + $col += length($w) + 1; + if ($col >= 65) { + $col = 0; + print "\n"; + } + else { + print ' '; + } + print $w; + if ($w =~ /\.$/) { + if (rand() < .1) { + print "\n"; + $col = 80; + } + } +} diff --git a/contrib/perl5/eg/unuc b/contrib/perl5/eg/unuc new file mode 100755 index 0000000..ae5c652 --- /dev/null +++ b/contrib/perl5/eg/unuc @@ -0,0 +1,186 @@ +#!/usr/bin/perl + +print STDERR "Loading proper nouns...\n"; +open(DICT,"/usr/dict/words") || die "Can't find /usr/dict/words: $!\n"; +while (<DICT>) { + if (/^[A-Z]/) { + chop; + ($lower = $_) =~ y/A-Z/a-z/; + $proper{$lower} = $_; + } +} +close DICT; +print STDERR "Loading exceptions...\n"; + +$prog = <<'EOT'; +while (<>) { + next if /[a-z]/; + y/A-Z/a-z/; + s/(\w+)/$proper{$1} ? $proper{$1} : $1/eg; + s/^(\s*)([a-z])/$1 . (($tmp = $2) =~ y:a-z:A-Z:,$tmp)/e; + s/([-.?!]["']?(\n\s*| \s*)["']?)([a-z])/$1 . (($tmp = $3) =~ y:a-z:A-Z:,$tmp)/eg; + s/\b([b-df-hj-np-tv-xz]+)\b/(($tmp = $1) =~ y:a-z:A-Z:,$tmp)/eg; + s/([a-z])'([SDT])\b/$1 . "'" . (($tmp = $2) =~ y:A-Z:a-z:,$tmp)/eg; +EOT +while (<DATA>) { + chop; + next if /^$/; + next if /^#/; + if (! /;$/) { + $foo = $_; + $foo =~ y/A-Z/a-z/; + print STDERR "Dup $_\n" if $proper{$foo}; + $foo =~ s/([^\w ])/\\$1/g; + $foo =~ s/ /(\\s+)/g; + $foo = "\\b" . $foo if $foo =~ /^\w/; # XXX till patch 9 + $foo .= "\\b" if $foo =~ /\w$/; + $i = 0; + ($bar = $_) =~ s/ /'$' . ++$i/eg; + $_ = "s/$foo/$bar/gi;"; + } + $prog .= ' ' . $_ . "\n"; +} +$prog .= "}\ncontinue {\n print;\n}\n"; + +$/ = ''; +#print $prog; +eval $prog; die $@ if $@; +__END__ +A.M. +Air Force +Air Force Base +Air Force Station +American +Apr. +Ariane +Aug. +August +Bureau of Labor Statistics +CIT +Caltech +Cape Canaveral +Challenger +China +Corporation +Crippen +Daily News in Brief +Daniel Quayle +Dec. +Discovery +Edwards +Endeavour +Feb. +Ford Aerospace +Fri. +General Dynamics +George Bush +Headline News +HOTOL +I +II +III +IV +IX +Institute of Technology +JPL +Jan. +Jul. +Jun. +Kennedy Space Center +LDEF +Long Duration Exposure Facility +Long March +Mar. +March +Martin +Martin Marietta +Mercury +Mon. +in May +s/\bmay (\d)/May $1/g; +s/\boffice of (\w)/'Office of ' . (($tmp = $1) =~ y:a-z:A-Z:,$tmp)/eg; +National Science Foundation +NASA Select +New Mexico +Nov. +OMB +Oct. +Office of Management and Budget +President +President Bush +Richard Truly +Rocketdyne +Russian +Russians +Sat. +Sep. +Soviet +Soviet Union +Soviets +Space Shuttle +Sun. +Thu. +Tue. +U.S. +Union of Soviet Socialist Republics +United States +VI +VII +VIII +Vice President +Vice President Quayle +Wed. +White Sands +Kaman Aerospace +Aerospace Daily +Aviation Week +Space Technology +Washington Post +Los Angeles Times +New York Times +Aerospace Industries Association +president of +Johnson Space Center +Space Services +Inc. +Co. +Hughes Aircraft +Company +Orbital Sciences +Swedish Space +Arnauld +Nicogosian +Magellan +Galileo +Mir +Jet Propulsion Laboratory +University +Department of Defense +Orbital Science +OMS +United Press International +United Press +UPI +Associated Press +AP +Cable News Network +Cape York +Zenit +SYNCOM +Eastern +Western +Test Range +Jcsat +Japanese Satellite Communications +Defence Ministry +Defense Ministry +Skynet +Fixed Service Structure +Launch Processing System +Asiasat +Launch Control Center +Earth +CNES +Glavkosmos +Pacific +Atlantic diff --git a/contrib/perl5/eg/uudecode b/contrib/perl5/eg/uudecode new file mode 100644 index 0000000..3b3cb60 --- /dev/null +++ b/contrib/perl5/eg/uudecode @@ -0,0 +1,15 @@ +#!/usr/bin/perl +while (<>) { + next unless ($mode,$file) = /^begin\s*(\d*)\s*(\S*)/; + open(OUT,"> $file") || die "Can't create $file: $!\n"; + while (<>) { + last if /^end/; + next if /[a-z]/; + next unless int((((ord() - 32) & 077) + 2) / 3) == + int(length() / 4); + print OUT unpack("u", $_); + } + chmod oct($mode), $file; + eof() && die "Missing end: $file may be truncated.\n"; +} + diff --git a/contrib/perl5/eg/van/empty b/contrib/perl5/eg/van/empty new file mode 100644 index 0000000..d699319 --- /dev/null +++ b/contrib/perl5/eg/van/empty @@ -0,0 +1,45 @@ +#!/usr/bin/perl + +# $RCSfile: empty,v $$Revision: 4.1 $$Date: 92/08/07 17:20:50 $ + +# This script empties a trashcan. + +$recursive = shift if $ARGV[0] eq '-r'; + +@ARGV = '.' if $#ARGV < 0; + +chop($pwd = `pwd`); + +dir: foreach $dir (@ARGV) { + unless (chdir $dir) { + print stderr "Can't find directory $dir: $!\n"; + next dir; + } + if ($recursive) { + do cmd('find . -name .deleted -exec /bin/rm -rf {} ;'); + } + else { + if (-d '.deleted') { + do cmd('rm -rf .deleted'); + } + else { + if ($dir eq '.' && $pwd =~ m|/\.deleted$|) { + chdir '..'; + do cmd('rm -rf .deleted'); + } + else { + print stderr "No trashcan found in directory $dir\n"; + } + } + } +} +continue { + chdir $pwd; +} + +# force direct execution with no shell + +sub cmd { + system split(' ',join(' ',@_)); +} + diff --git a/contrib/perl5/eg/van/unvanish b/contrib/perl5/eg/van/unvanish new file mode 100644 index 0000000..acb1603 --- /dev/null +++ b/contrib/perl5/eg/van/unvanish @@ -0,0 +1,66 @@ +#!/usr/bin/perl + +# $RCSfile: unvanish,v $$Revision: 4.1 $$Date: 92/08/07 17:20:52 $ + +sub it { + if ($olddir ne '.') { + chop($pwd = `pwd`) if $pwd eq ''; + (chdir $olddir) || die "Directory $olddir is not accesible"; + } + unless ($olddir eq '.deleted') { + if (-d '.deleted') { + chdir '.deleted' || die "Directory .deleted is not accesible"; + } + else { + chop($pwd = `pwd`) if $pwd eq ''; + die "Directory .deleted does not exist" unless $pwd =~ /\.deleted$/; + } + } + print `mv $startfiles$filelist..$force`; + if ($olddir ne '.') { + (chdir $pwd) || die "Can't get back to original directory $pwd: $!\n"; + } +} + +if ($#ARGV < 0) { + open(lastcmd,'.deleted/.lastcmd') || + open(lastcmd,'.lastcmd') || + die "No previous vanish in this dir"; + $ARGV = <lastcmd>; + close(lastcmd); + @ARGV = split(/[\n ]+/,$ARGV); +} + +while ($ARGV[0] =~ /^-/) { + $_ = shift; + /^-f/ && ($force = ' >/dev/null 2>&1'); + /^-i/ && ($interactive = 1); + if (/^-+$/) { + $startfiles = '- '; + last; + } +} + +while ($file = shift) { + if ($file =~ s|^(.*)/||) { + $dir = $1; + } + else { + $dir = '.'; + } + + if ($dir ne $olddir) { + do it() if $olddir; + $olddir = $dir; + } + + if ($interactive) { + print "unvanish: restore $dir/$file? "; + next unless <stdin> =~ /^y/i; + } + + $filelist .= $file; $filelist .= ' '; + +} + +do it() if $olddir; diff --git a/contrib/perl5/eg/van/vanexp b/contrib/perl5/eg/van/vanexp new file mode 100644 index 0000000..415b73b --- /dev/null +++ b/contrib/perl5/eg/van/vanexp @@ -0,0 +1,21 @@ +#!/usr/bin/perl + +# $RCSfile: vanexp,v $$Revision: 4.1 $$Date: 92/08/07 17:20:53 $ + +# This is for running from a find at night to expire old .deleteds + +$can = $ARGV[0]; + +exit 1 unless $can =~ /.deleted$/; + +($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, + $blksize,$blocks) = stat($can); + +exit 0 unless $size; + +if (time - $mtime > 2 * 24 * 60 * 60) { + `/bin/rm -rf $can`; +} +else { + `find $can -ctime +2 -exec rm -f {} \;`; +} diff --git a/contrib/perl5/eg/van/vanish b/contrib/perl5/eg/van/vanish new file mode 100644 index 0000000..09b9679 --- /dev/null +++ b/contrib/perl5/eg/van/vanish @@ -0,0 +1,65 @@ +#!/usr/bin/perl + +# $RCSfile: vanish,v $$Revision: 4.1 $$Date: 92/08/07 17:20:54 $ + +sub it { + if ($olddir ne '.') { + chop($pwd = `pwd`) if $pwd eq ''; + (chdir $olddir) || die "Directory $olddir is not accesible"; + } + if (!-d .deleted) { + print `mkdir .deleted; chmod 775 .deleted`; + die "You can't remove files from $olddir" if $?; + } + $filelist =~ s/ $//; + $filelist =~ s/#/\\#/g; + if ($filelist !~ /^[ \t]*$/) { + open(lastcmd,'>.deleted/.lastcmd'); + print lastcmd $filelist,"\n"; + close(lastcmd); + print `/bin/mv $startfiles$filelist .deleted$force`; + } + if ($olddir ne '.') { + (chdir $pwd) || die "Can't get back to original directory $pwd: $!\n"; + } +} + +while ($ARGV[0] =~ /^-/) { + $_ = shift; + /^-f/ && ($force = ' >/dev/null 2>&1'); + /^-i/ && ($interactive = 1); + if (/^-+$/) { + $startfiles = '- '; + last; + } +} + +chop($pwd = `pwd`); + +while ($file = shift) { + if ($file =~ s|^(.*)/||) { + $dir = $1; + } + else { + $dir = '.'; + } + + if ($interactive) { + print "vanish: remove $dir/$file? "; + next unless <stdin> =~ /^y/i; + } + + if ($file eq '.deleted') { + print stderr "To delete .deleted (the trashcan) use the 'empty' command.\n"; + next; + } + + if ($dir ne $olddir) { + do it() if $olddir; + $olddir = $dir; + } + + $filelist .= $file; $filelist .= ' '; +} + +do it() if $olddir; diff --git a/contrib/perl5/eg/who b/contrib/perl5/eg/who new file mode 100644 index 0000000..ac15246 --- /dev/null +++ b/contrib/perl5/eg/who @@ -0,0 +1,13 @@ +#!/usr/bin/perl +# This assumes your /etc/utmp file looks like ours +open(UTMP,'/etc/utmp'); +@mo = (Jan,Feb,Mar,Apr,May,Jun,Jul,Aug,Sep,Oct,Nov,Dec); +while (read(UTMP,$utmp,36)) { + ($line,$name,$host,$time) = unpack('A8A8A16l',$utmp); + if ($name) { + $host = "($host)" if ord($host); + ($sec,$min,$hour,$mday,$mon) = localtime($time); + printf "%-9s%-8s%s %2d %02d:%02d %s\n", + $name,$line,$mo[$mon],$mday,$hour,$min,$host; + } +} diff --git a/contrib/perl5/eg/wrapsuid b/contrib/perl5/eg/wrapsuid new file mode 100755 index 0000000..3b1fc6e --- /dev/null +++ b/contrib/perl5/eg/wrapsuid @@ -0,0 +1,104 @@ +#!/usr/bin/perl +'di'; +'ig00'; +# +# $Header: wrapsuid,v 1.1 90/08/11 13:51:29 lwall Locked $ +# +# $Log: wrapsuid,v $ +# Revision 1.1 90/08/11 13:51:29 lwall +# Initial revision +# + +$xdev = '-xdev' unless -d '/dev/iop'; + +if ($#ARGV >= 0) { + @list = @ARGV; + foreach $name (@ARGV) { + die "You must use absolute pathnames.\n" unless $name =~ m|^/|; + } +} +else { + open(DF,"/etc/mount|") || die "Can't run /etc/mount"; + + while (<DF>) { + chop; + $_ .= <DF> if length($_) < 50; + @ary = split; + push(@list,$ary[2]) if ($ary[0] =~ m|^/dev|); + } +} +$fslist = join(' ',@list); + +die "Can't find local filesystems" unless $fslist; + +open(FIND, + "find $fslist $xdev -type f \\( -perm -04000 -o -perm -02000 \\) -print|"); + +while (<FIND>) { + chop; + next unless -T; + print "Fixing ", $_, "\n"; + ($dir,$file) = m|(.*)/(.*)|; + chdir $dir || die "Can't chdir to $dir"; + ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, + $blksize,$blocks) = stat($file); + die "Can't stat $_" unless $ino; + chmod $mode & 01777, $file; # wipe out set[ug]id bits + rename($file,".$file"); + open(C,">.tmp$$.c") || die "Can't write C program for $_"; + $real = "$dir/.$file"; + print C ' +main(argc,argv) +int argc; +char **argv; +{ + execv("' . $real . '",argv); +} +'; + close C; + system '/bin/cc', ".tmp$$.c", '-o', $file; + die "Can't compile new $_" if $?; + chmod $mode, $file; + chown $uid, $gid, $file; + unlink ".tmp$$.c"; + chdir '/'; +} +############################################################################## + + # These next few lines are legal in both Perl and nroff. + +.00; # finish .ig + +'di \" finish diversion--previous line must be blank +.nr nl 0-1 \" fake up transition to first page again +.nr % 0 \" start at page 1 +'; __END__ ############# From here on it's a standard manual page ############ +.TH SUIDSCRIPT 1 "July 30, 1990" +.AT 3 +.SH NAME +wrapsuid \- puts a compiled C wrapper around a setuid or setgid script +.SH SYNOPSIS +.B wrapsuid [dirlist] +.SH DESCRIPTION +.I Wrapsuid +creates a small C program to execute a script with setuid or setgid privileges +without having to set the setuid or setgid bit on the script, which is +a security problem on many machines. +Specify the list of directories or files that you wish to process. +The names must be absolute pathnames. +With no arguments it will attempt to process all the local directories +for this machine. +The scripts to be processed must have the setuid or setgid bit set. +The wrapsuid program will delete the bits and set them on the wrapper. +.PP +Non-superusers may only process their own files. +.SH ENVIRONMENT +No environment variables are used. +.SH FILES +None. +.SH AUTHOR +Larry Wall +.SH "SEE ALSO" +.SH DIAGNOSTICS +.SH BUGS +.ex |
