diff options
author | Karl Williamson <khw@cpan.org> | 2016-03-11 14:43:33 -0700 |
---|---|---|
committer | Karl Williamson <khw@cpan.org> | 2016-03-11 14:49:26 -0700 |
commit | e46aa1ddb7d58d270bbc45cef016b0577cfdecaa (patch) | |
tree | 2c2bae16536e85b2786e98dda62579ffa5c90c27 /pod | |
parent | fa6c7d00a8b0cf48c0f78066f87065cfb43d601b (diff) | |
download | perl-e46aa1ddb7d58d270bbc45cef016b0577cfdecaa.tar.gz |
Fix various pod errors.
Mostly these are too long verbatim lines.
Diffstat (limited to 'pod')
-rw-r--r-- | pod/perlcall.pod | 91 | ||||
-rw-r--r-- | pod/perlfunc.pod | 72 | ||||
-rw-r--r-- | pod/perlguts.pod | 17 | ||||
-rw-r--r-- | pod/perliol.pod | 91 | ||||
-rw-r--r-- | pod/perlipc.pod | 442 | ||||
-rw-r--r-- | pod/perllol.pod | 29 | ||||
-rw-r--r-- | pod/perlmodstyle.pod | 3 | ||||
-rw-r--r-- | pod/perlnewmod.pod | 4 | ||||
-rw-r--r-- | pod/perlperf.pod | 25 | ||||
-rw-r--r-- | pod/perlrun.pod | 2 | ||||
-rw-r--r-- | pod/perltie.pod | 198 |
11 files changed, 503 insertions, 471 deletions
diff --git a/pod/perlcall.pod b/pod/perlcall.pod index c405153945..c41d835791 100644 --- a/pod/perlcall.pod +++ b/pod/perlcall.pod @@ -910,48 +910,48 @@ result, the subroutine calls I<die>. and some C to call it - static void - call_Subtract(a, b) - int a; - int b; - { - dSP; - int count; - SV *err_tmp; - - ENTER; - SAVETMPS; - - PUSHMARK(SP); - EXTEND(SP, 2); - PUSHs(sv_2mortal(newSViv(a))); - PUSHs(sv_2mortal(newSViv(b))); - PUTBACK; - - count = call_pv("Subtract", G_EVAL|G_SCALAR); - - SPAGAIN; - - /* Check the eval first */ - err_tmp = ERRSV; - if (SvTRUE(err_tmp)) - { - printf ("Uh oh - %s\n", SvPV_nolen(err_tmp)); - POPs; - } - else - { - if (count != 1) - croak("call_Subtract: wanted 1 value from 'Subtract', got %d\n", - count); - - printf ("%d - %d = %d\n", a, b, POPi); - } - - PUTBACK; - FREETMPS; - LEAVE; - } + static void + call_Subtract(a, b) + int a; + int b; + { + dSP; + int count; + SV *err_tmp; + + ENTER; + SAVETMPS; + + PUSHMARK(SP); + EXTEND(SP, 2); + PUSHs(sv_2mortal(newSViv(a))); + PUSHs(sv_2mortal(newSViv(b))); + PUTBACK; + + count = call_pv("Subtract", G_EVAL|G_SCALAR); + + SPAGAIN; + + /* Check the eval first */ + err_tmp = ERRSV; + if (SvTRUE(err_tmp)) + { + printf ("Uh oh - %s\n", SvPV_nolen(err_tmp)); + POPs; + } + else + { + if (count != 1) + croak("call_Subtract: wanted 1 value from 'Subtract', got %d\n", + count); + + printf ("%d - %d = %d\n", a, b, POPi); + } + + PUTBACK; + FREETMPS; + LEAVE; + } If I<call_Subtract> is called thus @@ -1909,9 +1909,10 @@ done inside our C code: ... - SV *cvrv = eval_pv("sub { - print 'You will not find me cluttering any namespace!' - }", TRUE); + SV *cvrv + = eval_pv("sub { + print 'You will not find me cluttering any namespace!' + }", TRUE); ... diff --git a/pod/perlfunc.pod b/pod/perlfunc.pod index 7cb162a3c9..18d2e4065c 100644 --- a/pod/perlfunc.pod +++ b/pod/perlfunc.pod @@ -943,12 +943,12 @@ With EXPR, it returns some extra information that the debugger uses to print a stack trace. The value of EXPR indicates how many call frames to go back before the current one. - # 0 1 2 3 4 - my ($package, $filename, $line, $subroutine, $hasargs, + # 0 1 2 3 4 + my ($package, $filename, $line, $subroutine, $hasargs, - # 5 6 7 8 9 10 - $wantarray, $evaltext, $is_require, $hints, $bitmask, $hinthash) - = caller($i); + # 5 6 7 8 9 10 + $wantarray, $evaltext, $is_require, $hints, $bitmask, $hinthash) + = caller($i); Here, $subroutine is the function that the caller called (rather than the function containing the caller). Note that $subroutine may be C<(eval)> if @@ -3472,7 +3472,7 @@ X<join> Joins the separate strings of LIST into a single string with fields separated by the value of EXPR, and returns that new string. Example: - my $rec = join(':', $login,$passwd,$uid,$gid,$gcos,$home,$shell); + my $rec = join(':', $login,$passwd,$uid,$gid,$gcos,$home,$shell); Beware that unlike L<C<split>|/split E<sol>PATTERNE<sol>,EXPR,LIMIT>, L<C<join>|/join EXPR,LIST> doesn't take a pattern as its first argument. @@ -4020,14 +4020,14 @@ encounters the missing (or unexpected) comma. The syntax error will be reported close to the C<}>, but you'll need to change something near the C<{> such as using a unary C<+> or semicolon to give Perl some help: - my %hash = map { "\L$_" => 1 } @array # perl guesses EXPR. wrong - my %hash = map { +"\L$_" => 1 } @array # perl guesses BLOCK. right - my %hash = map {; "\L$_" => 1 } @array # this also works - my %hash = map { ("\L$_" => 1) } @array # as does this - my %hash = map { lc($_) => 1 } @array # and this. - my %hash = map +( lc($_) => 1 ), @array # this is EXPR and works! + my %hash = map { "\L$_" => 1 } @array # perl guesses EXPR. wrong + my %hash = map { +"\L$_" => 1 } @array # perl guesses BLOCK. right + my %hash = map {; "\L$_" => 1 } @array # this also works + my %hash = map { ("\L$_" => 1) } @array # as does this + my %hash = map { lc($_) => 1 } @array # and this. + my %hash = map +( lc($_) => 1 ), @array # this is EXPR and works! - my %hash = map ( lc($_), 1 ), @array # evaluates to (1, @array) + my %hash = map ( lc($_), 1 ), @array # evaluates to (1, @array) or to force an anon hash constructor use C<+{>: @@ -4427,28 +4427,29 @@ See L<perliol> for detailed info on PerlIO. General examples: - open(my $log, ">>", "/usr/spool/news/twitlog"); - # if the open fails, output is discarded + open(my $log, ">>", "/usr/spool/news/twitlog"); + # if the open fails, output is discarded - open(my $dbase, "+<", "dbase.mine") # open for update - or die "Can't open 'dbase.mine' for update: $!"; + open(my $dbase, "+<", "dbase.mine") # open for update + or die "Can't open 'dbase.mine' for update: $!"; - open(my $dbase, "+<dbase.mine") # ditto - or die "Can't open 'dbase.mine' for update: $!"; + open(my $dbase, "+<dbase.mine") # ditto + or die "Can't open 'dbase.mine' for update: $!"; - open(my $article_fh, "-|", "caesar <$article") # decrypt article - or die "Can't start caesar: $!"; + open(my $article_fh, "-|", "caesar <$article") # decrypt + # article + or die "Can't start caesar: $!"; - open(my $article_fh, "caesar <$article |") # ditto - or die "Can't start caesar: $!"; + open(my $article_fh, "caesar <$article |") # ditto + or die "Can't start caesar: $!"; - open(my $out_fh, "|-", "sort >Tmp$$") # $$ is our process id - or die "Can't start sort: $!"; + open(my $out_fh, "|-", "sort >Tmp$$") # $$ is our process id + or die "Can't start sort: $!"; - # in-memory files - open(my $memory, ">", \$var) - or die "Can't open memory file: $!"; - print $memory "foo!\n"; # output will appear in $var + # in-memory files + open(my $memory, ">", \$var) + or die "Can't open memory file: $!"; + print $memory "foo!\n"; # output will appear in $var You may also, in the Bourne shell tradition, specify an EXPR beginning with C<< >& >>, in which case the rest of the string is interpreted @@ -4528,11 +4529,11 @@ Use C<defined($pid)> or C<//> to determine whether the open was successful. For example, use either - my $child_pid = open(my $from_kid, "-|") // die "Can't fork: $!"; + my $child_pid = open(my $from_kid, "-|") // die "Can't fork: $!"; or - my $child_pid = open(my $to_kid, "|-") // die "Can't fork: $!"; + my $child_pid = open(my $to_kid, "|-") // die "Can't fork: $!"; followed by @@ -6761,13 +6762,14 @@ subroutine like this: The usual idiom is: - my ($nfound, $timeleft) = - select(my $rout = $rin, my $wout = $win, my $eout = $ein, $timeout); + my ($nfound, $timeleft) = + select(my $rout = $rin, my $wout = $win, my $eout = $ein, + $timeout); or to block until something becomes ready just do this - my $nfound = - select(my $rout = $rin, my $wout = $win, my $eout = $ein, undef); + my $nfound = + select(my $rout = $rin, my $wout = $win, my $eout = $ein, undef); Most systems do not bother to return anything useful in C<$timeleft>, so calling L<C<select>|/select RBITS,WBITS,EBITS,TIMEOUT> in scalar context diff --git a/pod/perlguts.pod b/pod/perlguts.pod index 8091fe50a6..ba6cd16692 100644 --- a/pod/perlguts.pod +++ b/pod/perlguts.pod @@ -341,14 +341,15 @@ copy-on-write is skipped. First have a look at an empty string: Notice here the LEN is 10. (It may differ on your platform.) Extend the length of the string to one less than 10, and do a substitution: - % ./perl -Ilib -MDevel::Peek -le '$a=""; $a.="123456789"; $a=~s/.//; Dump($a)' - SV = PV(0x7ffa04008a70) at 0x7ffa04030390 - REFCNT = 1 - FLAGS = (POK,OOK,pPOK) - OFFSET = 1 - PV = 0x7ffa03c05b61 ( "\1" . ) "23456789"\0 - CUR = 8 - LEN = 9 + % ./perl -Ilib -MDevel::Peek -le '$a=""; $a.="123456789"; $a=~s/.//; \ + Dump($a)' + SV = PV(0x7ffa04008a70) at 0x7ffa04030390 + REFCNT = 1 + FLAGS = (POK,OOK,pPOK) + OFFSET = 1 + PV = 0x7ffa03c05b61 ( "\1" . ) "23456789"\0 + CUR = 8 + LEN = 9 Here the number of bytes chopped off (1) is shown next as the OFFSET. The portion of the string between the "real" and the "fake" beginnings is diff --git a/pod/perliol.pod b/pod/perliol.pod index ab600bd3b2..55aaf147f7 100644 --- a/pod/perliol.pod +++ b/pod/perliol.pod @@ -135,45 +135,51 @@ member of C<PerlIOl>. The functions (methods of the layer "class") are fixed, and are defined by the C<PerlIO_funcs> type. They are broadly the same as the public C<PerlIO_xxxxx> functions: - struct _PerlIO_funcs - { - Size_t fsize; - char * name; - Size_t size; - IV kind; - IV (*Pushed)(pTHX_ PerlIO *f,const char *mode,SV *arg, PerlIO_funcs *tab); - IV (*Popped)(pTHX_ PerlIO *f); - PerlIO * (*Open)(pTHX_ PerlIO_funcs *tab, - PerlIO_list_t *layers, IV n, - const char *mode, - int fd, int imode, int perm, - PerlIO *old, - int narg, SV **args); - IV (*Binmode)(pTHX_ PerlIO *f); - SV * (*Getarg)(pTHX_ PerlIO *f, CLONE_PARAMS *param, int flags) - IV (*Fileno)(pTHX_ PerlIO *f); - PerlIO * (*Dup)(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags) - /* Unix-like functions - cf sfio line disciplines */ - SSize_t (*Read)(pTHX_ PerlIO *f, void *vbuf, Size_t count); - SSize_t (*Unread)(pTHX_ PerlIO *f, const void *vbuf, Size_t count); - SSize_t (*Write)(pTHX_ PerlIO *f, const void *vbuf, Size_t count); - IV (*Seek)(pTHX_ PerlIO *f, Off_t offset, int whence); - Off_t (*Tell)(pTHX_ PerlIO *f); - IV (*Close)(pTHX_ PerlIO *f); - /* Stdio-like buffered IO functions */ - IV (*Flush)(pTHX_ PerlIO *f); - IV (*Fill)(pTHX_ PerlIO *f); - IV (*Eof)(pTHX_ PerlIO *f); - IV (*Error)(pTHX_ PerlIO *f); - void (*Clearerr)(pTHX_ PerlIO *f); - void (*Setlinebuf)(pTHX_ PerlIO *f); - /* Perl's snooping functions */ - STDCHAR * (*Get_base)(pTHX_ PerlIO *f); - Size_t (*Get_bufsiz)(pTHX_ PerlIO *f); - STDCHAR * (*Get_ptr)(pTHX_ PerlIO *f); - SSize_t (*Get_cnt)(pTHX_ PerlIO *f); - void (*Set_ptrcnt)(pTHX_ PerlIO *f,STDCHAR *ptr,SSize_t cnt); - }; + struct _PerlIO_funcs + { + Size_t fsize; + char * name; + Size_t size; + IV kind; + IV (*Pushed)(pTHX_ PerlIO *f, + const char *mode, + SV *arg, + PerlIO_funcs *tab); + IV (*Popped)(pTHX_ PerlIO *f); + PerlIO * (*Open)(pTHX_ PerlIO_funcs *tab, + PerlIO_list_t *layers, IV n, + const char *mode, + int fd, int imode, int perm, + PerlIO *old, + int narg, SV **args); + IV (*Binmode)(pTHX_ PerlIO *f); + SV * (*Getarg)(pTHX_ PerlIO *f, CLONE_PARAMS *param, int flags) + IV (*Fileno)(pTHX_ PerlIO *f); + PerlIO * (*Dup)(pTHX_ PerlIO *f, + PerlIO *o, + CLONE_PARAMS *param, + int flags) + /* Unix-like functions - cf sfio line disciplines */ + SSize_t (*Read)(pTHX_ PerlIO *f, void *vbuf, Size_t count); + SSize_t (*Unread)(pTHX_ PerlIO *f, const void *vbuf, Size_t count); + SSize_t (*Write)(pTHX_ PerlIO *f, const void *vbuf, Size_t count); + IV (*Seek)(pTHX_ PerlIO *f, Off_t offset, int whence); + Off_t (*Tell)(pTHX_ PerlIO *f); + IV (*Close)(pTHX_ PerlIO *f); + /* Stdio-like buffered IO functions */ + IV (*Flush)(pTHX_ PerlIO *f); + IV (*Fill)(pTHX_ PerlIO *f); + IV (*Eof)(pTHX_ PerlIO *f); + IV (*Error)(pTHX_ PerlIO *f); + void (*Clearerr)(pTHX_ PerlIO *f); + void (*Setlinebuf)(pTHX_ PerlIO *f); + /* Perl's snooping functions */ + STDCHAR * (*Get_base)(pTHX_ PerlIO *f); + Size_t (*Get_bufsiz)(pTHX_ PerlIO *f); + STDCHAR * (*Get_ptr)(pTHX_ PerlIO *f); + SSize_t (*Get_cnt)(pTHX_ PerlIO *f); + void (*Set_ptrcnt)(pTHX_ PerlIO *f,STDCHAR *ptr,SSize_t cnt); + }; The first few members of the struct give a function table size for compatibility check "name" for the layer, the size to C<malloc> for the per-instance data, @@ -443,7 +449,7 @@ flag is used it's up to the layer to validate the args. =item Pushed - IV (*Pushed)(pTHX_ PerlIO *f,const char *mode, SV *arg); + IV (*Pushed)(pTHX_ PerlIO *f,const char *mode, SV *arg); The only absolutely mandatory method. Called when the layer is pushed onto the stack. The C<mode> argument may be NULL if this occurs @@ -837,8 +843,9 @@ The following table summarizes the behaviour: Unread PerlIOBase_unread Write FAILURE - FAILURE Set errno (to EINVAL in Unixish, to LIB$_INVARG in VMS) and - return -1 (for numeric return values) or NULL (for pointers) + FAILURE Set errno (to EINVAL in Unixish, to LIB$_INVARG in VMS) + and return -1 (for numeric return values) or NULL (for + pointers) INHERITED Inherited from the layer below SUCCESS Return 0 (for numeric return values) or a pointer diff --git a/pod/perlipc.pod b/pod/perlipc.pod index 6be276384e..e3b74a55b9 100644 --- a/pod/perlipc.pod +++ b/pod/perlipc.pod @@ -316,8 +316,9 @@ Instead of setting C<$SIG{ALRM}>: try something like the following: - use POSIX qw(SIGALRM); - POSIX::sigaction(SIGALRM, POSIX::SigAction->new(sub { die "alarm" })) + use POSIX qw(SIGALRM); + POSIX::sigaction(SIGALRM, + POSIX::SigAction->new(sub { die "alarm" })) || die "Error setting SIGALRM handler: $!\n"; Another way to disable the safe signal behavior locally is to use @@ -515,17 +516,17 @@ containing the directory from which it was launched, and redirect its standard file descriptors from and to F</dev/null> so that random output doesn't wind up on the user's terminal. - use POSIX "setsid"; + use POSIX "setsid"; - sub daemonize { - chdir("/") || die "can't chdir to /: $!"; - open(STDIN, "< /dev/null") || die "can't read /dev/null: $!"; - open(STDOUT, "> /dev/null") || die "can't write to /dev/null: $!"; - defined(my $pid = fork()) || die "can't fork: $!"; - exit if $pid; # non-zero now means I am the parent - (setsid() != -1) || die "Can't start a new session: $!"; - open(STDERR, ">&STDOUT") || die "can't dup stdout: $!"; - } + sub daemonize { + chdir("/") || die "can't chdir to /: $!"; + open(STDIN, "< /dev/null") || die "can't read /dev/null: $!"; + open(STDOUT, "> /dev/null") || die "can't write to /dev/null: $!"; + defined(my $pid = fork()) || die "can't fork: $!"; + exit if $pid; # non-zero now means I am the parent + (setsid() != -1) || die "Can't start a new session: $!"; + open(STDERR, ">&STDOUT") || die "can't dup stdout: $!"; + } The fork() has to come before the setsid() to ensure you aren't a process group leader; the setsid() will fail if you are. If your @@ -812,70 +813,70 @@ this together by hand. This example only talks to itself, but you could reopen the appropriate handles to STDIN and STDOUT and call other processes. (The following example lacks proper error checking.) - #!/usr/bin/perl -w - # pipe1 - bidirectional communication using two pipe pairs - # designed for the socketpair-challenged - use IO::Handle; # thousands of lines just for autoflush :-( - pipe(PARENT_RDR, CHILD_WTR); # XXX: check failure? - pipe(CHILD_RDR, PARENT_WTR); # XXX: check failure? - CHILD_WTR->autoflush(1); - PARENT_WTR->autoflush(1); - - if ($pid = fork()) { - close PARENT_RDR; - close PARENT_WTR; - print CHILD_WTR "Parent Pid $$ is sending this\n"; - chomp($line = <CHILD_RDR>); - print "Parent Pid $$ just read this: '$line'\n"; - close CHILD_RDR; close CHILD_WTR; - waitpid($pid, 0); - } else { - die "cannot fork: $!" unless defined $pid; - close CHILD_RDR; - close CHILD_WTR; - chomp($line = <PARENT_RDR>); - print "Child Pid $$ just read this: '$line'\n"; - print PARENT_WTR "Child Pid $$ is sending this\n"; - close PARENT_RDR; - close PARENT_WTR; - exit(0); - } + #!/usr/bin/perl -w + # pipe1 - bidirectional communication using two pipe pairs + # designed for the socketpair-challenged + use IO::Handle; # thousands of lines just for autoflush :-( + pipe(PARENT_RDR, CHILD_WTR); # XXX: check failure? + pipe(CHILD_RDR, PARENT_WTR); # XXX: check failure? + CHILD_WTR->autoflush(1); + PARENT_WTR->autoflush(1); + + if ($pid = fork()) { + close PARENT_RDR; + close PARENT_WTR; + print CHILD_WTR "Parent Pid $$ is sending this\n"; + chomp($line = <CHILD_RDR>); + print "Parent Pid $$ just read this: '$line'\n"; + close CHILD_RDR; close CHILD_WTR; + waitpid($pid, 0); + } else { + die "cannot fork: $!" unless defined $pid; + close CHILD_RDR; + close CHILD_WTR; + chomp($line = <PARENT_RDR>); + print "Child Pid $$ just read this: '$line'\n"; + print PARENT_WTR "Child Pid $$ is sending this\n"; + close PARENT_RDR; + close PARENT_WTR; + exit(0); + } But you don't actually have to make two pipe calls. If you have the socketpair() system call, it will do this all for you. - #!/usr/bin/perl -w - # pipe2 - bidirectional communication using socketpair - # "the best ones always go both ways" - - use Socket; - use IO::Handle; # thousands of lines just for autoflush :-( - - # We say AF_UNIX because although *_LOCAL is the - # POSIX 1003.1g form of the constant, many machines - # still don't have it. - socketpair(CHILD, PARENT, AF_UNIX, SOCK_STREAM, PF_UNSPEC) - || die "socketpair: $!"; - - CHILD->autoflush(1); - PARENT->autoflush(1); - - if ($pid = fork()) { - close PARENT; - print CHILD "Parent Pid $$ is sending this\n"; - chomp($line = <CHILD>); - print "Parent Pid $$ just read this: '$line'\n"; - close CHILD; - waitpid($pid, 0); - } else { - die "cannot fork: $!" unless defined $pid; - close CHILD; - chomp($line = <PARENT>); - print "Child Pid $$ just read this: '$line'\n"; - print PARENT "Child Pid $$ is sending this\n"; - close PARENT; - exit(0); - } + #!/usr/bin/perl -w + # pipe2 - bidirectional communication using socketpair + # "the best ones always go both ways" + + use Socket; + use IO::Handle; # thousands of lines just for autoflush :-( + + # We say AF_UNIX because although *_LOCAL is the + # POSIX 1003.1g form of the constant, many machines + # still don't have it. + socketpair(CHILD, PARENT, AF_UNIX, SOCK_STREAM, PF_UNSPEC) + || die "socketpair: $!"; + + CHILD->autoflush(1); + PARENT->autoflush(1); + + if ($pid = fork()) { + close PARENT; + print CHILD "Parent Pid $$ is sending this\n"; + chomp($line = <CHILD>); + print "Parent Pid $$ just read this: '$line'\n"; + close CHILD; + waitpid($pid, 0); + } else { + die "cannot fork: $!" unless defined $pid; + close CHILD; + chomp($line = <PARENT>); + print "Child Pid $$ just read this: '$line'\n"; + print PARENT "Child Pid $$ is sending this\n"; + close PARENT; + exit(0); + } =head1 Sockets: Client/Server Communication @@ -954,131 +955,133 @@ the appropriate interface on multihomed hosts. If you want sit on a particular interface (like the external side of a gateway or firewall machine), fill this in with your real address instead. - #!/usr/bin/perl -Tw - use strict; - BEGIN { $ENV{PATH} = "/usr/bin:/bin" } - use Socket; - use Carp; - my $EOL = "\015\012"; + #!/usr/bin/perl -Tw + use strict; + BEGIN { $ENV{PATH} = "/usr/bin:/bin" } + use Socket; + use Carp; + my $EOL = "\015\012"; - sub logmsg { print "$0 $$: @_ at ", scalar localtime(), "\n" } + sub logmsg { print "$0 $$: @_ at ", scalar localtime(), "\n" } - my $port = shift || 2345; - die "invalid port" unless $port =~ /^ \d+ $/x; + my $port = shift || 2345; + die "invalid port" unless $port =~ /^ \d+ $/x; - my $proto = getprotobyname("tcp"); + my $proto = getprotobyname("tcp"); - socket(Server, PF_INET, SOCK_STREAM, $proto) || die "socket: $!"; - setsockopt(Server, SOL_SOCKET, SO_REUSEADDR, pack("l", 1)) - || die "setsockopt: $!"; - bind(Server, sockaddr_in($port, INADDR_ANY)) || die "bind: $!"; - listen(Server, SOMAXCONN) || die "listen: $!"; + socket(Server, PF_INET, SOCK_STREAM, $proto) || die "socket: $!"; + setsockopt(Server, SOL_SOCKET, SO_REUSEADDR, pack("l", 1)) + || die "setsockopt: $!"; + bind(Server, sockaddr_in($port, INADDR_ANY)) || die "bind: $!"; + listen(Server, SOMAXCONN) || die "listen: $!"; - logmsg "server started on port $port"; + logmsg "server started on port $port"; - my $paddr; + my $paddr; - for ( ; $paddr = accept(Client, Server); close Client) { - my($port, $iaddr) = sockaddr_in($paddr); - my $name = gethostbyaddr($iaddr, AF_INET); + for ( ; $paddr = accept(Client, Server); close Client) { + my($port, $iaddr) = sockaddr_in($paddr); + my $name = gethostbyaddr($iaddr, AF_INET); - logmsg "connection from $name [", - inet_ntoa($iaddr), "] - at port $port"; + logmsg "connection from $name [", + inet_ntoa($iaddr), "] + at port $port"; - print Client "Hello there, $name, it's now ", - scalar localtime(), $EOL; - } + print Client "Hello there, $name, it's now ", + scalar localtime(), $EOL; + } And here's a multitasking version. It's multitasked in that like most typical servers, it spawns (fork()s) a slave server to handle the client request so that the master server can quickly go back to service a new client. - #!/usr/bin/perl -Tw - use strict; - BEGIN { $ENV{PATH} = "/usr/bin:/bin" } - use Socket; - use Carp; - my $EOL = "\015\012"; - - sub spawn; # forward declaration - sub logmsg { print "$0 $$: @_ at ", scalar localtime(), "\n" } - - my $port = shift || 2345; - die "invalid port" unless $port =~ /^ \d+ $/x; + #!/usr/bin/perl -Tw + use strict; + BEGIN { $ENV{PATH} = "/usr/bin:/bin" } + use Socket; + use Carp; + my $EOL = "\015\012"; - my $proto = getprotobyname("tcp"); + sub spawn; # forward declaration + sub logmsg { print "$0 $$: @_ at ", scalar localtime(), "\n" } - socket(Server, PF_INET, SOCK_STREAM, $proto) || die "socket: $!"; - setsockopt(Server, SOL_SOCKET, SO_REUSEADDR, pack("l", 1)) - || die "setsockopt: $!"; - bind(Server, sockaddr_in($port, INADDR_ANY)) || die "bind: $!"; - listen(Server, SOMAXCONN) || die "listen: $!"; + my $port = shift || 2345; + die "invalid port" unless $port =~ /^ \d+ $/x; - logmsg "server started on port $port"; + my $proto = getprotobyname("tcp"); - my $waitedpid = 0; - my $paddr; + socket(Server, PF_INET, SOCK_STREAM, $proto) || die "socket: $!"; + setsockopt(Server, SOL_SOCKET, SO_REUSEADDR, pack("l", 1)) + || die "setsockopt: $!"; + bind(Server, sockaddr_in($port, INADDR_ANY)) || die "bind: $!"; + listen(Server, SOMAXCONN) || die "listen: $!"; - use POSIX ":sys_wait_h"; - use Errno; + logmsg "server started on port $port"; - sub REAPER { - local $!; # don't let waitpid() overwrite current error - while ((my $pid = waitpid(-1, WNOHANG)) > 0 && WIFEXITED($?)) { - logmsg "reaped $waitedpid" . ($? ? " with exit $?" : ""); - } - $SIG{CHLD} = \&REAPER; # loathe SysV - } + my $waitedpid = 0; + my $paddr; - $SIG{CHLD} = \&REAPER; + use POSIX ":sys_wait_h"; + use Errno; - while (1) { - $paddr = accept(Client, Server) || do { - # try again if accept() returned because got a signal - next if $!{EINTR}; - die "accept: $!"; - }; - my ($port, $iaddr) = sockaddr_in($paddr); - my $name = gethostbyaddr($iaddr, AF_INET); - - logmsg "connection from $name [", - inet_ntoa($iaddr), - "] at port $port"; + sub REAPER { + local $!; # don't let waitpid() overwrite current error + while ((my $pid = waitpid(-1, WNOHANG)) > 0 && WIFEXITED($?)) { + logmsg "reaped $waitedpid" . ($? ? " with exit $?" : ""); + } + $SIG{CHLD} = \&REAPER; # loathe SysV + } - spawn sub { - $| = 1; - print "Hello there, $name, it's now ", scalar localtime(), $EOL; - exec "/usr/games/fortune" # XXX: "wrong" line terminators - or confess "can't exec fortune: $!"; - }; - close Client; - } + $SIG{CHLD} = \&REAPER; + + while (1) { + $paddr = accept(Client, Server) || do { + # try again if accept() returned because got a signal + next if $!{EINTR}; + die "accept: $!"; + }; + my ($port, $iaddr) = sockaddr_in($paddr); + my $name = gethostbyaddr($iaddr, AF_INET); + + logmsg "connection from $name [", + inet_ntoa($iaddr), + "] at port $port"; + + spawn sub { + $| = 1; + print "Hello there, $name, it's now ", + scalar localtime(), + $EOL; + exec "/usr/games/fortune" # XXX: "wrong" line terminators + or confess "can't exec fortune: $!"; + }; + close Client; + } - sub spawn { - my $coderef = shift; + sub spawn { + my $coderef = shift; - unless (@_ == 0 && $coderef && ref($coderef) eq "CODE") { - confess "usage: spawn CODEREF"; - } + unless (@_ == 0 && $coderef && ref($coderef) eq "CODE") { + confess "usage: spawn CODEREF"; + } - my $pid; - unless (defined($pid = fork())) { - logmsg "cannot fork: $!"; - return; - } - elsif ($pid) { - logmsg "begat $pid"; - return; # I'm the parent - } - # else I'm the child -- go spawn + my $pid; + unless (defined($pid = fork())) { + logmsg "cannot fork: $!"; + return; + } + elsif ($pid) { + logmsg "begat $pid"; + return; # I'm the parent + } + # else I'm the child -- go spawn - open(STDIN, "<&Client") || die "can't dup client to stdin"; - open(STDOUT, ">&Client") || die "can't dup client to stdout"; - ## open(STDERR, ">&STDOUT") || die "can't dup stdout to stderr"; - exit($coderef->()); - } + open(STDIN, "<&Client") || die "can't dup client to stdin"; + open(STDOUT, ">&Client") || die "can't dup client to stdout"; + ## open(STDERR, ">&STDOUT") || die "can't dup stdout to stderr"; + exit($coderef->()); + } This server takes the trouble to clone off a child version via fork() for each incoming request. That way it can handle many requests at @@ -1294,7 +1297,7 @@ that the server there cares to provide. PeerAddr => "localhost", PeerPort => "daytime(13)", ) - || die "can't connect to daytime service on localhost"; + || die "can't connect to daytime service on localhost"; while (<$remote>) { print } When you run this program, you should get something back that @@ -1569,15 +1572,16 @@ Here's the code. We'll $client->autoflush(1); print $client "Welcome to $0; type help for command list.\n"; $hostinfo = gethostbyaddr($client->peeraddr); - printf "[Connect from %s]\n", $hostinfo ? $hostinfo->name : $client->peerhost; + printf "[Connect from %s]\n", + $hostinfo ? $hostinfo->name : $client->peerhost; print $client "Command? "; while ( <$client>) { - next unless /\S/; # blank line - if (/quit|exit/i) { last } - elsif (/date|time/i) { printf $client "%s\n", scalar localtime() } - elsif (/who/i ) { print $client `who 2>&1` } - elsif (/cookie/i ) { print $client `/usr/games/fortune 2>&1` } - elsif (/motd/i ) { print $client `cat /etc/motd 2>&1` } + next unless /\S/; # blank line + if (/quit|exit/i) { last } + elsif (/date|time/i) { printf $client "%s\n", scalar localtime() } + elsif (/who/i ) { print $client `who 2>&1` } + elsif (/cookie/i ) { print $client `/usr/games/fortune 2>&1` } + elsif (/motd/i ) { print $client `cat /etc/motd 2>&1` } else { print $client "Commands: quit date who cookie motd\n"; } @@ -1610,49 +1614,49 @@ will check many of them asynchronously by simulating a multicast and then using select() to do a timed-out wait for I/O. To do something similar with TCP, you'd have to use a different socket handle for each host. - #!/usr/bin/perl -w - use strict; - use Socket; - use Sys::Hostname; - - my ( $count, $hisiaddr, $hispaddr, $histime, - $host, $iaddr, $paddr, $port, $proto, - $rin, $rout, $rtime, $SECS_OF_70_YEARS); - - $SECS_OF_70_YEARS = 2_208_988_800; - - $iaddr = gethostbyname(hostname()); - $proto = getprotobyname("udp"); - $port = getservbyname("time", "udp"); - $paddr = sockaddr_in(0, $iaddr); # 0 means let kernel pick - - socket(SOCKET, PF_INET, SOCK_DGRAM, $proto) || die "socket: $!"; - bind(SOCKET, $paddr) || die "bind: $!"; - - $| = 1; - printf "%-12s %8s %s\n", "localhost", 0, scalar localtime(); - $count = 0; - for $host (@ARGV) { - $count++; - $hisiaddr = inet_aton($host) || die "unknown host"; - $hispaddr = sockaddr_in($port, $hisiaddr); - defined(send(SOCKET, 0, 0, $hispaddr)) || die "send $host: $!"; - } + #!/usr/bin/perl -w + use strict; + use Socket; + use Sys::Hostname; + + my ( $count, $hisiaddr, $hispaddr, $histime, + $host, $iaddr, $paddr, $port, $proto, + $rin, $rout, $rtime, $SECS_OF_70_YEARS); + + $SECS_OF_70_YEARS = 2_208_988_800; + + $iaddr = gethostbyname(hostname()); + $proto = getprotobyname("udp"); + $port = getservbyname("time", "udp"); + $paddr = sockaddr_in(0, $iaddr); # 0 means let kernel pick + + socket(SOCKET, PF_INET, SOCK_DGRAM, $proto) || die "socket: $!"; + bind(SOCKET, $paddr) || die "bind: $!"; + + $| = 1; + printf "%-12s %8s %s\n", "localhost", 0, scalar localtime(); + $count = 0; + for $host (@ARGV) { + $count++; + $hisiaddr = inet_aton($host) || die "unknown host"; + $hispaddr = sockaddr_in($port, $hisiaddr); + defined(send(SOCKET, 0, 0, $hispaddr)) || die "send $host: $!"; + } - $rin = ""; - vec($rin, fileno(SOCKET), 1) = 1; - - # timeout after 10.0 seconds - while ($count && select($rout = $rin, undef, undef, 10.0)) { - $rtime = ""; - $hispaddr = recv(SOCKET, $rtime, 4, 0) || die "recv: $!"; - ($port, $hisiaddr) = sockaddr_in($hispaddr); - $host = gethostbyaddr($hisiaddr, AF_INET); - $histime = unpack("N", $rtime) - $SECS_OF_70_YEARS; - printf "%-12s ", $host; - printf "%8d %s\n", $histime - time(), scalar localtime($histime); - $count--; - } + $rin = ""; + vec($rin, fileno(SOCKET), 1) = 1; + + # timeout after 10.0 seconds + while ($count && select($rout = $rin, undef, undef, 10.0)) { + $rtime = ""; + $hispaddr = recv(SOCKET, $rtime, 4, 0) || die "recv: $!"; + ($port, $hisiaddr) = sockaddr_in($hispaddr); + $host = gethostbyaddr($hisiaddr, AF_INET); + $histime = unpack("N", $rtime) - $SECS_OF_70_YEARS; + printf "%-12s ", $host; + printf "%8d %s\n", $histime - time(), scalar localtime($histime); + $count--; + } This example does not include any retries and may consequently fail to contact a reachable host. The most prominent reason for this is congestion diff --git a/pod/perllol.pod b/pod/perllol.pod index b35a0febb3..7eee1ec9a1 100644 --- a/pod/perllol.pod +++ b/pod/perllol.pod @@ -200,13 +200,14 @@ but not earlier, you should place a prominent directive at the top of the file that needs it. That way when somebody tries to run the new code under an old perl, rather than getting an error like - Type of arg 1 to push must be array (not array element) at /tmp/a line 8, near ""betty";" + Type of arg 1 to push must be array (not array element) at /tmp/a + line 8, near ""betty";" Execution of /tmp/a aborted due to compilation errors. they'll be politely informed that - Perl v5.14.0 required--this is only v5.12.3, stopped at /tmp/a line 1. - BEGIN failed--compilation aborted at /tmp/a line 1. + Perl v5.14.0 required--this is only v5.12.3, stopped at /tmp/a line 1. + BEGIN failed--compilation aborted at /tmp/a line 1. =head2 Access and Printing @@ -270,26 +271,28 @@ you might look at the standard L<Dumpvalue> or L<Data::Dumper> modules. The former is what the Perl debugger uses, while the latter generates parsable Perl code. For example: - use v5.14; # using the + prototype, new to v5.14 + use v5.14; # using the + prototype, new to v5.14 - sub show(+) { + sub show(+) { require Dumpvalue; state $prettily = new Dumpvalue:: tick => q("), - compactDump => 1, # comment these two lines out - veryCompact => 1, # if you want a bigger dump + compactDump => 1, # comment these two lines + # out + veryCompact => 1, # if you want a bigger + # dump ; dumpValue $prettily @_; - } + } - # Assign a list of array references to an array. - my @AoA = ( + # Assign a list of array references to an array. + my @AoA = ( [ "fred", "barney" ], [ "george", "jane", "elroy" ], [ "homer", "marge", "bart" ], - ); - push $AoA[0], "wilma", "betty"; - show @AoA; + ); + push $AoA[0], "wilma", "betty"; + show @AoA; will print out: diff --git a/pod/perlmodstyle.pod b/pod/perlmodstyle.pod index 6f0cb96c12..62390a4917 100644 --- a/pod/perlmodstyle.pod +++ b/pod/perlmodstyle.pod @@ -636,7 +636,8 @@ A correct CPAN version number is a floating point number with at least 2 digits after the decimal. You can test whether it conforms to CPAN by using - perl -MExtUtils::MakeMaker -le 'print MM->parse_version(shift)' 'Foo.pm' + perl -MExtUtils::MakeMaker -le 'print MM->parse_version(shift)' \ + 'Foo.pm' If you want to release a 'beta' or 'alpha' version of a module but don't want CPAN.pm to list it as most recent use an '_' after the diff --git a/pod/perlnewmod.pod b/pod/perlnewmod.pod index 26c4c13979..eae2997aad 100644 --- a/pod/perlnewmod.pod +++ b/pod/perlnewmod.pod @@ -164,8 +164,8 @@ the caller and not your module. For instance, if you say this: the user will see something like this: - No hostname given at /usr/local/lib/perl5/site_perl/5.6.0/Net/Acme.pm - line 123. + No hostname given at + /usr/local/lib/perl5/site_perl/5.6.0/Net/Acme.pm line 123. which looks like your module is doing something wrong. Instead, you want to put the blame on the user, and say this: diff --git a/pod/perlperf.pod b/pod/perlperf.pod index 5884a54f97..87d632f0d1 100644 --- a/pod/perlperf.pod +++ b/pod/perlperf.pod @@ -281,11 +281,16 @@ report on the contents. my $i_word = 0; foreach my $word ( @words ) { $i_word++; - $count{$i_LINES}{spec} += matches($i_word, $word, '[^a-zA-Z0-9]'); - $count{$i_LINES}{only} += matches($i_word, $word, '^[^a-zA-Z0-9]+$'); - $count{$i_LINES}{cons} += matches($i_word, $word, '^[(?i:bcdfghjklmnpqrstvwxyz)]+$'); - $count{$i_LINES}{vows} += matches($i_word, $word, '^[(?i:aeiou)]+$'); - $count{$i_LINES}{caps} += matches($i_word, $word, '^[(A-Z)]+$'); + $count{$i_LINES}{spec} += matches($i_word, $word, + '[^a-zA-Z0-9]'); + $count{$i_LINES}{only} += matches($i_word, $word, + '^[^a-zA-Z0-9]+$'); + $count{$i_LINES}{cons} += matches($i_word, $word, + '^[(?i:bcdfghjklmnpqrstvwxyz)]+$'); + $count{$i_LINES}{vows} += matches($i_word, $word, + '^[(?i:aeiou)]+$'); + $count{$i_LINES}{caps} += matches($i_word, $word, + '^[(A-Z)]+$'); } } @@ -301,7 +306,9 @@ report on the contents. $has++ if $1; } - debug("word: $i_wd ".($has ? 'matches' : 'does not match')." chars: /$regex/"); + debug( "word: $i_wd " + . ($has ? 'matches' : 'does not match') + . " chars: /$regex/"); return $has; } @@ -967,7 +974,8 @@ any way an issue, this approach is wrong. A common sight is code which looks something like this: - logger->debug( "A logging message via process-id: $$ INC: " . Dumper(\%INC) ) + logger->debug( "A logging message via process-id: $$ INC: " + . Dumper(\%INC) ) The problem is that this code will always be parsed and executed, even when the debug level set in the logging configuration file is zero. Once the debug() @@ -977,7 +985,8 @@ the program will continue. In the example given though, the C<\%INC> hash will already have been dumped, and the message string constructed, all of which work could be bypassed by a debug variable at the statement level, like this: - logger->debug( "A logging message via process-id: $$ INC: " . Dumper(\%INC) ) if $DEBUG; + logger->debug( "A logging message via process-id: $$ INC: " + . Dumper(\%INC) ) if $DEBUG; This effect can be demonstrated by setting up a test script with both forms, including a C<debug()> subroutine to emulate typical C<logger()> functionality. diff --git a/pod/perlrun.pod b/pod/perlrun.pod index fb0c271db5..1ff3ce2472 100644 --- a/pod/perlrun.pod +++ b/pod/perlrun.pod @@ -1326,7 +1326,7 @@ C<key_traversal_mask()> in L<Hash::Util>. An example output might be: - HASH_FUNCTION = ONE_AT_A_TIME_HARD HASH_SEED = 0x652e9b9349a7a032 PERTURB_KEYS = 1 (RANDOM) + HASH_FUNCTION = ONE_AT_A_TIME_HARD HASH_SEED = 0x652e9b9349a7a032 PERTURB_KEYS = 1 (RANDOM) =item PERL_MEM_LOG X<PERL_MEM_LOG> diff --git a/pod/perltie.pod b/pod/perltie.pod index db01b448a3..7b89f570ad 100644 --- a/pod/perltie.pod +++ b/pod/perltie.pod @@ -82,22 +82,22 @@ This is the constructor for the class. That means it is expected to return a blessed reference to a new scalar (probably anonymous) that it's creating. For example: - sub TIESCALAR { - my $class = shift; - my $pid = shift || $$; # 0 means me + sub TIESCALAR { + my $class = shift; + my $pid = shift || $$; # 0 means me - if ($pid !~ /^\d+$/) { - carp "Nice::Tie::Scalar got non-numeric pid $pid" if $^W; - return undef; - } + if ($pid !~ /^\d+$/) { + carp "Nice::Tie::Scalar got non-numeric pid $pid" if $^W; + return undef; + } - unless (kill 0, $pid) { # EPERM or ERSCH, no doubt - carp "Nice::Tie::Scalar got bad pid $pid: $!" if $^W; - return undef; - } + unless (kill 0, $pid) { # EPERM or ERSCH, no doubt + carp "Nice::Tie::Scalar got bad pid $pid: $!" if $^W; + return undef; + } - return bless \$pid, $class; - } + return bless \$pid, $class; + } This tie class has chosen to return an error rather than raising an exception if its constructor should fail. While this is how dbmopen() works, @@ -138,30 +138,33 @@ argument: the new value the user is trying to assign. Don't worry about returning a value from STORE; the semantic of assignment returning the assigned value is implemented with FETCH. - sub STORE { - my $self = shift; - confess "wrong type" unless ref $self; - my $new_nicety = shift; - croak "usage error" if @_; - - if ($new_nicety < PRIO_MIN) { - carp sprintf - "WARNING: priority %d less than minimum system priority %d", - $new_nicety, PRIO_MIN if $^W; - $new_nicety = PRIO_MIN; - } - - if ($new_nicety > PRIO_MAX) { - carp sprintf - "WARNING: priority %d greater than maximum system priority %d", - $new_nicety, PRIO_MAX if $^W; - $new_nicety = PRIO_MAX; - } - - unless (defined setpriority(PRIO_PROCESS, $$self, $new_nicety)) { - confess "setpriority failed: $!"; - } - } + sub STORE { + my $self = shift; + confess "wrong type" unless ref $self; + my $new_nicety = shift; + croak "usage error" if @_; + + if ($new_nicety < PRIO_MIN) { + carp sprintf + "WARNING: priority %d less than minimum system priority %d", + $new_nicety, PRIO_MIN if $^W; + $new_nicety = PRIO_MIN; + } + + if ($new_nicety > PRIO_MAX) { + carp sprintf + "WARNING: priority %d greater than maximum system priority %d", + $new_nicety, PRIO_MAX if $^W; + $new_nicety = PRIO_MAX; + } + + unless (defined setpriority(PRIO_PROCESS, + $$self, + $new_nicety)) + { + confess "setpriority failed: $!"; + } + } =item UNTIE this X<UNTIE> @@ -291,17 +294,17 @@ there. In our example, C<undef> is really C<$self-E<gt>{ELEMSIZE}> number of spaces so we have a little more work to do here: - sub STORE { - my $self = shift; - my( $index, $value ) = @_; - if ( length $value > $self->{ELEMSIZE} ) { - croak "length of $value is greater than $self->{ELEMSIZE}"; - } - # fill in the blanks - $self->EXTEND( $index ) if $index > $self->FETCHSIZE(); - # right justify to keep element size for smaller elements - $self->{ARRAY}->[$index] = sprintf "%$self->{ELEMSIZE}s", $value; - } + sub STORE { + my $self = shift; + my( $index, $value ) = @_; + if ( length $value > $self->{ELEMSIZE} ) { + croak "length of $value is greater than $self->{ELEMSIZE}"; + } + # fill in the blanks + $self->EXTEND( $index ) if $index > $self->FETCHSIZE(); + # right justify to keep element size for smaller elements + $self->{ARRAY}->[$index] = sprintf "%$self->{ELEMSIZE}s", $value; + } Negative indexes are treated the same as with FETCH. @@ -366,13 +369,13 @@ Verify that the element at index I<key> exists in the tied array I<this>. In our example, we will determine that if an element consists of C<$self-E<gt>{ELEMSIZE}> spaces only, it does not exist: - sub EXISTS { - my $self = shift; - my $index = shift; - return 0 if ! defined $self->{ARRAY}->[$index] || - $self->{ARRAY}->[$index] eq ' ' x $self->{ELEMSIZE}; - return 1; - } + sub EXISTS { + my $self = shift; + my $index = shift; + return 0 if ! defined $self->{ARRAY}->[$index] || + $self->{ARRAY}->[$index] eq ' ' x $self->{ELEMSIZE}; + return 1; + } =item DELETE this, key X<DELETE> @@ -706,19 +709,19 @@ This method is triggered when we remove an element from the hash, typically by using the delete() function. Again, we'll be careful to check whether they really want to clobber files. - sub DELETE { - carp &whowasi if $DEBUG; + sub DELETE { + carp &whowasi if $DEBUG; - my $self = shift; - my $dot = shift; - my $file = $self->{HOME} . "/.$dot"; - croak "@{[&whowasi]}: won't remove file $file" - unless $self->{CLOBBER}; - delete $self->{LIST}->{$dot}; - my $success = unlink($file); - carp "@{[&whowasi]}: can't unlink $file: $!" unless $success; - $success; - } + my $self = shift; + my $dot = shift; + my $file = $self->{HOME} . "/.$dot"; + croak "@{[&whowasi]}: won't remove file $file" + unless $self->{CLOBBER}; + delete $self->{LIST}->{$dot}; + my $success = unlink($file); + carp "@{[&whowasi]}: can't unlink $file: $!" unless $success; + $success; + } The value returned by DELETE becomes the return value of the call to delete(). If you want to emulate the normal behavior of delete(), @@ -736,16 +739,16 @@ In our example, that would remove all the user's dot files! It's such a dangerous thing that they'll have to set CLOBBER to something higher than 1 to make it happen. - sub CLEAR { - carp &whowasi if $DEBUG; - my $self = shift; - croak "@{[&whowasi]}: won't remove all dot files for $self->{USER}" - unless $self->{CLOBBER} > 1; - my $dot; - foreach $dot ( keys %{$self->{LIST}}) { - $self->DELETE($dot); - } - } + sub CLEAR { + carp &whowasi if $DEBUG; + my $self = shift; + croak "@{[&whowasi]}: won't remove all dot files for $self->{USER}" + unless $self->{CLOBBER} > 1; + my $dot; + foreach $dot ( keys %{$self->{LIST}}) { + $self->DELETE($dot); + } + } =item EXISTS this, key X<EXISTS> @@ -770,7 +773,7 @@ to iterate through the hash, such as via a keys(), values(), or each() call. sub FIRSTKEY { carp &whowasi if $DEBUG; my $self = shift; - my $a = keys %{$self->{LIST}}; # reset each() iterator + my $a = keys %{$self->{LIST}}; # reset each() iterator each %{$self->{LIST}} } @@ -904,11 +907,11 @@ X<WRITE> This method will be called when the handle is written to via the C<syswrite> function. - sub WRITE { - $r = shift; - my($buf,$len,$offset) = @_; - print "WRITE called, \$buf=$buf, \$len=$len, \$offset=$offset"; - } + sub WRITE { + $r = shift; + my($buf,$len,$offset) = @_; + print "WRITE called, \$buf=$buf, \$len=$len, \$offset=$offset"; + } =item PRINT this, LIST X<PRINT> @@ -917,7 +920,7 @@ This method will be triggered every time the tied handle is printed to with the C<print()> or C<say()> functions. Beyond its self reference it also expects the list that was passed to the print function. - sub PRINT { $r = shift; $$r++; print join($,,map(uc($_),@_)),$\ } + sub PRINT { $r = shift; $$r++; print join($,,map(uc($_),@_)),$\ } C<say()> acts just like C<print()> except $\ will be localized to C<\n> so you need do nothing special to handle C<say()> in C<PRINT()>. @@ -942,14 +945,14 @@ X<READ> This method will be called when the handle is read from via the C<read> or C<sysread> functions. - sub READ { - my $self = shift; - my $bufref = \$_[0]; - my(undef,$len,$offset) = @_; - print "READ called, \$buf=$bufref, \$len=$len, \$offset=$offset"; - # add to $$bufref, set $len to number of characters read - $len; - } + sub READ { + my $self = shift; + my $bufref = \$_[0]; + my(undef,$len,$offset) = @_; + print "READ called, \$buf=$bufref, \$len=$len, \$offset=$offset"; + # add to $$bufref, set $len to number of characters read + $len; + } =item READLINE this X<READLINE> @@ -1178,11 +1181,12 @@ UNTIE method is passed the count of "extra" references and can issue its own warning if appropriate. e.g. to replicate the no UNTIE case this method can be used: - sub UNTIE - { - my ($obj,$count) = @_; - carp "untie attempted while $count inner references still exist" if $count; - } + sub UNTIE + { + my ($obj,$count) = @_; + carp "untie attempted while $count inner references still exist" + if $count; + } =head1 SEE ALSO |