-------------------------
# tworzymy nowy zakres dla zmiennych leksykalnych 
 {
     package InsideOut::User;

     use Scalar::Util 'refaddr';

     # zmienne leksykalne suce do przechowywania danych instancji 
     my %names;
     my %addresses;

     sub new
     {
         my ($class, $data) = @_;

         # bogosawimy nowy skalar, by zdoby jego identyfikator obiektu 
         bless \(my $self), $class;

         # zachowujemy dane instancji 
         my $id             = refaddr( $self );
         $names{     $id }  = $data->{name};
         $addresses{ $id }  = $data->{address};

         return $self;
     }

     # metody dostpu takie jak $self->{name}, czy $self->{address} nie dziaaj
     sub get_name
     {
         my $self = shift;
         return $names{ refaddr( $self ) };
     }

     sub get_address
     {
         my $self = shift;
         return $addresses{ refaddr( $self ) };
     }

     # wielu ludzi zapomina o tej czci 
     sub DESTROY
     {
         my $self = shift;
         my $id   = refaddr( $self );
         delete $names{     $id };
         delete $addresses{ $id };
     }
 }

 1;
-------------------------
 {
     package InsideOut::User;

     use Class::Std;

     my %names     :ATTR( :get<name>    :init_arg<name>    );
     my %addresses :ATTR( :get<address> :init_arg<address> );
 }
-------------------------
use YAML 'DumpFile';

 sub serialize
 {
     my ($object, $file) = @_;
     my %data            = %$object;
     DumpFile( $file, \%data );
 }
-------------------------
package Graphics::Drawable;
 {
     use Class::Std;

     my %coords_of     :ATTR( :get<coords>   :init_arg<coords>   );
     my %velocities_of :ATTR( :get<velocity> :init_arg<velocity> );
     my %shapes_of     :ATTR( :get<shape>    :init_arg<shape>    );

     sub get_serializable_data
     {
         my $self  = shift;

         my %data;

         for my $attribute (qw( coords velocity shape ))
         {
             my $method = 'get_' . $attribute;
             $data{ $attribute } = $self->$method(  );
         }

         return \%data;
     }
 }
-------------------------
 ---
 coords:
   - 0
   - 0
   - 0
 shape: Circle
 velocity:
   - 1
   - 0
   - 0
-------------------------
use YAML 'LoadFile';

 sub deserialize
 {
     my ($class, $file) = @_;
     my $data           = LoadFile( $file );
     return $class->new( $data );
 }
-------------------------
package Counter;

 use strict;
 use warnings;

 use Attribute::Docstring;

 our $counter :Doc( 'licznik wszystkich nowych obiektw Foo' );

 sub new :Doc( 'konstruktor obiektu Foo' )
 {
     $counter++;
     bless {  }, shift;
 }

 sub get_count :Doc( 'zwraca licznik dla wszystkich obiektw foo' )
 {
     return $counter;
 }

 1;
-------------------------
package Attribute::Docstring;

 use strict;
 use warnings;

 use Scalar::Util 'blessed';
 use Attribute::Handlers;

 my %doc;

 sub UNIVERSAL::Doc :ATTR
 {
     my ($package, $symbol, $referent, $attr, $data, $phase) = @_;
     return if $symbol eq 'LEXICAL';

     my $name                  = *{$symbol}{NAME};
     $doc{ $package }{ $name } = $data;
 }

 sub UNIVERSAL::doc
 {
     my ($self, $name) = @_;
     my $package       = blessed( $self ) || $self;

     return unless exists $doc{ $package }{ $name };
     return               $doc{ $package }{ $name };
 }

 1;
