|
|
Perl/FAQ/Доступ к файлам
Материал из Wiki.crossplatform.ru
[править] 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 }
#-----------------------------
|
