PLEAC-Perl 教程 - File Access (Perl进阶者极力推荐)

最新推荐文章于 2024-09-07 15:19:09 发布
最新推荐文章于 2024-09-07 15:19:09 发布
阅读量897 收藏
点赞数
分类专栏： C & Perl 文章标签： file perl access path filenames struct
<script type="text/javascript"> </script> <script type="text/javascript" src="http://pagead2.googlesyndication.com/pagead/show_ads.js"> </script>

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(___FCKpd___3gt;))[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 }

#-----------------------------
bsdplus
关注
专栏目录
perl file lock
ocarvb的专栏
07-02 500
原因：  有将license 的信息打印到log中的需求，这段code是call perl scripts，而多用户同时丢job会在central中同时调用该perl，所以产生同时write log的现象，这样导致log data dirty. 所以打算采用file lock 方法. 其实但从lock file的角度上是没有什么可写的，因为也是百度的他人的, 不过在自己电脑上try的时候遇到了
perl简单文本文件处理
haoren_e的专栏
07-01 8062
    中国移动游戏频道，游戏玩家套餐包中的玩家乐园游戏上线啦，很开心，作为开发人员之一，加了那么多班，眼看出了成果，激动一下下，哈哈，随之而来的是各种各样的pv、uv的数据统计。    领导问：还会写perl啊？    我答：会一些。        进入这个公司后，确实涉及到过perl脚本，所以稍稍简单的还能写，所以对于领导交代的access_log日志的处理，我写完了，贴到自己
