Take control
This presentation is the property of its rightful owner.
Sponsored Links
1 / 54

Take control PowerPoint PPT Presentation


  • 67 Views
  • Uploaded on
  • Presentation posted in: General

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

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.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 gebruikers

overload gebruikers?

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


Take control

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 [email protected]' (${ 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 gebruikers

CORE::GLOBAL gebruikers?

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 (*;$@) {

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 (*;$@) {

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 handler gebruikers

Attribute::Handler gebruikers?

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


  • Login