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><code>##

sub gc_frac {
    local $_ = @_? shift : $_;
    2 * (() = /(gc)/gi ) / length;
}
print gc_frac('AAgcTT'),$/
##</code><code>##

0.333333333333333
$ 
##</code><code>##

>>-----ASSIGN-----+---------------+----+--user-id--->
                  '--WITH REGRET--'    '--group-id-->

>---password---------+-------NO PRIVILEGE----------><
>---group-password---'
##</code><code>##

$ perl -e'printf "OS: %s\tNum: %d\tTime left: %f\n", $^O, select undef, undef, undef, 1.5'

##</code><code>##

$ perl -e'alarm 1;printf "Num: %d\tTime left: %f\n", select undef, undef, undef, 3.0'
Alarm clock
$ 
##</code><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><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><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><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><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><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><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><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><code>##

{$_="r\@56O4\@FCE6DJO\@7OE96O!6C=>\@?<DO|@?2DE6CJ\n",y, -},O-} -N,,print}