PLEAC-Perl 教程 - Database Access (Perl进阶者极力推荐)
OpenBSD 咨询与维护
05-04 1342
14. Database Access<!--google_ad_client = "pub-5143338080895292";/* 728x90, created 4/10/08 */google_ad_slot = "8165396160";google_ad_width = 728;google_ad_height = 90;//--> <script ty
Perl 语言进阶学习
power_9的博客
07-10 926
本文详细介绍了 Perl 语言的高级特性，包括高级数据结构、引用、面向对象编程、异常处理、文件操作、网络编程、数据库操作、自动化测试和模块开发等内容。通过掌握这些高级功能，您可以在更复杂的编程任务中游刃有余，提升编程效率和代码质量。希望本文能帮助您进一步深入学习 Perl 语言，并在实际项目中发挥其强大功能。
perl脚本调用openssh不能正确执行（ctl_dir /root/.libnet-openssh-perl/ is not secure）的原因排查
haiqinma的专栏
08-03 771
perl脚本使用Net::OpenSSH提示不能访问指定节点，手动操作ssh登录正常，问题排查
Nginx(二十)nginx配置perl
wzj_110的博客
01-21 1893
++++++'基本原理'++++++ nginx本身不能处理PHP，它只是个web服务器，当接收到请求后，如果是php请求，则发给php解释器处理，并把结果返回给客户端。 nginx一般是把请求发fastcgi管理进程处理，fascgi管理进程选择cgi子进程处理结果并返回被nginx。 nginx无法解析'PHP、perl、python'程序,一开启网页就'直接下载'程序 (1)先检查PHP环境 (2)再检查php-fpm nginx默认并不支持php等动态语言，可以使用fastcgi来使用.
使用MySQLTuner-perl对MySQL进行优化
热门推荐
神棍之路
11-09 7万+
项目地址https://github.com/major/MySQLTuner-perl.git 抄一把说明，不翻译了，累…… MySQLTuner is a script written in Perl that allows you to review a MySQL installation quickly and make adjustments to increase per
ARM cortex M0 verification script --- Perl
定戒慧
07-19 4304
ARM cortex M0 verification script --- Perl
各个平台下 Perl 源码安装教程
BioIT爱好者的博客
08-06 2031
![How-To-Install-Perl.jpeg](https://imgconvert.csdnimg.cn/aHR0cHM6Ly9jZG4ubmxhcmsuY29tL3l1cXVlLzAvMjAyMC9qcGVnLzEyNjAzMi8xNTkyNTUwNDE2NjgzLWE5NjlhMTA2LTlkYmUtNGMzNi04ODA4LWM0NzYyZmM1Njc0MS5qcGVn?x-oss-process=image/format,png#align=left&display=inline&
perl-lwp笔记
麦好的AI乐园
11-22 1743
perl的LWP模块介绍 一 LWP::Simple 功能 1. 如何在Perl中使用该模块？ use LWP::Simple; 2. 如何获取一个页面内容？ my $content = get(’http://www.yahoo.com.cn’); get函数把从www.yahoo.com.cn上获取得页面内容全部赋给$content这个变量，如果获取失败将返回一
Intermediate Perl.pdf
08-18
Create, access, and print arbitrarily deep and nested data structures, including arrays of arrays and hashes of hashes. Chapter 7, Subroutine References Capture behavior as an anonymous subroutine ...
matlab导入excel代码-utl_import_file_with_multiple_record_types:导入具有多种记录类型的文
05-21
matlab导入excel代码utl_import_file_with_multiple_record_types 导入具有多种记录类型的文件。 关键字：sas sql join合并大数据分析宏oracle teradata mysql sas社区stackoverflow statistics人工智慧AI Python R ...
perl中 -e, -z, -s, -M, -A, -C, -r, -w, -x, -o, -f, -d , -l 含义
qq_21478261的博客
04-08 9620
Description taken from the official documentation of Perl: -r File is readable by effective uid/gid. -w File is writable by effective uid/gid. -x File is executable by effective uid/gid. -o File i...
perl的学习记录——仿真regression
u011974971的博客
09-07 926
之前只知道有这个强大语言的存在，但一直侥幸自己应该不会用到它，所以一直没有开始学习。然而人生这么长，怎就确定自己不会用到呢？这次要搭建一个可以自动跑完所有case并且打印每个case的pass信息到指定的文件中。从而减轻手动跑仿真，手动查看log信息的重复无效低质量的操作。下面简单记录下自己的思路并贴出自己的代码，方便自己以后使用和修正。
经济补偿金、赔偿金的核定及劳动合同解除后双方的义务.ppt
09-14
经济补偿金、赔偿金的核定及劳动合同解除后双方的义务.ppt
配电网分布式电源和储能选址定容 以配电网总成本最低为目标函数，其中包括年运行成本，设备维护折损成本、环境成本；以系统潮流运行为约
09-14
配电网分布式电源和储能选址定容 以配电网总成本最低为目标函数，其中包括年运行成本，设备维护折损成本、环境成本；以系统潮流运行为约束条件，采用粒子群算法求解，实现光伏、风电、储能设备的规划。 这是一个使用粒子群算法进行优化的程序。下面我将对程序进行详细的分析和解释。 首先，程序开始时加载了一些数据文件，包括光伏、风电和负荷的数据。然后，定义了一些参数，如蓄电池参数、迭代次数、种群大小、速度更新参数等。 接下来，程序进行了种群的初始化。使用随机数生成种群的初始位置，并初始化速度。然后，对种群中的每个个体进行潮流计算，并计算适应度。适应度的计算包括对电压、网损等进行评估，并考虑了一些约束条件，如储能容量、光伏容量等的限制。 接下来，程序进行了迭代优化过程。在每次迭代中，根据当前的速度和位置，更新粒子的速度和位置。然后，对更新后的粒子进行潮流计算，并计算适应度。如果个体的适应度优于个体历史最佳适应度，则更新个体历史最佳适应度和位置。如果个体的适应度优于全局最佳适应度，则更新全局最佳适应度和位置。 程序通过迭代优化过程不断更新粒子的速度和位置，直到达到指定的迭代次数。最后，程序输出优化结
Cpp-halcono-pencv互相转换
最新发布
09-14
Cpp_halcon_opencv互相转换 python halcon_opencv图像变量互相转换 C++ halcon 和opencv 图像变量互相转换 VS2022工程 无需配置环境即可 使用绝对路径 无需配置 无需配置 无需配置 下载即可编译生成 仅限交流学习使用;仅限交流学习使用;仅限交流学习使用;
××部20xx年人员裁员分流方案表.xlsx
09-14
××部20xx年人员裁员分流方案表.xlsx
『人事流程图新』会前准备工作管理流程图.docx
09-14
『人事流程图新』会前准备工作管理流程图.docx
perl使用华为云SDK
04-04
作为语言，Perl可以使用华为云SDK进行API调用。下面是一个使用华为云对象存储服务的示例： ```perl #!/usr/bin/perl use strict; use warnings; use utf8; use HuaweiCloud::OBS::Client; # 创建OBS客户端对象 ...
评论
添加红包

请填写红包祝福语或标题

个

红包个数最小为10个

元

红包金额最低5元

当前余额3.43元 前往充值 >
需支付：10.00元
成就一亿技术人!
领取后你会自动成为博主和红包主的粉丝 规则
hope_wisdom
发出的红包
实付元
使用余额支付
点击重新获取
扫码支付
钱包余额 0

抵扣说明：

1.余额是钱包充值的虚拟货币，按照1:1的比例进行支付金额的抵扣。
2.余额无法直接购买下载，可以购买VIP、付费专栏及课程。

余额充值