#-----------------------------
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" |