#----------------------------- open(INPUT, "< /usr/local/widgets/data") or die "Couldn't open /usr/local/widgets/data for reading: $!\n"; while (<INPUT>) { print if /blue/; } close(INPUT); #----------------------------- $var = *STDIN; mysub($var, *LOGFILE); #----------------------------- use IO::File; $input = IO::File->new("< /usr/local/widgets/data") or die "Couldn't open /usr/local/widgets/data for reading: $!\n"; while (defined($line = $input->getline())) { chomp($line); STDOUT->print($line) if $line =~ /blue/; } $input->close(); #----------------------------- while (<STDIN>) { # reads from STDIN unless (/\d/) { warn "No digit found.\n"; # writes to STDERR } print "Read: ", $_; # writes to STDOUT } END { close(STDOUT) or die "couldn't close STDOUT: $!" } #----------------------------- open(LOGFILE, "> /tmp/log") or die "Can't write /tmp/log: $!"; #----------------------------- close(FH) or die "FH didn't close: $!"; #----------------------------- $old_fh = select(LOGFILE); # switch to LOGFILE for output print "Countdown initiated ...\n"; select($old_fh); # return to original output print "You have 30 seconds to reach minimum safety distance.\n"; #----------------------------- |
#----------------------------- open(SOURCE, "< $path") or die "Couldn't open $path for reading: $!\n"; open(SINK, "> $path") or die "Couldn't open $path for writing: $!\n"; #----------------------------- use Fcntl; sysopen(SOURCE, $path, O_RDONLY) or die "Couldn't open $path for reading: $!\n"; sysopen(SINK, $path, O_WRONLY) or die "Couldn't open $path for writing: $!\n"; #----------------------------- use IO::File; # like Perl's open $fh = IO::File->new("> $filename") or die "Couldn't open $filename for writing: $!\n"; # like Perl's sysopen $fh = IO::File->new($filename, O_WRONLY|O_CREAT) or die "Couldn't open $filename for writing: $!\n"; # like stdio's fopen(3) $fh = IO::File->new($filename, "r+") or die "Couldn't open $filename for read and write: $!\n"; #----------------------------- sysopen(FILEHANDLE, $name, $flags) or die "Can't open $name : $!"; sysopen(FILEHANDLE, $name, $flags, $perms) or die "Can't open $name : $!"; #----------------------------- open(FH, "< $path") or die $!; sysopen(FH, $path, O_RDONLY) or die $!; #----------------------------- open(FH, "> $path") or die $!; sysopen(FH, $path, O_WRONLY|O_TRUNC|O_CREAT) or die $!; sysopen(FH, $path, O_WRONLY|O_TRUNC|O_CREAT, 0600) or die $!; #----------------------------- sysopen(FH, $path, O_WRONLY|O_EXCL|O_CREAT) or die $!; sysopen(FH, $path, O_WRONLY|O_EXCL|O_CREAT, 0600) or die $!; #----------------------------- open(FH, ">> $path") or die $!; sysopen(FH, $path, O_WRONLY|O_APPEND|O_CREAT) or die $!; sysopen(FH, $path, O_WRONLY|O_APPEND|O_CREAT, 0600) or die $!; #----------------------------- sysopen(FH, $path, O_WRONLY|O_APPEND) or die $!; #----------------------------- open(FH, "+< $path") or die $!; sysopen(FH, $path, O_RDWR) or die $!; #----------------------------- sysopen(FH, $path, O_RDWR|O_CREAT) or die $!; sysopen(FH, $path, O_RDWR|O_CREAT, 0600) or die $!; #----------------------------- sysopen(FH, $path, O_RDWR|O_EXCL|O_CREAT) or die $!; sysopen(FH, $path, O_RDWR|O_EXCL|O_CREAT, 0600) or die $!; #----------------------------- |
#----------------------------- $filename =~ s#^(\s)#./$1#; open(HANDLE, "< $filename\0") or die "cannot open $filename : $!\n"; #----------------------------- sysopen(HANDLE, $filename, O_RDONLY) or die "cannot open $filename: $!\n"; #----------------------------- $filename = shift @ARGV; open(INPUT, $filename) or die "Couldn't open $filename : $!\n"; #----------------------------- open(OUTPUT, ">$filename") or die "Couldn't open $filename for writing: $!\n"; #----------------------------- use Fcntl; # for file constants sysopen(OUTPUT, $filename, O_WRONLY|O_TRUNC) or die "Can't open $filename for writing: $!\n"; #----------------------------- $file =~ s#^(\s)#./$1#; open(OUTPUT, "> $file\0") or die "Couldn't open $file for OUTPUT : $!\n"; #----------------------------- |
#----------------------------- $filename =~ s{ ^ ~ ( [^/]* ) } { $1 ? (getpwnam($1))[7] : ( $ENV{HOME} || $ENV{LOGDIR} || (getpwuid($>))[7] ) }ex; #----------------------------- # ~user # ~user/blah # ~ # ~/blah #----------------------------- |
#----------------------------- open($path, "< $path") or die "Couldn't open $path for reading : $!\n"; #----------------------------- #Argument "3\n" isn't numeric in multiply at tallyweb line 16, <LOG> chunk 17. #----------------------------- #Argument "3\n" isn't numeric in multiply at tallyweb # # line 16, </usr/local/data/mylog3.dat> chunk 17. #----------------------------- |
#----------------------------- use IO::File; $fh = IO::File->new_tmpfile or die "Unable to make new temporary file: $!"; #----------------------------- use IO::File; use POSIX qw(tmpnam); # try new temporary filenames until we get one that didn't already exist do { $name = tmpnam() } until $fh = IO::File->new($name, O_RDWR|O_CREAT|O_EXCL); # install atexit-style handler so that when we exit or die, # we automatically delete this temporary file END { unlink($name) or die "Couldn't unlink $name : $!" } # now go on to use the file ... #----------------------------- for (;;) { $name = tmpnam(); sysopen(TMP, $tmpnam, O_RDWR | O_CREAT | O_EXCL) && last; } unlink $tmpnam; #----------------------------- use IO::File; $fh = IO::File->new_tmpfile or die "IO::File->new_tmpfile: $!"; $fh->autoflush(1); print $fh "$i\n" while $i++ < 10; seek($fh, 0, 0) or die "seek: $!"; print "Tmp file has: ", <$fh>; #----------------------------- |
#----------------------------- while (<DATA>) { # process the line } #__DATA__ # your data goes here #----------------------------- while (<main::DATA>) { # process the line } #__END__ # your data goes here #----------------------------- use POSIX qw(strftime); $raw_time = (stat(DATA))[9]; $size = -s DATA; $kilosize = int($size / 1024) . 'k'; print "<P>Script size is $kilosize\n"; print strftime("<P>Last script update: %c (%Z)\n", localtime($raw_time)); #__DATA__ #DO NOT REMOVE THE PRECEDING LINE. #Everything else in this file will be ignored. #----------------------------- |
#----------------------------- while (<>) { # do something with the line } #----------------------------- while (<>) { # ... } #----------------------------- unshift(@ARGV, '-') unless @ARGV; while ($ARGV = shift @ARGV) { unless (open(ARGV, $ARGV)) { warn "Can't open $ARGV: $!\n"; next; } while (defined($_ = <ARGV>)) { # ... } } #----------------------------- @ARGV = glob("*.[Cch]") unless @ARGV; #----------------------------- # arg demo 1: Process optional -c flag if (@ARGV && $ARGV[0] eq '-c') { $chop_first++; shift; } # arg demo 2: Process optional -NUMBER flag if (@ARGV && $ARGV[0] =~ /^-(\d+)$/) { $columns = $1; shift; } # arg demo 3: Process clustering -a, -i, -n, or -u flags while (@ARGV && $ARGV[0] =~ /^-(.+)/ && (shift, ($_ = $1), 1)) { next if /^$/; s/a// && (++$append, redo); s/i// && (++$ignore_ints, redo); s/n// && (++$nostdout, redo); s/u// && (++$unbuffer, redo); die "usage: $0 [-ainu] [filenames] ...\n"; } #----------------------------- undef $/; while (<>) { # $_ now has the complete contents of # the file whose name is in $ARGV } #----------------------------- { # create block for local local $/; # record separator now undef while (<>) { # do something; called functions still have # undeffed version of $/ } } # $/ restored here #----------------------------- while (<>) { print "$ARGV:$.:$_"; close ARGV if eof; } #----------------------------- # download the following standalone program #!/usr/bin/perl # findlogin1 - print all lines containing the string "login" while (<>) { # loop over files on command line print if /login/; } #----------------------------- # download the following standalone program #!/usr/bin/perl -n # findlogin2 - print all lines containing the string "login" print if /login/; #----------------------------- #% perl -ne 'print if /login/' #----------------------------- # download the following standalone program #!/usr/bin/perl # lowercase - turn all lines into lowercase use locale; while (<>) { # loop over lines on command line s/([^\W0-9_])/\l$1/g; # change all letters to lowercase print; } #----------------------------- # download the following standalone program #!/usr/bin/perl -p # lowercase - turn all lines into lowercase use locale; s/([^\W0-9_])/\l$1/g; # change all letters to lowercase #----------------------------- #% perl -Mlocale -pe 's/([^\W0-9_])/\l$1/g' #----------------------------- # download the following standalone program #!/usr/bin/perl -n # countchunks - count how many words are used. # skip comments, and bail on file if _ _END_ _ # or _ _DATA_ _ seen. for (split /\W+/) { next LINE if /^#/; close ARGV if /_ _(DATA|END)_ _/; $chunks++; } END { print "Found $chunks chunks\n" } #----------------------------- #+0894382237 #less /etc/motd #+0894382239 #vi ~/.exrc #+0894382242 #date #+0894382242 #who #+0894382288 #telnet home #----------------------------- #% perl -pe 's/^#\+(\d+)\n/localtime($1) . " "/e' #Tue May 5 09:30:37 1998 less /etc/motd # #Tue May 5 09:30:39 1998 vi ~/.exrc # #Tue May 5 09:30:42 1998 date # #Tue May 5 09:30:42 1998 who # #Tue May 5 09:31:28 1998 telnet home #----------------------------- |
#----------------------------- open(OLD, "< $old") or die "can't open $old: $!"; open(NEW, "> $new") or die "can't open $new: $!"; while (<OLD>) { # change $_, then... print NEW $_ or die "can't write $new: $!"; } close(OLD) or die "can't close $old: $!"; close(NEW) or die "can't close $new: $!"; rename($old, "$old.orig") or die "can't rename $old to $old.orig: $!"; rename($new, $old) or die "can't rename $new to $old: $!"; #----------------------------- while (<OLD>) { if ($. == 20) { print NEW "Extra line 1\n"; print NEW "Extra line 2\n"; } print NEW $_; } #----------------------------- while (<OLD>) { next if 20 .. 30; print NEW $_; } #----------------------------- |
#----------------------------- #% perl -i.orig -p -e 'FILTER COMMAND' file1 file2 file3 ... #----------------------------- #!/usr/bin/perl -i.orig -p # filter commands go here #----------------------------- #% perl -pi.orig -e 's/DATE/localtime/e' #----------------------------- while (<>) { if ($ARGV ne $oldargv) { # are we at the next file? rename($ARGV, $ARGV . '.orig'); open(ARGVOUT, ">$ARGV"); # plus error check select(ARGVOUT); $oldargv = $ARGV; } s/DATE/localtime/e; } continue{ print; } select (STDOUT); # restore default output #----------------------------- #Dear Sir/Madam/Ravenous Beast, # As of DATE, our records show your account #is overdue. Please settle by the end of the month. #Yours in cheerful usury, # --A. Moneylender #----------------------------- #Dear Sir/Madam/Ravenous Beast, # As of Sat Apr 25 12:28:33 1998, our records show your account #is overdue. Please settle by the end of the month. #Yours in cheerful usury, # --A. Moneylender #----------------------------- #% perl -i.old -pe 's{\bhisvar\b}{hervar}g' *.[Cchy] #----------------------------- # set up to iterate over the *.c files in the current directory, # editing in place and saving the old file with a .orig extension local $^I = '.orig'; # emulate -i.orig local @ARGV = glob("*.c"); # initialize list of files while (<>) { if ($. == 1) { print "This line should appear at the top of each file\n"; } s/\b(p)earl\b/${1}erl/ig; # Correct typos, preserving case print; } continue {close ARGV if eof} #----------------------------- |
#----------------------------- open(FH, "+< FILE") or die "Opening: $!"; @ARRAY = <FH>; # change ARRAY here seek(FH,0,0) or die "Seeking: $!"; print FH @ARRAY or die "Printing: $!"; truncate(FH,tell(FH)) or die "Truncating: $!"; close(FH) or die "Closing: $!"; #----------------------------- open(F, "+< $infile") or die "can't read $infile: $!"; $out = ''; while (<F>) { s/DATE/localtime/eg; $out .= $_; } seek(F, 0, 0) or die "can't seek to start of $infile: $!"; print F $out or die "can't print to $infile: $!"; truncate(F, tell(F)) or die "can't truncate $infile: $!"; close(F) or die "can't close $infile: $!"; #----------------------------- |
#----------------------------- open(FH, "+< $path") or die "can't open $path: $!"; flock(FH, 2) or die "can't flock $path: $!"; # update file, then... close(FH) or die "can't close $path: $!"; #----------------------------- sub LOCK_SH() { 1 } # Shared lock (for reading) sub LOCK_EX() { 2 } # Exclusive lock (for writing) sub LOCK_NB() { 4 } # Non-blocking request (don't stall) sub LOCK_UN() { 8 } # Free the lock (careful!) #----------------------------- unless (flock(FH, LOCK_EX|LOCK_NB)) { warn "can't immediately write-lock the file ($!), blocking ..."; unless (flock(FH, LOCK_EX)) { die "can't get write-lock on numfile: $!"; } } #----------------------------- if ($] < 5.004) { # test Perl version number my $old_fh = select(FH); local $| = 1; # enable command buffering local $\ = ''; # clear output record separator print ""; # trigger output flush select($old_fh); # restore previous filehandle } flock(FH, LOCK_UN); #----------------------------- use Fcntl qw(:DEFAULT :flock); sysopen(FH, "numfile", O_RDWR|O_CREAT) or die "can't open numfile: $!"; flock(FH, LOCK_EX) or die "can't write-lock numfile: $!"; # Now we have acquired the lock, it's safe for I/O $num = <FH> || 0; # DO NOT USE "or" THERE!! seek(FH, 0, 0) or die "can't rewind numfile : $!"; truncate(FH, 0) or die "can't truncate numfile: $!"; print FH $num+1, "\n" or die "can't write numfile: $!"; close(FH) or die "can't close numfile: $!"; #----------------------------- |
#----------------------------- $old_fh = select(OUTPUT_HANDLE); $| = 1; select($old_fh); #----------------------------- use IO::Handle; OUTPUT_HANDLE->autoflush(1); #----------------------------- # download the following standalone program #!/usr/bin/perl -w # seeme - demo stdio output buffering $| = (@ARGV > 0); # command buffered if arguments given print "Now you don't see it..."; sleep 2; print "now you do\n"; #----------------------------- select((select(OUTPUT_HANDLE), $| = 1)[0]); #----------------------------- use FileHandle; STDERR->autoflush; # already unbuffered in stdio $filehandle->autoflush(0); #----------------------------- use IO::Handle; # assume REMOTE_CONN is an interactive socket handle, # but DISK_FILE is a handle to a regular file. autoflush REMOTE_CONN 1; # unbuffer for clarity autoflush DISK_FILE 0; # buffer this for speed #----------------------------- # download the following standalone program #!/usr/bin/perl # getpcomidx - fetch www.perl.com's index.html document use IO::Socket; $sock = new IO::Socket::INET (PeerAddr => 'www.perl.com', PeerPort => 'http(80)'); die "Couldn't create socket: $@" unless $sock; # the library doesn't support $! setting; it uses $@ $sock->autoflush(1); # Mac *must* have \015\012\015\012 instead of \n\n here. # It's a good idea for others, too, as that's the spec, # but implementations are encouraged to accept "\cJ\cJ" too, # and as far as we're seen, they do. $sock->print("GET /index.html http/1.1\n\n"); $document = join('', $sock->getlines()); print "DOC IS: $document\n"; #----------------------------- |
#----------------------------- $rin = ''; # repeat next line for all filehandles to poll vec($rin, fileno(FH1), 1) = 1; vec($rin, fileno(FH2), 1) = 1; vec($rin, fileno(FH3), 1) = 1; $nfound = select($rout=$rin, undef, undef, 0); if ($nfound) { # input waiting on one or more of those 3 filehandles if (vec($rout,fileno(FH1),1)) { # do something with FH1 } if (vec($rout,fileno(FH2),1)) { # do something with FH2 } if (vec($rout,fileno(FH3),1)) { # do something with FH3 } } #----------------------------- use IO::Select; $select = IO::Select->new(); # repeat next line for all filehandles to poll $select->add(*FILEHANDLE); if (@ready = $select->can_read(0)) { # input waiting on the filehandles in @ready } #----------------------------- $rin = ''; vec($rin, fileno(FILEHANDLE), 1) = 1; $nfound = select($rin, undef, undef, 0); # just check if ($nfound) { $line = <FILEHANDLE>; print "I read $line"; } #----------------------------- |
#----------------------------- use Fcntl; sysopen(MODEM, "/dev/cua0", O_NONBLOCK|O_RDWR) or die "Can't open modem: $!\n"; #----------------------------- use Fcntl; $flags = ''; fcntl(HANDLE, F_GETFL, $flags) or die "Couldn't get flags for HANDLE : $!\n"; $flags |= O_NONBLOCK; fcntl(HANDLE, F_SETFL, $flags) or die "Couldn't set flags for HANDLE: $!\n"; #----------------------------- use POSIX qw(:errno_h); $rv = syswrite(HANDLE, $buffer, length $buffer); if (!defined($rv) && $! == EAGAIN) { # would block } elsif ($rv != length $buffer) { # incomplete write } else { # successfully wrote } $rv = sysread(HANDLE, $buffer, $BUFSIZ); if (!defined($rv) && $! == EAGAIN) { # would block } else { # successfully read $rv bytes from HANDLE } #----------------------------- |
#----------------------------- $size = pack("L", 0); ioctl(FH, $FIONREAD, $size) or die "Couldn't call ioctl: $!\n"; $size = unpack("L", $size); # $size bytes can be read #----------------------------- require 'sys/ioctl.ph'; $size = pack("L", 0); ioctl(FH, FIONREAD(), $size) or die "Couldn't call ioctl: $!\n"; $size = unpack("L", $size); #----------------------------- #% grep FIONREAD /usr/include/*/* #/usr/include/asm/ioctls.h:#define FIONREAD 0x541B #----------------------------- #% cat > fionread.c ##include <sys/ioctl.h> #main() { # # printf("%#08x\n", FIONREAD); #} #^D #% cc -o fionread fionread #% ./fionread #0x4004667f #----------------------------- $FIONREAD = 0x4004667f; # XXX: opsys dependent $size = pack("L", 0); ioctl(FH, $FIONREAD, $size) or die "Couldn't call ioctl: $!\n"; $size = unpack("L", $size); #----------------------------- |
#----------------------------- $variable = *FILEHANDLE; # save in variable subroutine(*FILEHANDLE); # or pass directly sub subroutine { my $fh = shift; print $fh "Hello, filehandle!\n"; } #----------------------------- use FileHandle; # make anon filehandle $fh = FileHandle->new(); use IO::File; # 5.004 or higher $fh = IO::File->new(); #----------------------------- $fh_a = IO::File->new("< /etc/motd") or die "open /etc/motd: $!"; $fh_b = *STDIN; some_sub($fh_a, $fh_b); #----------------------------- sub return_fh { # make anon filehandle local *FH; # must be local, not my # now open it if you want to, then... return *FH; } $handle = return_fh(); #----------------------------- sub accept_fh { my $fh = shift; print $fh "Sending to indirect filehandle\n"; } #----------------------------- sub accept_fh { local *FH = shift; print FH "Sending to localized filehandle\n"; } #----------------------------- accept_fh(*STDOUT); accept_fh($handle); #----------------------------- @fd = (*STDIN, *STDOUT, *STDERR); print $fd[1] "Type it: "; # WRONG $got = <$fd[0]> # WRONG print $fd[2] "What was that: $got"; # WRONG #----------------------------- print { $fd[1] } "funny stuff\n"; printf { $fd[1] } "Pity the poor %x.\n", 3_735_928_559; Pity the poor deadbeef. #----------------------------- $ok = -x "/bin/cat"; print { $ok ? $fd[1] : $fd[2] } "cat stat $ok\n"; print { $fd[ 1 + ($ok || 0) ] } "cat stat $ok\n"; #----------------------------- $got = readline($fd[0]); #----------------------------- |
#----------------------------- use FileCache; cacheout ($path); # each time you use a filehandle print $path "output"; #----------------------------- # download the following standalone program #!/usr/bin/perl # splitwulog - split wuftpd log by authenticated user use FileCache; $outdir = '/var/log/ftp/by-user'; while (<>) { unless (defined ($user = (split)[-4])) { warn "Invalid line: $.\n"; next; } $path = "$outdir/$user"; cacheout $path; print $path $_; } #----------------------------- |
#----------------------------- foreach $filehandle (@FILEHANDLES) { print $filehandle $stuff_to_print; } #----------------------------- open(MANY, "| tee file1 file2 file3 > /dev/null") or die $!; print MANY "data\n" or die $!; close(MANY) or die $!; #----------------------------- # `use strict' complains about this one: for $fh ('FH1', 'FH2', 'FH3') { print $fh "whatever\n" } # but not this one: for $fh (*FH1, *FH2, *FH3) { print $fh "whatever\n" } #----------------------------- open (FH, "| tee file1 file2 file3 >/dev/null"); print FH "whatever\n"; #----------------------------- # make STDOUT go to three files, plus original STDOUT open (STDOUT, "| tee file1 file2 file3") or die "Teeing off: $!\n"; print "whatever\n" or die "Writing: $!\n"; close(STDOUT) or die "Closing: $!\n"; #----------------------------- |
#----------------------------- open(FH, "<&=$FDNUM"); # open FH to the descriptor itself open(FH, "<&$FDNUM"); # open FH to a copy of the descriptor use IO::Handle; $fh->fdopen($FDNUM, "r"); # open file descriptor 3 for reading #----------------------------- use IO::Handle; $fh = IO::Handle->new(); $fh->fdopen(3, "r"); # open fd 3 for reading #----------------------------- $fd = $ENV{MHCONTEXTFD}; open(MHCONTEXT, "<&=$fd") or die "couldn't fdopen $fd: $!"; # after processing close(MHCONTEXT) or die "couldn't close context file: $!"; #----------------------------- |
#----------------------------- *ALIAS = *ORIGINAL; #----------------------------- open(OUTCOPY, ">&STDOUT") or die "Couldn't dup STDOUT: $!"; open(INCOPY, "<&STDIN" ) or die "Couldn't dup STDIN : $!"; #----------------------------- open(OUTALIAS, ">&=STDOUT") or die "Couldn't alias STDOUT: $!"; open(INALIAS, "<&=STDIN") or die "Couldn't alias STDIN : $!"; open(BYNUMBER, ">&=5") or die "Couldn't alias file descriptor 5: $!"; #----------------------------- # take copies of the file descriptors open(OLDOUT, ">&STDOUT"); open(OLDERR, ">&STDERR"); # redirect stdout and stderr open(STDOUT, "> /tmp/program.out") or die "Can't redirect stdout: $!"; open(STDERR, ">&STDOUT") or die "Can't dup stdout: $!"; # run the program system($joe_random_program); # close the redirected filehandles close(STDOUT) or die "Can't close STDOUT: $!"; close(STDERR) or die "Can't close STDERR: $!"; # restore stdout and stderr open(STDERR, ">&OLDERR") or die "Can't restore stderr: $!"; open(STDOUT, ">&OLDOUT") or die "Can't restore stdout: $!"; # avoid leaks by closing the independent copies close(OLDOUT) or die "Can't close OLDOUT: $!"; close(OLDERR) or die "Can't close OLDERR: $!"; #----------------------------- |
#----------------------------- # download the following standalone program #!/usr/bin/perl -w # drivelock - demo File::LockDir module use strict; use File::LockDir; $SIG{INT} = sub { die "outta here\n" }; $File::LockDir::Debug = 1; my $path = shift or die "usage: $0 <path>\n"; unless (nflock($path, 2)) { die "couldn't lock $path in 2 seconds\n"; } sleep 100; nunflock($path); #----------------------------- package File::LockDir; # module to provide very basic filename-level # locks. No fancy systems calls. In theory, # directory info is sync'd over NFS. Not # stress tested. use strict; use Exporter; use vars qw(@ISA @EXPORT); @ISA = qw(Exporter); @EXPORT = qw(nflock nunflock); use vars qw($Debug $Check); $Debug ||= 0; # may be predefined $Check ||= 5; # may be predefined use Cwd; use Fcntl; use Sys::Hostname; use File::Basename; use File::stat; use Carp; my %Locked_Files = (); # usage: nflock(FILE; NAPTILL) sub nflock($;$) { my $pathname = shift; my $naptime = shift || 0; my $lockname = name2lock($pathname); my $whosegot = "$lockname/owner"; my $start = time(); my $missed = 0; local *OWNER; # if locking what I've already locked, return if ($Locked_Files{$pathname}) { carp "$pathname already locked"; return 1 } if (!-w dirname($pathname)) { croak "can't write to directory of $pathname"; } while (1) { last if mkdir($lockname, 0777); confess "can't get $lockname: $!" if $missed++ > 10 && !-d $lockname; if ($Debug) {{ open(OWNER, "< $whosegot") || last; # exit "if"! my $lockee = <OWNER>; chomp($lockee); printf STDERR "%s $0\[$$]: lock on %s held by %s\n", scalar(localtime), $pathname, $lockee; close OWNER; }} sleep $Check; return if $naptime && time > $start+$naptime; } sysopen(OWNER, $whosegot, O_WRONLY|O_CREAT|O_EXCL) or croak "can't create $whosegot: $!"; printf OWNER "$0\[$$] on %s since %s\n", hostname(), scalar(localtime); close(OWNER) or croak "close $whosegot: $!"; $Locked_Files{$pathname}++; return 1; } # free the locked file sub nunflock($) { my $pathname = shift; my $lockname = name2lock($pathname); my $whosegot = "$lockname/owner"; unlink($whosegot); carp "releasing lock on $lockname" if $Debug; delete $Locked_Files{$pathname}; return rmdir($lockname); } # helper function sub name2lock($) { my $pathname = shift; my $dir = dirname($pathname); my $file = basename($pathname); $dir = getcwd() if $dir eq '.'; my $lockname = "$dir/$file.LOCKDIR"; return $lockname; } # anything forgotten? END { for my $pathname (keys %Locked_Files) { my $lockname = name2lock($pathname); my $whosegot = "$lockname/owner"; carp "releasing forgotten $lockname"; unlink($whosegot); return rmdir($lockname); } } 1; #----------------------------- |
#----------------------------- 4: 18584 was just here #----------------------------- 29: 24652 ZAPPED 24656 #----------------------------- #% lockarea 5 & #% rep -1 'cat /tmp/lkscreen' #----------------------------- # download the following standalone program #!/usr/bin/perl -w # lockarea - demo record locking with fcntl use strict; my $FORKS = shift || 1; my $SLEEP = shift || 1; use Fcntl; use POSIX qw(:unistd_h :errno_h); my $COLS = 80; my $ROWS = 23; # when's the last time you saw *this* mode used correctly? open(FH, "+> /tmp/lkscreen") or die $!; select(FH); $| = 1; select STDOUT; # clear screen for (1 .. $ROWS) { print FH " " x $COLS, "\n"; } my $progenitor = $$; fork while $FORKS-- > 0; print "hello from $$\n"; if ($progenitor == $$) { $SIG{INT} = \&genocide; } else { $SIG{INT} = sub { die "goodbye from $$" }; } while (1) { my $line_num = int rand($ROWS); my $line; my $n; # move to line seek(FH, $n = $line_num * ($COLS+1), SEEK_SET) or next; # get lock my $place = tell(FH); my $him; next unless defined($him = lock(*FH, $place, $COLS)); # read line read(FH, $line, $COLS) == $COLS or next; my $count = ($line =~ /(\d+)/) ? $1 : 0; $count++; # update line seek(FH, $place, 0) or die $!; my $update = sprintf($him ? "%6d: %d ZAPPED %d" : "%6d: %d was just here", $count, $$, $him); my $start = int(rand($COLS - length($update))); die "XXX" if $start + length($update) > $COLS; printf FH "%*.*s\n", -$COLS, $COLS, " " x $start . $update; # release lock and go to sleep unlock(*FH, $place, $COLS); sleep $SLEEP if $SLEEP; } die "NOT REACHED"; # just in case # lock($handle, $offset, $timeout) - get an fcntl lock sub lock { my ($fh, $start, $till) = @_; ##print "$$: Locking $start, $till\n"; my $lock = struct_flock(F_WRLCK, SEEK_SET, $start, $till, 0); my $blocker = 0; unless (fcntl($fh, F_SETLK, $lock)) { die "F_SETLK $$ @_: $!" unless $! == EAGAIN || $! == EDEADLK; fcntl($fh, F_GETLK, $lock) or die "F_GETLK $$ @_: $!"; $blocker = (struct_flock($lock))[-1]; ##print "lock $$ @_: waiting for $blocker\n"; $lock = struct_flock(F_WRLCK, SEEK_SET, $start, $till, 0); unless (fcntl($fh, F_SETLKW, $lock)) { warn "F_SETLKW $$ @_: $!\n"; return; # undef } } return $blocker; } # unlock($handle, $offset, $timeout) - release an fcntl lock sub unlock { my ($fh, $start, $till) = @_; ##print "$$: Unlocking $start, $till\n"; my $lock = struct_flock(F_UNLCK, SEEK_SET, $start, $till, 0); fcntl($fh, F_SETLK, $lock) or die "F_UNLCK $$ @_: $!"; } # OS-dependent flock structures # Linux struct flock # short l_type; # short l_whence; # off_t l_start; # off_t l_len; # pid_t l_pid; BEGIN { # c2ph says: typedef='s2 l2 i', sizeof=16 my $FLOCK_STRUCT = 's s l l i'; sub linux_flock { if (wantarray) { my ($type, $whence, $start, $len, $pid) = unpack($FLOCK_STRUCT, $_[0]); return ($type, $whence, $start, $len, $pid); } else { my ($type, $whence, $start, $len, $pid) = @_; return pack($FLOCK_STRUCT, $type, $whence, $start, $len, $pid); } } } # SunOS struct flock: # short l_type; /* F_RDLCK, F_WRLCK, or F_UNLCK */ # short l_whence; /* flag to choose starting offset */ # long l_start; /* relative offset, in bytes */ # long l_len; /* length, in bytes; 0 means lock to EOF */ # short l_pid; /* returned with F_GETLK */ # short l_xxx; /* reserved for future use */ BEGIN { # c2ph says: typedef='s2 l2 s2', sizeof=16 my $FLOCK_STRUCT = 's s l l s s'; sub sunos_flock { if (wantarray) { my ($type, $whence, $start, $len, $pid, $xxx) = unpack($FLOCK_STRUCT, $_[0]); return ($type, $whence, $start, $len, $pid); } else { my ($type, $whence, $start, $len, $pid) = @_; return pack($FLOCK_STRUCT, $type, $whence, $start, $len, $pid, 0); } } } # (Free)BSD struct flock: # off_t l_start; /* starting offset */ # off_t l_len; /* len = 0 means until end of file */ # pid_t l_pid; /* lock owner */ # short l_type; /* lock type: read/write, etc. */ # short l_whence; /* type of l_start */ BEGIN { # c2ph says: typedef="q2 i s2", size=24 my $FLOCK_STRUCT = 'll ll i s s'; # XXX: q is ll sub bsd_flock { if (wantarray) { my ($xxstart, $start, $xxlen, $len, $pid, $type, $whence) = unpack($FLOCK_STRUCT, $_[0]); return ($type, $whence, $start, $len, $pid); } else { my ($type, $whence, $start, $len, $pid) = @_; my ($xxstart, $xxlen) = (0,0); return pack($FLOCK_STRUCT, $xxstart, $start, $xxlen, $len, $pid, $type, $whence); } } } # alias the fcntl structure at compile time BEGIN { for ($^O) { *struct_flock = do { /bsd/ && \&bsd_flock || /linux/ && \&linux_flock || /sunos/ && \&sunos_flock || die "unknown operating system $^O, bailing out"; }; } } # install signal handler for children BEGIN { my $called = 0; sub genocide { exit if $called++; print "$$: Time to die, kiddies.\n" if $$ == $progenitor; my $job = getpgrp(); $SIG{INT} = 'IGNORE'; kill -2, $job if $job; # killpg(SIGINT, job) 1 while wait > 0; print "$$: My turn\n" if $$ == $progenitor; exit; } } END { &genocide } #----------------------------- |