-------------------------
 package Class::HideMethods;

 use strict;
 use warnings;
 use Attribute::Handlers;

 my %prefixes;

 sub import
 {
     my ($self, $ref)      = @_;
     my $package           = caller(  );
     $prefixes{ $package } = $ref;
 }

 sub gen_prefix
 {
     my $invalid_chars = "\0\r\n\f\b";

     my $prefix;

     for ( 1 .. 5 )
     {
         my $char_pos = int( rand( length( $invalid_chars ) ) );
         $prefix     .= substr( $invalid_chars, $char_pos, 1 );
     }

     return $prefix;
 }

 package UNIVERSAL;

 sub Private :ATTR
 {
     my ($package, $symbol, $referent, $attr, $data, $phase) = @_;

     my $name    = *{ $symbol }{NAME};
     my $newname = Class::HideMethods::gen_prefix( $package ) . $name;
     my @refs    = map { *$symbol{ $_ } } qw( HASH SCALAR ARRAY GLOB );
     *$symbol    = do { local *symbol };

     no strict 'refs';
     *{ $package . '::' . $newname } = $referent;
     *{ $package . '::' . $name    } = $_ for @refs;
     $prefixes{ $package }{ $name }  = $newname;
 }

 1;
-------------------------
package SecretClass;

 my %methods;
 use Class::HideMethods \%methods;

 sub new            { bless {  }, shift }
 sub hello :Private { return 'hello'   }
 sub goodbye        { return 'goodbye' }

 sub public_hello
 {
     my $self  = shift;
     my $hello = $methods{hello};
     $self->$hello(  );
 }

 1;
-------------------------
 use Test::More tests => 6;

 my $sc = SecretClass->new(  );
 isa_ok( $sc, 'SecretClass' );

 ok( ! $sc->can( 'hello' ),        'hello(  ) powinna by ukryta'              );
 ok( $sc->can( 'public_hello' ),   'public_hello(  ) powinna by dostpna'     );
 is($sc->public_hello(  ),
     'hello', '... i powinna mc przywoywa hello(  )' );
 ok( $sc->can( 'goodbye' ),        'goodbye(  ) powinna by dostpna '         );
 is($sc->goodbye(  ), 'goodbye',    '... i powinna da si przywoywa'        );
