scratchpad
Zaxo
<p>[ikegami], your alias code output:
<code>
use Data::Alias qw( alias );
use Devel::Peek qw( Dump );
my $x = 3;
my $y = 4;
Dump($x);
Dump($y);
alias $x = $y;
Dump($x);
Dump($y);
__END__
SV = IV(0x80ce4c8) at 0x805917c
REFCNT = 1
FLAGS = (PADBUSY,PADMY,IOK,pIOK)
IV = 3
SV = IV(0x80ce4cc) at 0x8059128
REFCNT = 1
FLAGS = (PADBUSY,PADMY,IOK,pIOK)
IV = 4
SV = IV(0x80ce4cc) at 0x8059128
REFCNT = 2
FLAGS = (PADBUSY,PADMY,IOK,pIOK)
IV = 4
SV = IV(0x80ce4cc) at 0x8059128
REFCNT = 2
FLAGS = (PADBUSY,PADMY,IOK,pIOK)
IV = 4
</code></p>
<hr />
<p>For [ewijawa],
<code>sub gc_frac {
local $_ = @_? shift : $_;
2 * (() = /(gc)/gi ) / length;
}
print gc_frac('AAgcTT'),$/</code>
Prints,
<code>0.333333333333333
$ </code></p>
<hr />
Ascii art for parallel continuation lines in [castaway]'s problem.
<code>
>>-----ASSIGN-----+---------------+----+--user-id--->
'--WITH REGRET--' '--group-id-->
>---password---------+-------NO PRIVILEGE----------><
>---group-password---'</code>
<hr />
<h3>Limbic's Lost Lesson List, Linked</h3>
<ol>
<li>[id://378226]</li>
<li>[id://377450]</li>
<li>[id://374287]</li>
<li>[id://371938]</li>
<li>[id://371720]</li>
<li>[id://355625]</li>
<li>[id://353259]</li>
<li>[id://339131]</li>
<li>[id://324749]</li>
<li>[id://324638]</li>
<li>[id://321831]</li>
<li>[id://291446]</li>
<li>[id://289076]</li>
<li>[id://288217]</li>
<li>[id://284214]</li>
<li>[id://272369]</li>
<li>[id://272366]</li>
<li>[id://269642]</li>
<li>[id://264471]</li>
<li>[id://264333]</li>
<li>[id://253934]</li>
<li>[id://253797]</li>
<li>[id://237388]</li>
<li>[id://221512]</li>
<li>[id://216644]</li>
<li>[id://214293]</li>
<li>[id://213052]</li>
<li>[id://159373]</li>
<li>[id://158625]</li>
<li>[id://136482]</li>
<li>[id://135462]</li>
<li>[id://135323]</li>
<li>[id://123961]</li>
<li>[id://109641]</li>
<li>[id://108182]</li>
<li>[id://105906]</li>
<li>[id://105620]</li>
<li>[id://105041]</li>
<li>[id://101793]</li>
<li>[id://71192]</li>
<li>[id://54485]</li>
<li>[id://20519]</li>
<li>[id://15838]</li>
<li>[id://15301]</li>
<li>[id://8650]</li>
<li>[id://8344]</li>
<li>[id://8259]</li>
<li>[id://990]</li>
<li>[id://965]</li>
</ol>
<hr />
<p>[select|Select] stuff for [duff]</p>
<blockquote><em>Return values: What's a good use for the number of ready channels? What systems return something useful for the time remaining? Linux does, are there others?</em></blockquote>
<p>Truth or not of the number tells whether the return from select was due to ready channels or a timeout. The number can be decremented with each channel handled to enable a quick test for completion. The timeleft value appears to be useful only on Linux.
<code>$ perl -e'printf "OS: %s\tNum: %d\tTime left: %f\n", $^O, select undef, undef, undef, 1.5'
</code>
gives for several systems,<br />
<tt>OS: linux Num: 0 Time left: 0.000000 (Zaxo)<br />
OS: freebsd Num: 0 Time left: 1.500000 (sporty)<br />
OS: solaris Num: 0 Time left: 1.500000 (sporty)</tt><br />
Thanks to [sporty] for his assistance with that.</p>
<p></p>
<blockquote><em>Signal handling: Do signals awake a sleeping select? Does a select timeout affect a pending alarm?</em></blockquote>
<p>This it readily checked with a couple of one-liners.
<code>$ perl -e'alarm 1;printf "Num: %d\tTime left: %f\n", select undef, undef, undef, 3.0'
Alarm clock
$ </code>
shows that setting timeout in select does not interfere with SIGALRM and that signals will awake pending select.
<code>$ time perl -e'alarm 5;printf "Num: %d\tTime left: %f\n", select undef, undef, undef, 3.0'
Num: 0 Time left: 0.000000
$ </code>
shows that having an alarm set does not interfere with [select] timing.
<code>$ perl -e'$SIG{ALRM}=sub {};alarm 1;printf "Num: %d\tTime left: %f\n", select undef, undef, undef, 3.0'
Num: -1 Time left: 2.000000
$ </code>
shows that catching a signal will jolt [select] into returning. That points out another use of the number returned. On Linux the time left value would be useful in recovering from such interruptions.</p><p></p>
<blockquote><em></em></blockquote>
<hr />
<h2>[cpan://Hook::LexWrap] problem *SOLVED*</h2>
++[demerphq] points out that it is the elements of @_ that are aliases, not @_ itself. Modifying $_[0] works as advertised.
<p>This is either a Hook::LexWrap bug, or else I'm doing something silly:
<code>#!/usr/bin/perl
use strict;
use warnings;
use Hook::LexWrap;
{
my $foo;
sub foo { @_ ? $foo = shift : $foo; }
my $wrapper = wrap *foo,
pre => sub {
warn 0+@_, " @_";
# splice @_, 0, 1, lc( $_[0]) if @_ > 1; # bad
$_[0] = lc $_[0] if @_ > 1; #new
warn 0+@_, " @_";
},
post => sub {
$_[-1] =
wantarray ?
[ map {uc} @{$_[-1]} ] :
uc $_[-1]
};
sub wrapper () :lvalue { $wrapper } # keeps the cloistered
# lexwrap alive
sub _foo () :lvalue { $foo } # inspection hatch
}
my $str = 'Quux';
my $tmp = $str;
printf "Given $str, wrapped setter reports %s, backdoor shows %s, arg is now %s.\n",
foo($tmp), _foo, $tmp; # setter
printf "Wrapped getter reports %s, and backdoor shows %s\n",
foo(), _foo; # getter
__END__
2 Quux ARRAY(0x804b3f8) at hlw.pl line 13.
2 quux ARRAY(0x804b3f8) at hlw.pl line 15.
Given Quux, wrapped setter reports QUUX, backdoor shows Quux, arg is now Quux.
1 ARRAY(0x804b50c) at hlw.pl line 13.
1 ARRAY(0x804b50c) at hlw.pl line 15.
Wrapped getter reports QUUX, and backdoor shows Quux
</code>
If I understand correctly, the pre code ought to be able to modify @_ and have the wrapped sub see the new argument. There is a similar example in the pod, doing temperature conversion.</p>
<hr />
<p>Reading from a file descriptor in C.<p>
<p>C's library read() returns -1 on error, or the number of bytes read. Some errors, like EAGAIN, are usually handled by retrying. The function does not necessarily read as many bytes as you ask for.</p>
<code>ssize_t rd = 0;
size_t sofar = 0;
while (rd = read( fd, buf + sofar, BUFSIZE - sofar)) {
switch (rd) {
case -1:
switch (errno) {
case EAGAIN :
case EINTR :
continue;
default :
/* unrecoverable */
abort();
}
default:
sofar += rd;
}
}</code>
<p>This is just skeletal, more detailed error handling may be called for. The read call returns zero either on eof, or when its third argument is zero. The while loop exits in either case having read BUFSIZE chars, or all there were, whichever came first.</p>
<p>In C, it pays to be persnickety, there is no dwimmery to the language. It just does what you tell it to.</p>
<hr/>
<p>My external css, http://localhost/PerlMonks.css:<code>
PRE {
background-color: #CCEECC;
border: thin black solid;
padding: 5px;
font-family: fixed, courier;
font-size: 14pt;
white-space : pre;
}
H1 {font-size: 34pt}
H2 {font-size: 30pt}
H3 {font-size: 24pt}
H4 {font-size: 18pt}
H5 {font-size: 14pt}
H6 {font-size: 8pt}</code>
That green makes the Red Theme look like spumoni.</p>
<hr />
<p>Patched [framechat2], line 6 only fixes xml header if it's broken:<code>
sub fixxml
{ # fix the xml nodes so they parse correctly
my$xml = shift;
my$fix = q{<?xml version="1.0" encoding="ISO-8859-1"?>
<!DOCTYPE CHATTER SYSTEM "dummy.dtd"[]>}; # mirod to the rescue!
$xml = ($xml=~/^<\?xml/i?'':$fix).$xml; # Zaxo
$xml =~ s/[\r\n\t]//g; # jcwren
$xml =~ y/\x00-\x1f//d; # strip control chrs
return $xml; # to the xml parser
}</code></p>
<hr />
<p>for [simon_proctor]:<code>
#!/usr/bin/perl -w
use strict;
sub common {
my (%common, %test);
$_ = shift;
@common{@$_} = {} x @$_; # second use is scalar context
while ( $_ = shift) {
%test = ();
@test{@$_} = () x @$_;
delete @common{ grep { ! exists $test{$_} } keys %common};
}
return ( keys %common );
}
my @foo = (
[1,2,3,5,8,9,4,5],
[18,2,4,7,3,4.9],
[2,3,6,5,9],
[1,2,3,4,5,6,7,8,9,0],
[1,2,3,5,8],
[2,3,4,5,8,7],
);
print "@{[common(@foo)]}$/";
</code>prints:<pre>
1 2
</pre></p>
<hr />
<p>If you want to try insanely low-level things in perl on linux, here is a transcription to perl of linux-2.4 asm-i386/ioctl.h. A lot of perls were built with linux-2.2 headers, making perl's sys/ioctl.ph not quite right for rekerneled machines.<code>
# Constants and functions transcribed from linux 2.4 asm-i386/ioctl.h macros
use strict;
package Ioctl::Linux_2_4::I386;
BEGIN {
use Exporter;
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
@ISA = qw(Exporter);
$VERSION = '0.04';
@EXPORT = qw( _IO _IOR _IOW _IOWR );
@EXPORT_OK = qw(
_IOC_DIR _IOC_SIZE _IOC_NR _IOC_TYPE
IOC_IN IOC_OUT IOC_INOUT
IOCSIZE_MASK IOCSIZE_SHIFT
);
%EXPORT_TAGS = (
decode => [qw( _IOC_DIR _IOC_SIZE _IOC_NR _IOC_TYPE)],
rawdir => [qw(IOC_IN IOC_OUT IOC_INOUT)],
rawsize => [qw(IOCSIZE_MASK IOCSIZE_SHIFT)]
);
}
# Bitfield layout of ioctl command word
use constant IOC_NRBITS => 8;
use constant IOC_TYPEBITS => 8;
use constant IOC_SIZEBITS => 14;
use constant IOC_DIRBITS => 2;
# Decoding masks
use constant IOC_NRMASK => ((1 << IOC_NRBITS) - 1 );
use constant IOC_TYPEMASK => ((1 << IOC_TYPEBITS) - 1 );
use constant IOC_SIZEMASK => ((1 << IOC_SIZEBITS) - 1 );
use constant IOC_DIRMASK => ((1 << IOC_DIRBITS) - 1 );
# Shift amounts derived from bitfield widths
use constant IOC_NRSHIFT => 0;
use constant IOC_TYPESHIFT => (IOC_NRSHIFT + IOC_NRBITS);
use constant IOC_SIZESHIFT => (IOC_TYPESHIFT + IOC_TYPEBITS);
use constant IOC_DIRSHIFT => (IOC_SIZESHIFT + IOC_SIZEBITS);
# Direction encoding
use constant IOC_NONE => 0;
use constant IOC_WRITE => 1;
use constant IOC_READ => 2;
# Convenience constants
use constant IOC_IN => (IOC_WRITE << IOC_DIRSHIFT);
use constant IOC_OUT => (IOC_READ << IOC_DIRSHIFT);
use constant IOC_INOUT => ((IOC_WRITE|IOC_READ) << IOC_DIRSHIFT);
use constant IOCSIZE_MASK => (IOC_SIZEMASK << IOC_SIZESHIFT);
use constant IOCSIZE_SHIFT => (IOC_SIZESHIFT);
# Control word packing
# arguments: direction, type, nr, size
sub _IOC ($$$$) {
($_[0] & IOC_DIRMASK) << IOC_DIRSHIFT |
($_[1] & IOC_TYPEMASK) << IOC_TYPESHIFT |
($_[2] & IOC_NRMASK) << IOC_NRSHIFT |
($_[3] & IOC_SIZEMASK) << IOC_SIZESHIFT
}
# arguments: type, nr
sub _IO ($$) {
_IOC( IOC_NONE, $_[0], $_[1], 0)
}
# arguments: type, nr, size
sub _IOR ($$$) {
_IOC( IOC_READ, $_[0], $_[1], $_[2])
}
# arguments type, nr, size
sub _IOW ($$$) {
_IOC( IOC_WRITE, $_[0], $_[1], $_[2])
}
# arguments type, nr, size
sub _IOWR ($$$) {
_IOC( IOC_WRITE | IOC_READ, $_[0], $_[1], $_[2])
}
# Decode ioctl numbers
sub _IOC_DIR ($;@) {
$_[0] >> IOC_DIRSHIFT & IOC_DIRMASK
}
sub _IOC_TYPE ($;@) {
$_[0] >> IOC_TYPESHIFT & IOC_TYPEMASK
}
sub _IOC_NR ($;@) {
$_[0] >> IOC_NRSHIFT & IOC_NRMASK
}
sub _IOC_SIZE ($;@) {
$_[0] >> IOC_SIZESHIFT & IOC_SIZEMASK
}
1;
__END__
</code>I'm soliciting review of this. Is the heavy use of the <tt>constant</tt> pragma good? How about the prototypes? I want it to howl at compile time if it gets the wrong number of arguments. I don't want runtime errors in the midst of prodding a kernel device</p>
<hr />
<p>Here is a minor obfu which may be useful to paste into replies to homework:<code>
{$_="r\@56O4\@FCE6DJO\@7OE96O!6C=>\@?<DO|@?2DE6CJ\n",y, -},O-} -N,,print}
</code>
A modified version of this is published as [Steal This Code]</p>