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
####
sub gc_frac {
local $_ = @_? shift : $_;
2 * (() = /(gc)/gi ) / length;
}
print gc_frac('AAgcTT'),$/
##
##
0.333333333333333
$
##
##
>>-----ASSIGN-----+---------------+----+--user-id--->
'--WITH REGRET--' '--group-id-->
>---password---------+-------NO PRIVILEGE----------><
>---group-password---'
##
##
$ perl -e'printf "OS: %s\tNum: %d\tTime left: %f\n", $^O, select undef, undef, undef, 1.5'
##
##
$ perl -e'alarm 1;printf "Num: %d\tTime left: %f\n", select undef, undef, undef, 3.0'
Alarm clock
$
##
##
$ time perl -e'alarm 5;printf "Num: %d\tTime left: %f\n", select undef, undef, undef, 3.0'
Num: 0 Time left: 0.000000
$
##
##
$ 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
$
##
##
#!/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
##
##
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;
}
}
##
##
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}
##
##
sub fixxml
{ # fix the xml nodes so they parse correctly
my$xml = shift;
my$fix = q{
}; # 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
}
##
##
#!/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)]}$/";
##
##
# 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__
##
##
{$_="r\@56O4\@FCE6DJO\@7OE96O!6C=>\@?