1 / 54

Take control

Take control. Introductie in het wijzigen van standaard Perl gedrag. use Workshop::Perl::Dutch 5; date( '2008-02-29' ); author( abeltje => 'Abe Timmerman' );. Technieken. overload tie CORE::GLOBAL Attribute::Handlers. overload gebruikers?. overload. stringify String functies Numify

craig
Download Presentation

Take control

An Image/Link below is provided (as is) to download presentation Download Policy: Content on the Website is provided to you AS IS for your information and personal use and may not be sold / licensed / shared on other websites without getting consent from its author. Content is provided to you AS IS for your information and personal use only. Download presentation by click this link. While downloading, if for some reason you are not able to download a presentation, the publisher may have deleted the file from their server. During download, if you can't get a presentation, the file might be deleted by the publisher.

E N D

Presentation Transcript

  1. Take control Introductie in het wijzigen van standaard Perl gedrag use Workshop::Perl::Dutch 5; date( '2008-02-29' ); author( abeltje => 'Abe Timmerman' );

  2. Technieken • overload • tie • CORE::GLOBAL • Attribute::Handlers Take control

  3. overload gebruikers? Take control

  4. overload • stringify • String functies • Numify • Rekenkundige bewerkingen • Rekenkundige functies • overload::constant() Take control

  5. overload API • Operator overloading met sub • Unary operators: • 1 argument • Binary operators • 3 argumenten • 1ste altijd een object • 2de object of constante • 3de geeft aan of 1ste en 2de zijn verwisseld Take control

  6. Coords.pm package Coords; sub new { my( $class, $x, $y ) = @_; bless { _x => $x || 0, _y => $y || 0 }, $class; } sub move { my( $self, $dx, $dy ) = @_; ref $dx eq __PACKAGE__ and ( $dx, $dy ) = ( $dx->{_x}, $dx->{_y} ); $self->{_x} += $dx; $self->{_y} += $dy; return $self; } sub as_string { my( $self ) = @_; return sprintf "(%d, %d)", $self->{_x}, $self->{_y}; } Take control

  7. Coords.pm package Coords; use overload q{""} => \&as_string, fallback => 1; sub new { my( $class, $x, $y ) = @_; bless { _x => $x || 0, _y => $y || 0 }, $class; } sub move { my( $self, $dx, $dy ) = @_; ref $dx eq __PACKAGE__ and ( $dx, $dy ) = ( $dx->{_x}, $dx->{_y} ); $self->{_x} += $dx; $self->{_y} += $dy; return $self; } sub as_string { my( $self ) = @_; return sprintf "(%d, %d)", $self->{_x}, $self->{_y}; } Take control

  8. Testing Coords.pm use Test::More 'no_plan'; my $c = Coords->new( 150, 150 ); is $c, $c->as_string, "overloaded stringify: $c"; $c->move( -50, 50 ); is $c, "(100, 200)", "->move(-50,50): $c"; my $m = Coords->new( 50, -50 ); $c->move( $m ); is $c, "(150, 150)", "->move$m: $c"; # overload/coords/1fase/ -> prove -lv t/*.t Take control

  9. Using '+' to move use Test::More 'no_plan'; my $c1 = Coords->new( 150, 150 ); is $c1, $c1->as_string, "overloaded stringify: $c1"; my $c2 = Coords->new( -50, 50 ); is $c2, $c2->as_string, "overloaded stringify: $c2"; my $r2 = $c1 + $c2; isa_ok $r2, 'Coords'; is $r2, "(100, 200)", "overloaded addition: $r2"; Take control

  10. Using '+' to move use Test::More 'no_plan'; my $c1 = Coords->new( 150, 150 ); is $c1, $c1->as_string, "overloaded stringify: $c1"; my $c2 = Coords->new( -50, 50 ); is $c2, $c2->as_string, "overloaded stringify: $c2"; my $r1 = $c1->copy; isa_ok $r1, 'Coords'; is $r1, $c1, "->copy: $r1"; $r1->move( $c2 ); is $r1, "(100, 200)", "->move$c2: $r1"; my $r2 = $c1 + $c2; isa_ok $r2, 'Coords'; is $r2, "(100, 200)", "overloaded addition: $r2"; Take control

  11. Using '+' to move package Coords; use overload q{""} => \&as_string, fallback => 1; sub new { my( $class, $x, $y ) = @_; bless { _x => $x || 0, _y => $y || 0 }, $class; } sub copy { return bless { _x => $_[0]->{_x}, _y => $_[0]->{_y} }, ref $_[0]; } sub move { my( $self, $dx, $dy ) = @_; ref $dx and ( $dx, $dy ) = ( $dx->{_x}, $dx->{_y} ); $self->{_x} += $dx; $self->{_y} += $dy; return $self; } sub as_string { my( $self ) = @_; return sprintf "(%d, %d)", $self->{_x}, $self->{_y}; } Take control

  12. Using '+' to move package Coords; use overload q{""} => \&as_string, q{+} => \&add_move, fallback => 1; sub new { my( $class, $x, $y ) = @_; bless { _x => $x || 0, _y => $y || 0 }, $class; } sub copy { return bless { _x => $_[0]->{_x}, _y => $_[0]->{_y} }, ref $_[0]; } sub move { my( $self, $dx, $dy ) = @_; ref $dx and ( $dx, $dy ) = ( $dx->{_x}, $dx->{_y} ); $self->{_x} += $dx; $self->{_y} += $dy; return $self; } sub add_move { my( $a1, $a2 ) = @_; ref $a2 or die "Cannot move() with constants!"; $a1->copy->move( $a2 ); } sub as_string { my( $self ) = @_; return sprintf "(%d, %d)", $self->{_x}, $self->{_y}; } Take control

  13. Meer informatie • perldoc overload Take control

  14. tie() gebruikers? Take control

  15. tie() • Geef een object de interface van een Perl variabele type • Mogelijke typen: • Scalar • Array • Hash • Handle • Toegang tot het onderliggende object met behulp van tied() Take control

  16. TIEARRAY API • API: • TIEARRAY constructor • FETCH, STORE • FETCHSIZE, STORESIZE • CLEAR, EXTEND • EXISTS, DELETE • PUSH, POP, • SHIFT, UNSHIFT, SPLICE • UNTIE, DESTROY Take control

  17. TIEARRAY • Geef een object de interface van een array • In het voorbeeld: gebruik een scalar als array • substr() <-> push/pop/unshift/shift/slice Take control

  18. CharArray (src1) package CharArray; use warnings; use strict; sub TIEARRAY { my $class = shift; ref $_[0] or die "Usage: tie my @a, CharArray => \$scalar;"; bless $_[0], $class; } sub UNTIE { } sub FETCHSIZE { my $self = shift; defined $$self ? length( $$self ) : 0; } Take control

  19. CharArray (src2) sub FETCH { my( $self, $index ) = @_; $index > length $$self and $$self .= "" x ( 1 + $index - length $$self ); defined $$self ? substr $$self, $index, 1 : undef; } sub STORE { my( $self, $index, $value ) = @_; $index > length $$self and $$self .= "" x ( 1 + $index - length $$self ); substr $$self, $index, 1, $value; } sub PUSH { my $self = shift; $$self .= join "", @_; length $$self; } sub POP { my $self = shift; my $last = substr $$self, -1, 1; $$self = substr $$self, 0, length( $$self ) - 1; $last; } 1; Take control

  20. Testing CharArray.pm #! /usr/bin/perl use warnings; use strict; use Test::More 'no_plan'; use_ok 'CharArray'; { my $orig = 'value'; tie my @ca, 'CharArray', \$orig; is $ca[0], 'v', "First value '@ca' (${ tied( @ca ) })"; push @ca, 's'; is @ca, 6, "new length (${ tied( @ca ) })"; my $sorted = join "", sort @ca; is $sorted, 'aelsuv', "sorting the array works ($sorted)"; untie @ca; is $orig, 'values', "still the changed value in original ($orig)"; } # tie/array/ -> prove -lv t/*.t Take control

  21. TIEHANDLE API • API: • TIEHANDLE constructor • schrijven • PRINT, PRINTF • WRITE • lezen • READLINE • READ, GETC • CLOSE • UNTIE, DESTROY Take control

  22. TIEHANDLE (output) • Output • STDOUT, STDERR • Iedere andere GLOB • Methods: • TIEHANDLE() • PRINT • PRINTF Take control

  23. CatchOut.pm package CatchOut; use strict; use warnings; our $VERSION = 0.04; # tie *HANDLE, CatchOut => <\*TIEDHANDLE | \$buf> sub TIEHANDLE { my $class = shift; ref $_[0] eq __PACKAGE__ and return $_[0]; ref $_[0] eq 'SCALAR' or die "Usage:\n\ttie *HANDLE, CatchOut => <\*TIEDHANDLE | \$buf>"; bless $_[0], $class; } sub PRINT { my $self = shift; $$self .= join "", @_; } sub PRINTF { my $self = shift; my( $fmt, @args ) = @_; $$self .= sprintf $fmt, @args; } 1; Take control

  24. Testing CatchOut.pm #! perl use warnings; use strict; use Test::More 'no_plan'; use_ok 'CatchOut'; { my $outbuf; { local *OUT; tie *OUT, 'CatchOut', \$outbuf; print OUT "Testline\n"; untie *OUT; } is $outbuf, <<' __EOTEST__', "Caught the right output"; Testline __EOTEST__ } Take control

  25. TIEHANDLE (input) • Input • STDIN • Elke andere GLOB • Methods: • TIEHANDLE • READLINE Take control

  26. FeedIn.pm package FeedIn; use warnings; use strict; our $VERSION = 0.01; # tie *FH, FeedIn => $text; sub TIEHANDLE { my( $class, $store ) = @_; bless \$store, $class; } sub READLINE { my $self = shift; defined $$self or return; length $$self or return; if ( ! defined $/ ) { # slurp-mode my $all = $$self; $$self = undef; return $all; } if ( wantarray ) { my @lines = grep length $_ => $$self =~ m{(.*?(?:$/|\z))}sg; $$self = undef; return @lines; } else { return defined $$self =~ s{(.*?(?:$/|\z))}{}s ? $1 : undef; } } 1; Take control

  27. Testing FeedIn.pm #! perl use warnings; use strict; use Test::More 'no_plan'; use_ok 'FeedIn'; { local *IN; tie *IN, 'FeedIn', "regel 1\nregel 2"; my @line = <IN>; is scalar @line, 2, "2 lines in list-context"; is $line[0], "regel 1\n", "Read a line '$line[0]'"; is $line[1], "regel 2", "Read a line '$line[1]'"; } { local *IN; tie *IN, 'FeedIn', "regel 1\nregel 2"; my @line; while ( <IN> ) { push @line, $_ } is scalar @line, 2, "2 lines in list-context"; is $line[0], "regel 1\n", "Read a line '$line[0]'"; is $line[1], "regel 2", "Read a line '$line[1]'"; } { local *IN; tie *IN, 'FeedIn', "regel 1\nregel 2"; my $lines = do { local $/; <IN> }; is $lines, "regel 1\nregel 2", "Slurp-mode"; } Take control

  28. Meer informatie • perldoc perltie Take control

  29. CORE::GLOBAL gebruikers? Take control

  30. CORE::GLOBAL:: • Herdefinieren interne functies • prototype CORE:: • In de compileer fase (BEGIN) • Origineel altijd nog beschikbaar • CORE:: Take control

  31. CORE::GLOBAL::gmtime #! /usr/bin/perl use warnings; use strict; BEGIN { # 29 Feb 2008 12:00:00 GMT *CORE::GLOBAL::gmtime = sub (;$) { my $stamp = @_ ? $_[0] : 1204286400; CORE::gmtime( $stamp ); }; } printf "[ empty] %s\n", scalar gmtime( ); printf "[time()] %s\n", scalar gmtime( time ); Take control

  32. Een test case voor open() • Ik wil de volgende soort code testen: • open my $fh, '<', '/proc/cpuinfo' • Herdefinieer • CORE::GLOBAL::open • Gebruik een tied handle voor invoer • FeedIn.pm Take control

  33. MyOpen.pm package MyOpen; use warnings; use strict; our $VERSION = 0.01; sub core_open (*;$@) { my( $handle, $mode, $file, @list ) = @_; # make sure filehandles are in their own package my $pkg = caller; if ( defined $handle and !ref $handle ) { # bareword handle no strict 'refs'; $handle = *{ "$pkg\:\:$handle" }; } elsif ( !defined $handle ) { # undefined scalar, provide GLOBref $_[0] = $handle = do { no strict 'refs'; \*{ sprintf "%s::NH%d%d%d", $pkg, $$, time, rand 100 }; }; } # convert to two argumented open() defined $file and $mode .= " $file"; CORE::open( $handle, $mode ); }; # prepare open() for runtime override BEGIN { *CORE::GLOBAL::open = \&core_open } 1; Take control

  34. Testing MyOpen.pm #! perl use warnings; use strict; use Test::More 'no_plan'; BEGIN { use_ok 'MyOpen' } ok defined &CORE::GLOBAL::open, "CORE::GLOBAL::open() defined"; my $content; { CORE::open( my $fh, '<', $0 ) or die "Cannot CORE::open($0): $!"; isa_ok $fh, 'GLOB'; $content = do { local $/; <$fh> }; close $fh; like $content, qr/BEGIN { use_ok 'MyOpen' }/, "contains MyOpen"; } { open my $fh, '<', $0 or die "Cannot open($0): $!"; isa_ok $fh, 'GLOB'; my $file = do { local $/; <$fh> }; close $fh; is $file, $content, "contents still the same"; } Take control

  35. Bringing it togther (1/2) #! perl use warnings; use strict; use Test::More 'no_plan'; BEGIN { use_ok 'MyOpen' } ok defined &CORE::GLOBAL::open, "CORE::GLOBAL::open() defined"; use_ok 'FeedIn'; { no warnings 'redefine'; local *CORE::GLOBAL::open = \&tied_open; open my $fh, '<', $0 or die "Cannot tied_open($0): $!"; isa_ok tied( $fh ), 'FeedIn'; my $file = do { local $/; <$fh> }; close $fh; is $file, "open: $0", "tied_open() returned '$file'"; } Take control

  36. Bringing it together (2/2) sub tied_open (*;$@) { my( $handle, $mode, $file ) = @_; # make sure filehandles are in their own package my $pkg = caller; if ( defined $handle and !ref $handle ) { # bareword handle no strict 'refs'; $handle = *{ "$pkg\:\:$handle" }; } elsif ( !defined $handle ) { # undefined scalar, provide a GLOB $_[0] = $handle = do { no strict 'refs'; *{ sprintf "%s::NH%d%d%d", $pkg, $$, time, rand 100 }; }; } # convert to two argumented open() defined $file and $mode .= " $file"; # do the magic-tie for open "< $0" or pass to CORE::open() if ( $mode =~ m/^(?:<\s*)?($0)/ ) { tie $handle, FeedIn => "open: $1"; } else { CORE::open( $handle, $mode ); } } Take control

  37. Meer informatie • perldoc perlsub Take control

  38. Attribute::Handler gebruikers? Take control

  39. Attribute::Handlers • Perl heeft syntax voor attributes • :my_attribute(data) • Perl heeft twee geïmplementeerde attributes • :lvalue • :ATTR • Via :ATTR is de attribute implementatie uit te breiden • Een attribute is een sub met die naam die het :ATTR attribute heeft Take control

  40. Types voor een attribute • Deze typen kunnen een attribute krijgen • SCALAR • ARRAY • HASH • CODE (sub) Take control

  41. Aandachtspunten • De handler sub moet bekend zijn in de aanroepende namespace • use base • Declareer in UNIVERSAL:: • Argumenten aan de handler sub • Aanroepende package • Referentie naar de symbol table (CODE) • Referentie naar de variabele/code • Attribute naam • Data die aan het attribute wordt mee gegeven • Fase voor de handler (BEGIN,CHECK,INIT,END) Take control

  42. Een attribute voor tie() package Tie_OddEven; use strict; use warnings; our $VERSION = 0.01; use Attribute::Handlers; sub OddEven :ATTR(SCALAR) { my( $pkg, $symbol, $referent, $attr, $data ) = @_; tie $$referent, __PACKAGE__, $data; } sub TIESCALAR { my $class = shift; bless \(my $self = shift), $class; } sub FETCH { my $self = shift; return $$self % 2 == 0 ? 'even' : 'odd'; } sub STORE { my $self = shift; $$self = shift; } 1; Take control

  43. Voorbeeld code voor gebruik #! /usr/bin/perl use warnings; use strict; use lib 'lib'; use Tie_OddEven; tie my $oe, Tie_OddEven => 0; while ( 1 ) { print "Number: "; chomp( my $input = <> ); last unless $input =~ /^-?\d+$/; $oe = $input; printf "$input is $oe (%d)\n", ${ tied $oe }; } Take control

  44. Voorbeeld code voor gebruik #! /usr/bin/perl use warnings; use strict; use lib 'lib'; use base 'Tie_OddEven'; my $oe :OddEven(0); while ( 1 ) { print "Number: "; chomp( my $input = <> ); last unless $input =~ /^-?\d+$/; $oe = $input; printf "$input is $oe (%d)\n", ${ tied $oe }; } Take control

  45. Oorspronkelijke attribute package Tie_OddEven; use strict; use warnings; our $VERSION = 0.01; use Attribute::Handlers; sub OddEven :ATTR(SCALAR) { my( $pkg, $symbol, $referent, $attr, $data ) = @_; tie $$referent, __PACKAGE__, $data; } sub TIESCALAR { my $class = shift; bless \(my $self = shift), $class; } sub FETCH { my $self = shift; return $$self % 2 == 0 ? 'even' : 'odd'; } sub STORE { my $self = shift; $$self = shift; } 1; Take control

  46. Een UNIVERSAL:: attribute package Universal_OddEven; use strict; use warnings; our $VERSION = 0.01; use Attribute::Handlers; sub UNIVERSAL::OddEven :ATTR(SCALAR) { my( $pkg, $symbol, $referent, $attr, $data ) = @_; tie $$referent, __PACKAGE__, $data; } sub TIESCALAR { my $class = shift; bless \(my $self = shift), $class; } sub FETCH { my $self = shift; return $$self % 2 == 0 ? 'even' : 'odd'; } sub STORE { my $self = shift; $$self = shift; } 1; Take control

  47. Oorspronkelijke voorbeeld #! /usr/bin/perl use warnings; use strict; use lib 'lib'; use base 'Tie_OddEven'; my $oe :OddEven(0); while ( 1 ) { print "Number: "; chomp( my $input = <> ); last unless $input =~ /^-?\d+$/; $oe = $input; printf "$input is $oe (%d)\n", ${ tied $oe }; } Take control

  48. Gebruik UNIVERSAL attribute #! /usr/bin/perl use warnings; use strict; use lib 'lib'; use Universal_OddEven; my $oe :OddEven(0); while ( 1 ) { print "Number: "; chomp( my $input = <> ); last unless $input =~ /^-?\d+$/; $oe = $input; printf "$input is $oe (%d)\n", ${ tied $oe }; } Take control

  49. Oorspronkelijke attribute package Tie_OddEven; use strict; use warnings; our $VERSION = 0.01; use Attribute::Handlers; sub OddEven :ATTR(SCALAR) { my( $pkg, $symbol, $referent, $attr, $data ) = @_; tie $$referent, __PACKAGE__, $data; } sub TIESCALAR { my $class = shift; bless \(my $self = shift), $class; } sub FETCH { my $self = shift; return $$self % 2 == 0 ? 'even' : 'odd'; } sub STORE { my $self = shift; $$self = shift; } 1; Take control

  50. Een attribute en autotie package Auto_OddEven; use strict; use warnings; our $VERSION = 0.01; use Attribute::Handlers autotie => { '__CALLER__::OddEven' => __PACKAGE__ }; sub TIESCALAR { my $class = shift; bless \(my $self = shift), $class; } sub FETCH { my $self = shift; return $$self % 2 == 0 ? 'even' : 'odd'; } sub STORE { my $self = shift; $$self = shift; } 1; Take control

More Related