7. File Access

Introduction

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

Opening a File

#-----------------------------
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 $!;
#-----------------------------

Opening Files with Unusual Filenames

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

Expanding Tildes in Filenames

#-----------------------------
$filename =~ s{ ^ ~ ( [^/]* ) }
              { $1
                    ? (getpwnam($1))[7]
                    : ( $ENV{HOME} || $ENV{LOGDIR}
                         || (getpwuid($>))[7]
                       )
}ex;
#-----------------------------
#    ~user
#    ~user/blah
#    ~
#    ~/blah
#-----------------------------

Making Perl Report Filenames in Errors

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

Creating Temporary Files

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

Storing Files Inside Your Program Text

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

Writing a Filter

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

Modifying a File in Place with Temporary File

#-----------------------------
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 $_;
}
#-----------------------------

Modifying a File in Place with -i Switch

#-----------------------------
#% 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} 
#-----------------------------

Modifying a File in Place Without a Temporary File

#-----------------------------
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: $!";
#-----------------------------

Locking a File

#-----------------------------
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: $!";
#-----------------------------

Flushing Output

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

#-----------------------------

Reading from Many Filehandles Without Blocking

#-----------------------------
$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";
}
#-----------------------------

Doing Non-Blocking I/O

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

Determining the Number of Bytes to Read

#-----------------------------
$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);
#-----------------------------

Storing Filehandles in Variables

#-----------------------------
$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]);
#-----------------------------

Caching Open Output Filehandles

#-----------------------------
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 $_;
}

#-----------------------------

Printing to Many Filehandles Simultaneously

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

Opening and Closing File Descriptors by Number

#-----------------------------
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: $!";
#-----------------------------

Copying Filehandles

#-----------------------------
*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: $!";
#-----------------------------

Program: netlock

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

Program: lockarea

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

#-----------------------------