-------------------------
package Attribute::Method;

 use strict;
 use warnings;

 use B::Deparse;
 use Attribute::Handlers;

 my $deparse = B::Deparse->new(  );

 sub import
 {
     my ( $class, @vars ) = @_;
     my $package          = caller(  );

     my %references       =
     (
         '$' => \undef,
         '@' => [  ],
         '%' => {  },
     );

     push @vars, '$self';

     for my $var (@vars)
     {
         my $reftype                 = substr( $var, 0, 1, '' );

         no strict 'refs';
         *{ $package . '::' . $var } = $references{$reftype};
     }
 }

 sub UNIVERSAL::Method :ATTR(RAWDATA)
 {
     my ($package, $symbol, $referent, undef, $arglist) = @_;

     my $code                 = $deparse->coderef2text( $referent );
     $code                    =~ s/{/sub {\nmy (\$self, $arglist) = \@_;\n/;

     no warnings 'redefine';
     *$symbol                 = eval "package $package; $code";
 }

 1;
-------------------------
package Easy::Class;

 use strict;
 use warnings;

 use Attribute::Method qw( $status );

 sub new :Method
 {
     bless { @_ }, $self;
 }

 sub set_status :Method( $status )
 {
     $self->{status} = $status;
 }

 sub get_status :Method
 {
     return $self->{status};
 }

 1;
-------------------------
package Proxy::AccessControl;

 use strict;
 use warnings;

 use Attribute::Handlers;

 my %perms;

 sub UNIVERSAL::perms
 {
     my ($package, $symbol, $referent, $attr, $data) = @_;
     my $method                                      = *{ $symbol }{NAME};

     for my $permission (split(/\s+/, $data))
     {
         push @{ $perms{ $package }{ $method } }, $permission;
     }
 }

 sub dispatch
 {
     my ($user, $class, $method, @args) = @_;

     return unless $perms{ $class }{ $method } and $class->can( $method );

     for my $perm (@{ $perms{ $class }{ $method } })
     {
       die "Potrzebne uprawnienia '$perm\n'" unless $user->has_permission( $perm );
     }

     $class->$method( @args );
 }

 1;
-------------------------
 package Inventory;

 use Proxy::AccessControl;

 sub insert :perms( 'create' )
 {
     my ($self, $attributes) = @_;
     # ...
 }

 sub delete :perms( 'delete' )
 {
     my ($self, $id) = @_;
     # ...
 }

 sub update :perms( 'write' )
 {
     my ($self, $id, $attributes) = @_;
     # ...
 }

 sub fetch :perms( 'read' )
 {
     my ($self, $id) = @_;
     # ...
 }

-------------------------
 sub clone :perms( 'read create' )
 {
     my ($self, $id, $attributes) = @_;
     # ...
 }
-------------------------
package Model;

 sub new
 {
     my ($class, %args) = @_;
     bless \%args, $class;
 }

 sub get_data
 {
     my $self = shift;
     my %data = map { $_ => $self->{$_} } qw( imie profesja wiek );
     return \%data;
 }

 1;
-------------------------
package View;

 use Class::Trait 'base';

 package TextView;

 use base 'View';

 sub render
 {
     my $self = shift;
     printf( "Nazywam si %s.  Moja profesja to %s i mam %d lat.\n",
         @{ $self->get_data(  ) }{qw( imie profesja wiek )} );
 }

 package YAMLView;

 use YAML;
 use base 'View';

 sub render
 {
     my $self = shift;
     print Dump $self->get_data(  );
 }

 1;
-------------------------
 # wykorzystujemy model i ogldamy klasy 

 # tworzymy odpowiednie obiekty modelu
 my $uncle  = Uncle->new(
     imie => 'Robert', profesja => 'Wuj', wiek => 50
 );
 my $nephew = Nephew->new(
     imie => 'Jakub', profesja => 'Agent Chaosu', wiek => 3
 );

 # stosujemy odpowiednie perspektywy 
 Class::Trait->apply( $uncle,  'TextView' );
 Class::Trait->apply( $nephew, 'YAMLView' );

 # wywietlamy wyniki
 $uncle->render(  );
 $nephew->render(  );
-------------------------
 Nazywam si Robert.  Pracuj jako Wuj i mam 50 lat.
 ---
 imie: Jakub 
 profesja: Agent Chaosu 
 wiek: 3
-------------------------
Class::Trait->apply( $uncle, $view_type ) unless $uncle->does( 'View' ); 
-------------------------
package My::Customer;

 use strict;
 use warnings;
	
 sub new { bless {  }, shift }

 sub first_name
 {
     my $self            = shift;
     return $self->{first_name} unless @_;
     $self->{first_name} = shift;
     return $self;
 }

 sub last_name
 {
     my $self           = shift;
     return $self->{last_name} unless @_;
     $self->{last_name} = shift;
     return $self;
 }

 sub full_name
 {
     my $self = shift;
     return join ' ', $self->first_name(  ), $self->last_name(  );
 }

 1;
-------------------------
 my $cust = My::Customer->new(  );
 $cust->first_name( 'Jan' );
 $cust->last_name( 'Publiczny' );
 print $cust->full_name(  );
-------------------------
package My::Customer;

 use strict;
 use warnings;

 use Class::MethodMaker[
     new    => [qw( new )],
     scalar => [qw( first_name last_name )],];

 sub full_name
 {
     my $self = shift;
     return join ' ', $self->first_name(  ), $self->last_name(  );
 }
-------------------------
print $cust->first_name_isset(  ) ? 'true' : 'false';
-------------------------
 $cust->first_name( 'Ozymandias' );
 print $cust->first_name_isset(  ) ? 'true' : 'false'; # prawda - true
 $cust->first_name_reset(  );
 print $cust->first_name_isset(  ) ? 'true' : 'false'; # fasz - false
-------------------------
package My::Customer;

 use strict;
 use warnings;

 use Class::BuildMethods qw(
   first_name
   last_name
 );

 # Warto zauway, e jeli wolimy, moemy uy odwoania do tablicy 
 sub new { bless [  ], shift }

 sub full_name
 {
     my $self = shift;
     return join ' ', $self->first_name(  ), $self->last_name(  );
 }

 1;
-------------------------
 use Class::BuildMethods
   'imie',
   gender => { default  => 'mezczyzna' },
   age    => { validate => sub
   {
       my ($self, $age) = @_;
       carp 'Nie moesz studiowa, jeli jeste istot nisz'
           if ( $age < 18 && ! $self->is_emancipated(  ) );
   }};
-------------------------

