package Some::Module;
use base 'Exporter';
our @EXPORT = qw( useful );

sub useful{ 42 }
---------------------------------
package Some::Module;
sub useful { 42 } 

sub import {
    no strict 'refs';
    *{caller()."::useful"} = *useful;
}
---------------------------------
$answer = 42
$variable = "answer";

print ${$variable};
---------------------------------
use Some::Module;
our $useful = "Jaki acuch";

print $Some::Module::useful;
---------------------------------
${caller()."::useful"} = $useful;
@{caller()."::useful"} = @useful;
---------------------------------
&{caller()."::useful"} = &useful;
---------------------------------
@b = (1,2,3,4);
*a = \@b;

push @b, 5;
print @a; # 12345

# Jednak:
$a = "egnaj"
$b = "Witaj!";
print a; # egnaj
---------------------------------
*a = \"Witaj";
*a = [ 1, 2, 3 ];
*a = { red => "czerwony", blue => "niebieski"}"

print $a;        # Witaj
print $a[1];     # 2
print $a{"red";} # czerwony
---------------------------------
*a = \1234;
$a = 10; # Prba modyfikacji wartoci tylko-do-odczytu
---------------------------------
sub useful { 42 }
sub import {
    no strict 'refs';
    *{caller()."::useful"} = \&useful;
}
---------------------------------
foreach $sym (@imports) {
    # skrt dla czstego przypadku braku oznaczenia typu
    (*{"${callpkg}}::$sym"} = \&{"${pkg}::$sym"}, next)
        unless $sym =~ s/^(\W)//;

    $type = $1;
    *{${callpkg}::$sym"} = 
       $type eq '&' ? \&{"${pkg}::$sym"} :
       $type eq '$' ? \${"${pkg}::$sym} :
       $type eq '@' ? \@{"${pkg}::$sym"} :
       $type eq '%' ? \%{"${pkg}::$sym} :
       $type eq '*' ?  *{"${pkg}::$sym"} :
       do {require Carp; Carp::croack("Nie mona wyeksportowa symbolu:$type$sym") };
}
---------------------------------
 (*{"${callpkg}::$sym"} = \&{"${pkg}::$sym"}, next)
    unless $sym =~s/^(\W)//;
---------------------------------
*{"${callpkg}::$sym"} = \&{"${pkg}::$sym"};
next;
---------------------------------
*{$callpkg."::useful"} = \&{"Some::Module::useful"};
---------------------------------
*{"${callpkg}::$sym"} =
    $type eq '&' ? \&{"${pkg}::$sym"} :
    $type eq '$' ? \${"${pkg}::$sym"} :
    $type eq '@' ? \@{"${pkg{::$sym"} :
    $type eq '%' ? \%{"${pkg}::$sym"} :
    $type eq '*' ? \%{"${pkg}::$sym"} :
    do { require Carp; Carp::croak("Nie mona wyeksportowa symbolu: $type$sym") };
---------------------------------
package Data::BT::PhoneBill::_Call;
sub new {
  my ($class, @data) = @_;
  bless \@data,$class;
}

sub installation { shift->[0] }
sub line         { shift->[1] }
...
---------------------------------
{
   my $seq = 3;
   sub sequence { $seq += 3 }
}

print $seq; # poza zasigiem

print sequence; # wypisze 6
print sequence; # wypisze 9
---------------------------------
sub type         ( shift->[0] }
sub installation { shift->[1] }
sub line         { shift->[2] }
---------------------------------
our @fields = qw(type installation line chargecard_date time
                 destination _number _duration rebate _cost);

sub new {
  my ($class, @data) = @_;
  bless { map { $fields[$_] => $data[$_] } 0..$#fields } => $class;
}
---------------------------------
sub type         { shift->{type} }
sub installation { shift->{installation} }
sub line         { shift->{line} }
---------------------------------
for my $f (@fields) {
    no strict 'refs';
    *$f = sub { shift->{$f} };
}
---------------------------------
sub AUTOLOAD {
    print "Nie wiem, co zrobi!\n";
}

yow();
---------------------------------
sub AUTOLOAD {
    my $self = shift;
    if ($AUTOLOAD =~ /.*::(.*)/) { $self->{$1} }
---------------------------------
sub AUTOLOAD {
if ($AUTOLOAD =~/.*::(.*)/) {
    my $element =$1;
    *$AUTOLOAD = sub { shift->{$element} };
    goto &$AUTOLOAD;
}
---------------------------------
. = Data::BT::PhoneBill::_Call::type ...
. = Data::BT::PhoneBill::_Call::AUTOLOAD ...
. = main::process_call
---------------------------------
. = Data::BT::PhoneBill::_Call::type ...
. = main::process_call
---------------------------------
use Carp qw(croak);
...
sub AUTOLOAD {
    my $self = shift;
    if ($AUTOLOAD =~ /.*::(.*)/ and exists $self->{$1}) {
        return $self->{$1}
    }
    croack "Wywoanie niezdefinowanej procedury &$Autoload" }
---------------------------------
use subs qw(glob);

sub glob {
    my $pattern = shift;
    local *DIR;
    opendir DIR, "." or die $!;
    return grep /$pattern/, readdir DIR;
}
---------------------------------
print "$_\n" for glob("^c.*\\.xml");

ch01.xml
ch02.xml
...
---------------------------------
print "$_\n" for <^c.*\\.xml>;
---------------------------------
@files = <ch.*xml>;      # Nowa wersja glob
@files = CORE::glob("ch*xml"); # Oryginalna wersja glob
---------------------------------
package Regexp::Glob;
use base 'Exporter';
our @Export = qw(glob);

sub glob
    my $pattern = shift;
    return grep /$pattern/, CORE::glob("*");
}
1;
---------------------------------
use Regexp::Glob;
@files = glob("ch.*xml");    # Nowa wersja glob

package Elsewhere;
@files = glob("ch.*xml");    # Oryginalna wersja glob
---------------------------------
package Regexp::Glob;

*CORE::GLOBAL::glob = sub {
    my $pattern = shift;
    local *DIR;
    opendir DIR, "." or die $!;
    return grep /$pattern/, readdir DIR
};

1;
---------------------------------
wrap 'my_routine',
   pre => sub {print "Pocztek wykonywania my_routine z argumentami @_"},
   post => sub {print "Wykonywanie my_routine zakoczone"; }
---------------------------------
sub my_routine {
    call_pre_hook();
    goto &Real::my_routine;
}
---------------------------------
*CORE::GLOBAL::caller = sub{
    my($height) = ($_[0}||0);
    my $i=1;
    my $name_cache;
    while (1) {
        my @caller = CORE::caller($i++) or return;
        $caller[3} = $name_cache if $name_cache;
        $name_cache = $caller[0] eq 'Hook::LexWrap' ? $caller[3] : '';
        next if $name_cache || $height --!= 0;
        return wantarray ? @_? @caller : @caller[0..2] : $caller[0];
    }
};
---------------------------------
sub wrap (*@) {
    my ($typeglob, %wrapper) = @_;
    $typeglob = (ref $typeglob || $typeglob =~ /::/)
        ? $typeglob
        : caller()."::$typeglob";
    my $orginal = ref $typeglob eq 'CODE'
                  ? typeglob
                  : *$typeglob{CODE};
    $imposter = sub {
        $wrapper{pre}->(@_) if $wrapper{pre};
        my @return = &$original;
        $wrapper{post}->(@_) if $wrapper{post};
        return @return;
    };
    *{$typeglob} = $imposter;
}
---------------------------------
$typeglob = $typeglob =~/::/ ? $typeglob : caller()."::$typeglob";
my $original = *$typeglob{CODE};
---------------------------------
sub sum_input {
    my $a = <>;
    print $a + 1;
}
---------------------------------
% perl -MO=Deparse -n -e '/^#/ || print'

LINE: while (defined($_ = <ARGV>)) {
    print $_ unless /^#/;
}
---------------------------------
use B;

my $subref = sub {
    my $a = <>;
    print $a + 1;
};

my $b = B::svref_2object($subref); # B::CV object
---------------------------------
my $op = $b->START

do {
    print B::class($op)." : ". $op->name." (".$op->desc.")\n";
} while $op = $op->next and not $op->isa("B::NULL");
---------------------------------
COP : nextstate (next statement)
OP : padsv (private variable)
PADOP : gv (glob value)
UNOP : readline (<HANDLE>)
COP : nextstate (next statement)
OP : pushmark (pushmark)
OP : padsv (private variable)
SVOP : const (constant item)
BINOP : add (addition (+))
LISTOP : print (print)
UNOP : leavesub (subroutine exit)
---------------------------------
use B::Utills qw( walkoptree_simple );
...
my $op = $b->ROOT;

walkoptree_simple($op, sub{
    $cop = shift;
    print B::class($cop). " : ". $cop->name." (".$cop->desc.")\n";
});
---------------------------------
UNOP : leavesub (subroutine exit)
LISTOP : lineseq (line sequence)
COP : nextstate (next statement)
UNOP : null (null operation)
OP : padsv (private variable)
UNOP : readline (<HANDLE>)
PADOP : gv (glob value)
COP : nextstate (next statement)
LISTOP : print (print)
...
---------------------------------
package Coffee;
our @ISA = qw(Beverage::Hot);

sub new { return bless { temp => 80 }, shift }

package Tea;
use base 'Beverage::Hot';

package Latte;
use base 'Coffee';

package main;
my $mug = Latte->new;

Tea->isa("Beverage::Hot"); # 1
Tea->isa("Coffee"); # 0

if ($mug->isa("Beverage::Hot")) {
    warn 'Zawarto moe by gorca';
}
---------------------------------
my ($self, $thing) = @_;
croak "Musz otrzyma instancj Beverage::Hot"
 unless eval { $thing->isa("Beverage::Hot"); };
---------------------------------
$h{firstaddr} = sprintf("%#x", $ {$op->first}) if $op->can("first");
$h{lastaddr} =  sprintf("%#x", $ {$op->last})  if $op->can("last");
---------------------------------
require Some::Module;
---------------------------------
my $module = "Some::Module";
require $module;
---------------------------------
eval "require $module";
---------------------------------
$module->require;
---------------------------------
package UNIVERSAL;

sub moniker {
    my ($self) = @_;
        my @parts = split /::/, (ref($self) || $self);
    return 1c pop @patrs;
}
---------------------------------
for my $class (@classes) {
    print "Lista wszystkich ".$class->plural_moniker.":\n";
    print $ ->name."\n" for $class->retrieve_all;
    print "\n";
}
---------------------------------
sub UNIVERSAL::AUTOLOAD {
    my $self = shift;
    $UNIVERSAL::AUTOLOAD =~ /.*::(.*)/;
    return if $1 eq "DESTROY"
    if (@_) {
    $self->{$1} = shift;
    }
    $self->{$1};
}
---------------------------------
my $a = Some::Class->new;
my $b = Some::Class->new;

$a->singleton_method( dump => sub {
  my $self = shift;
  require Data::Dumper; print STDERR Date::Dumper::Dumper($self)
});

$a->dump; # Wypisze reprezentacj obiektu.
$b->dump; # Nie uda si odnale metody "dump"
---------------------------------
package UNIVERSAL;

sub singleton_method {
    my ($object, $method, $subref) = @_;

    my $parent_class = ref $object;
    my $new_class = "_Singletons::".(0+$object);
    *{$new_class."::".$method} = $subref;

    if ($new_class ne $parent_class) {
        @{$new_class."::ISA"} = ($parent_class);
        bless $object, $new_class;
    }
}
---------------------------------
cout << "Hello world";
---------------------------------
$object *= $value;
---------------------------------
my $min = Time::Seconds->new(60);
my $hour = Time::Seconds->new(3600);
---------------------------------
my $longtime = Time::Seconds->new(123456);
print $longtime->hours; # 34.2933..
print $longtime->days;  # 1.42888..
---------------------------------
my $new = $min->add($hour);
---------------------------------
my $new = $min + $hour;
print $new->seconds; # 3660
---------------------------------
use overload '+' => \&add;
# ...
sub add {
    my ($lhs, $rhs) = getovlvals(@_);
    return Time::Seconds->new($lhs + $rhs);
}

sub _get_ovlvals {
    my ($lhs, $rhs, $reverse) = @_;
    $lhs = $lhs->seconds;

    if (UNIVERSAL::isa($rhs, 'Time::Seconds')) {
        $rhs = $rhs->seconds;
    } elsif (ref($rhs)) {
        die "W przecizonym operatorze mona uywa tylko obiektw Seconds";
    }

    if ($reverse) { return $rhs, $lhs; }
    return $lhs, $rhs;
}
---------------------------------
use overload '<=>' \&compare;
sub compare {
    my ($lhs, $rhs) = getovlvals(@_);
    return $lhs <=> $rhs;
}
---------------------------------
use overload '-=' => \&subtract_from;
sub subtract_from {
    my $lhs = shift;
    my $rhs = shift;
    $rhs = $rhs->seconds if UNIVERSAL::isa($rhs, 'Time::Seconds');
    $$lhs -= $rhs;
    return $lhs;
}
---------------------------------
use overload 'fallback' => 'undef';
---------------------------------
$file << "Ale to brzydkie\n";
---------------------------------
print $new; # 3660
---------------------------------
use overload '0+' => \&seconds,
             '""' => \&seconds;
---------------------------------
print "Godzina plus minuta to $new sekund\n";
# Godzina plus minuta to 3660 sekund
---------------------------------
camel
alpaca
panther
---------------------------------
% perl -Mmath::BigFloat=:constant -le 'print ref (123456789012345678901234567890\
    >1234567890)'
Math::BigFloat
---------------------------------
sub import {
    my $self = shift;
    # ...
    overload::constant float => sub { $self->new(shift); };
}
---------------------------------
Math::BigFloat->new("1234567890123456789012345678901234567890")
---------------------------------
% irb
irb(main):001:0> 2
=> 2
irb(main):002:0> 2.class
=> Fixnum
irb(main):003:0> 2.class.class
=> Class
irb(main):004:0> 2.class.class.class
=> Class
irb(main):005:0> 2.methods
=> ["<=", "to_f", "abs", "upto", "succ", "|", "/", "type",
"times", "%", "-@", "&", "~", "<", "**", "zero?", "^", "<=>", "to_s",
"step", "[&thinsp;&thinsp;]", ">", "=&thinsp;&thinsp;=", "modulo", "next", "id2name",
"size", "<<",
"*", "downto", ">>", ">=", "divmod", "+", "floor", "to_int", "to_i",
"chr", "truncate", "round", "ceil", "integer?", "prec_f", "prec_i",
"prec", "coerce", "nonzero?", "+@", "remainder", "eql?",
"=&thinsp;&thinsp;=&thinsp;&thinsp;=",
"clone", "between?", "is_a?", "equal?", "singleton_methods", "freeze",
"instance_of", "send", "methods", "tainted?", "id", 
"instance_variables", "extend", "dup", "protected_methods", "=~",
"frozen?", "kind_of", "respond_to?", "class", "nil?",
"instance_eval", "public_methods", "_&thinsp;_send_&thinsp;_", "untaint", "_&thinsp;_
id_&thinsp;_",
"inspect", "display", "taint", "method", "private_methods", "hash",
"to_a"]
---------------------------------
use Ruby;
print 2->class; # "FixInt"
print "Hello world"->class->class # "Class"
print 2->class->to_s->class # "String"
print 2->class->to_s->lenght # "6"
print ((2+2)->class) # "FixInt"

# A nawet:
print 2.class.to_s.class # "String"
---------------------------------
package Ruby;
sub import {
overload::constant(integer => sub { return Fixnum->new(shift) },
                   q       => sub { return String->new(shift) },
                   qq      => sub { return String->new(shift) });
}
---------------------------------
package Fixnum;
sub new { return bless \$_[1], $_[0] }

package String;
sub new { return bless \$_[1], $_[0] }
---------------------------------
use overload '""' => sub { ${$_[0]} };
---------------------------------
use Carp;
use overload "0+" => sub { croak "Nie mona wymusi traktowania String jako Fixnum"};
---------------------------------
use overload "+" => sub { String->new(${$_[0]} . "$_[1]") };
---------------------------------
use overload '""' => sub { croak "nie udao si przekonwertowa Fixnum na String" },
             "0+" => sub { ${$_[0] } },
---------------------------------
use overload '+' => sub {${ $_[0] } + $_[1] };
---------------------------------
use overload '+' => \&sum;

sub sum{
    my ($left, $right) = @_;
    my $rval;
    if (my $numify = overload::Method($right, "0+")) {
        $rval = $right->$numify;
    } else {
        $rval = $right;
    }
    Fixnum->new($left + $rval);
}
---------------------------------
print 2.class.to_s.class # "String"
---------------------------------
use overload "." => sub {my ($obj,$meth)=@_; $obj->$meth };
---------------------------------
print "Ja bd druga!\n";
BEGIN { print "Ja bd pierwsza!\n"; }
---------------------------------
BEGIN { require Module::Name; Module::Name->import(@stuff); }
---------------------------------
BEGIN { @AnyDBM_File::ISA = qw(DB_File GDBM_File NDBM_File); }
use AnyDBM::File;
---------------------------------
package Beverage::Hot;
sub serve :final { # Tylko ja mam prawo do zdefiniowania tej metody!
    my ($self, $who) = @_;
    if ($who->waitress) { $who->waitress->serve($self, $who); }
    else                { $who->take($self); }
}

package Tea;
use base 'Beverage::Hot';

sub serve { # Bd kompilacji.
}
---------------------------------
package UNIVERSAL;
use Attribute::Handlers;
sub final :ATTR {
    my ($pack, $ref) = @_;
    push @{$marked{$pack}}, *{$ref}{NAME};
}
---------------------------------
CHECK { Attribute::Final->check }
---------------------------------
sub fill_packages {
    no strict 'refs';
    my $root = shift;
    my @subs = grep s/::$//, keys %{$root."::"};
    push @all_packages, $root;
    for (@subs) { 
         next if $root eq "main" and $_eq "main"; # Zaptlenie
         fill_packages($root."::".$);
    }
}
---------------------------------
sub check {
    no strict 'refs';
    fill packages("main" unless @all_packages;
    for my $derived_pack (@all_packages) {
        next unless @{$derived_pack."::ISA"};
        ...
    }
}
---------------------------------
for my $derived_pack (@all_packages) {
    next unless @{$derived_pack."::ISA"};
    for my $marked_pack (keys %marked) {
        next unless $derived_pack->isa($marked_pack);
        ...
---------------------------------
        for my $meth (@{$marked{$marked_pack}}) {
            my $glob_ref = \*{derived_pack."::".$meth};
            if (*{$glob_ref}{CODE}) {
---------------------------------
               my $name = $marked_pack."::".$meth;
               my $b = B::svref_2object($glob_ref);
               die "Prba przesonicia metody final w ".
                   $b->FILE. ", line ".$b->LINE."\n";
---------------------------------
sub do_later (&) { bless shift, "Do::Later"}
sub Do::Later::DESTROY {$_[0]->() };

{
   my $later = do_later { print "Koniec bloku!\n"; };
   ...
}
---------------------------------
my $unwrap;
$imposter = sub {
    if ($unwrap) { goto &$original }
    ...
}
...
return bless sub { $unwrap=1 }, 'Hook::LexWrap::Cleanup';
---------------------------------
sub AUTOLOAD {
     $AUTOLOAD =~ /.*::(.*)/;
     return if $1 eq "DESTROY";
     return { data => \@_, name => $1 }
}
---------------------------------
use overload "." => sub {
    my ($obj, $stuff) = @_;
    @_ = ($obj, @{$stuff->{data}});
    goto &{$obj->can($stuff->{name})};
}, fallback => 1;
---------------------------------
package My::Class;
use Acme::Dot;
use base 'Class::Accessor';
__PACKAGE__->mk_accessor(qw/name age/);

package End::User;
use My::Class;

my $x = new My::Class;
$x.name("Kubu Puchatek");
---------------------------------
my ($call_pack);

sub import {
    no strict 'refs';
    $call_pack = (caller())[0];
    eval <<EOT
 package $call_pack;
use overload "." => sub {
    my (\$obj, \$stuff) = \@_;
    \@_ = (\$obj, \@{\$stuff->{data}});
    goto \&{\$obj->can(\$stuff->{name}});
}, fallback => 1;

EOT
   ;
}
---------------------------------
my ($call_pack, $end_user);

sub import {
    no strict 'refs';
    $call_pack = (caller())[0];
    *{$call_pack."::import"} = sub { $end_user = (caller())[0]; };
    eval <<EOT
 package $call_pack;
use overload "." => sub {
    my (\$obj, \$stuff) = \@_;
    \@_ = (\$obj, \@{\$stuff->{data}});
    goto \&{\$obj->can(\$stuff->{name})};
}, fallback => 1;

EOT
   ;
}
---------------------------------
CHECK {
    # W tej chwili wszystko jest gotowe, a $end_user zawiera
    # nazw pakietu wywoujcego pakiet wywoujcy.
    no strict;
    if ($end_user) {
        *{$end_user."::AUTOLOAD"} = sub {
             $AUTOLOAD =~ /.*::(.*)/;
             return if $1 eq "DESTROY";
             return { data => \@_, name => $1 }
        }
    }
}


