take control
Download
Skip this Video
Download Presentation
Take control

Loading in 2 Seconds...

play fullscreen
1 / 54

Take control - PowerPoint PPT Presentation


  • 103 Views
  • Uploaded on

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

loader
I am the owner, or an agent authorized to act on behalf of the owner, of the copyrighted work described.
capcha
Download Presentation

PowerPoint Slideshow about ' Take control' - craig


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.While downloading, if for some reason you are not able to download a presentation, the publisher may have deleted the file from their server.


- - - - - - - - - - - - - - - - - - - - - - - - - - E N D - - - - - - - - - - - - - - - - - - - - - - - - - -
Presentation Transcript
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
Technieken
  • overload
  • tie
  • CORE::GLOBAL
  • Attribute::Handlers

Take control

overload
overload
  • stringify
    • String functies
  • Numify
    • Rekenkundige bewerkingen
    • Rekenkundige functies
  • overload::constant()

Take control

overload api
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

coords pm
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

coords pm1
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

testing coords pm
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

using to move
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

using to move1
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

using to move2
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

using to move3
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

meer informatie
Meer informatie
  • perldoc overload

Take control

tie gebruikers
tie() gebruikers?

Take control

slide15
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

tiearray api
TIEARRAY API
  • API:
    • TIEARRAY constructor
    • FETCH, STORE
    • FETCHSIZE, STORESIZE
    • CLEAR, EXTEND
    • EXISTS, DELETE
    • PUSH, POP,
    • SHIFT, UNSHIFT, SPLICE
    • UNTIE, DESTROY

Take control

tiearray
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

chararray src1
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

chararray src2
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

testing chararray pm
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

tiehandle api
TIEHANDLE API
  • API:
    • TIEHANDLE constructor
    • schrijven
      • PRINT, PRINTF
      • WRITE
    • lezen
      • READLINE
      • READ, GETC
    • CLOSE
    • UNTIE, DESTROY

Take control

tiehandle output
TIEHANDLE (output)
  • Output
    • STDOUT, STDERR
    • Iedere andere GLOB
  • Methods:
    • TIEHANDLE()
    • PRINT
    • PRINTF

Take control

catchout pm
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

testing catchout pm
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

tiehandle input
TIEHANDLE (input)
  • Input
    • STDIN
    • Elke andere GLOB
  • Methods:
    • TIEHANDLE
    • READLINE

Take control

feedin pm
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

testing feedin pm
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

meer informatie1
Meer informatie
  • perldoc perltie

Take control

core global
CORE::GLOBAL::
  • Herdefinieren interne functies
    • prototype CORE::
    • In de compileer fase (BEGIN)
  • Origineel altijd nog beschikbaar
    • CORE::

Take control

core global gmtime
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

een test case voor open
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

myopen pm
MyOpen.pm

package MyOpen;

use warnings;

use strict;

our $VERSION = 0.01;

sub core_open (*;[email protected]) {

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

testing myopen pm
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

bringing it togther 1 2
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

bringing it together 2 2
Bringing it together (2/2)

sub tied_open (*;[email protected]) {

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

meer informatie2
Meer informatie
  • perldoc perlsub

Take control

attribute handlers
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

types voor een attribute
Types voor een attribute
  • Deze typen kunnen een attribute krijgen
    • SCALAR
    • ARRAY
    • HASH
    • CODE (sub)

Take control

aandachtspunten
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

een attribute voor tie
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

voorbeeld code voor gebruik
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

voorbeeld code voor gebruik1
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

oorspronkelijke attribute
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

een universal attribute
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

oorspronkelijke voorbeeld
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

gebruik universal attribute
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

oorspronkelijke attribute1
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

een attribute en autotie
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

gebruik autotie attribute
Gebruik autotie attribute

#! /usr/bin/perl

use warnings;

use strict;

use lib \'lib\';

use Auto_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

meer informatie3
Meer informatie
  • perldoc Attribute::Handlers

Take control

vragen
Vragen?

Take control

dank je wel
Dank je wel!

Take control

ad