Take control

1
Take control

• Introductie in het wijzigen van standaard Perl
  gedrag

use WorkshopPerlDutch 5 date( '2008-02-29'
) author( abeltje gt 'Abe Timmerman' )
2
Technieken

• overload
• tie
• COREGLOBAL
• AttributeHandlers

3
overload gebruikers?
4
overload

• stringify
• String functies
• Numify
• Rekenkundige bewerkingen
• Rekenkundige functies
• overloadconstant()

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

6
Coords.pm
package Coords sub new my( class,
x, y ) _at__ bless _x gt x 0, _y gt
y 0 , class sub move my( self,
dx, dy ) _at__ ref dx eq __PACKAGE__ and (
dx, dy ) ( dx-gt_x, dx-gt_y )
self-gt_x dx self-gt_y dy
return self sub as_string my( self )
_at__ return sprintf "(d, d)", self-gt_x,
self-gt_y
7
Coords.pm
package Coords use overload q"" gt
\as_string, fallback gt 1 sub new
my( class, x, y ) _at__ bless _x gt x
0, _y gt y 0 , class sub move
my( self, dx, dy ) _at__ ref dx eq
__PACKAGE__ and ( dx, dy ) ( dx-gt_x,
dx-gt_y ) self-gt_x dx
self-gt_y dy return self sub
as_string my( self ) _at__ return
sprintf "(d, d)", self-gt_x, self-gt_y
8
Testing Coords.pm
use TestMore 'no_plan' my c Coords-gtnew(
150, 150 ) is c, c-gtas_string, "overloaded
stringify c" c-gtmove( -50, 50 ) is c,
"(100, 200)", "-gtmove(-50,50) c" my m
Coords-gtnew( 50, -50 ) c-gtmove( m ) is c,
"(150, 150)", "-gtmovem c"
overload/coords/1fase/ -gt prove -lv t/.t
9
Using '' to move
use TestMore 'no_plan' my c1 Coords-gtnew(
150, 150 ) is c1, c1-gtas_string, "overloaded
stringify c1" my c2 Coords-gtnew( -50, 50
) is c2, c2-gtas_string, "overloaded stringify
c2" my r2 c1 c2 isa_ok r2,
'Coords' is r2, "(100, 200)", "overloaded
addition r2"
10
Using '' to move
use TestMore 'no_plan' my c1 Coords-gtnew(
150, 150 ) is c1, c1-gtas_string, "overloaded
stringify c1" my c2 Coords-gtnew( -50, 50
) is c2, c2-gtas_string, "overloaded stringify
c2" my r1 c1-gtcopy isa_ok r1,
'Coords' is r1, c1, "-gtcopy r1" r1-gtmove(
c2 ) is r1, "(100, 200)", "-gtmovec2
r1" my r2 c1 c2 isa_ok r2,
'Coords' is r2, "(100, 200)", "overloaded
addition r2"
11
Using '' to move
package Coords use overload q"" gt
\as_string, fallback gt 1 sub new
my( class, x, y ) _at__ bless _x gt x
0, _y gt y 0 , class sub copy
return bless _x gt _0-gt_x, _y gt
_0-gt_y , ref _0 sub move my(
self, dx, dy ) _at__ ref dx and ( dx,
dy ) ( dx-gt_x, dx-gt_y ) self-gt_x
dx self-gt_y dy return
self sub as_string my( self )
_at__ return sprintf "(d, d)", self-gt_x,
self-gt_y
12
Using '' to move
package Coords use overload q"" gt
\as_string, q gt \add_move,
fallback gt 1 sub new my( class, x, y
) _at__ bless _x gt x 0, _y gt y 0
, class sub copy return bless _x gt
_0-gt_x, _y gt _0-gt_y , ref _0
sub move my( self, dx, dy ) _at__
ref dx and ( dx, dy ) ( dx-gt_x, dx-gt_y
) self-gt_x dx self-gt_y
dy return self sub add_move my(
a1, a2 ) _at__ ref a2 or die "Cannot
move() with constants!" a1-gtcopy-gtmove( a2
) sub as_string my( self ) _at__
return sprintf "(d, d)", self-gt_x,
self-gt_y
13
Meer informatie

• perldoc overload

14
tie() gebruikers?
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()

16
TIEARRAY API

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

17
TIEARRAY

• Geef een object de interface van een array
• In het voorbeeld gebruik een scalar als array
• substr() lt-gt push/pop/unshift/shift/slice

18
CharArray (src1)
package CharArray use warnings use strict sub
TIEARRAY my class shift ref _0
or die "Usage tie my _at_a, CharArray gt
\scalar" bless _0, class sub UNTIE
sub FETCHSIZE my self shift
defined self ? length( self ) 0
19
CharArray (src2)
sub FETCH my( self, index ) _at__
index gt length self and self . "" x ( 1
index - length self ) defined self
? substr self, index, 1
undef sub STORE my( self, index,
value ) _at__ index gt length self and
self . "" x ( 1 index - length self )
substr self, index, 1, value sub PUSH
my self shift self . join "", _at__
length self sub POP my self
shift my last substr self, -1, 1
self substr self, 0, length( self ) - 1
last 1
20
Testing CharArray.pm
! /usr/bin/perl use warnings use strict use
TestMore 'no_plan' use_ok 'CharArray'
my orig 'value' tie my _at_ca, 'CharArray',
\orig is ca0, 'v', "First value '_at_ca'
( tied( _at_ca ) )" push _at_ca, 's' is
_at_ca, 6, "new length ( tied( _at_ca ) )" my
sorted join "", sort _at_ca is sorted,
'aelsuv', "sorting the array works (sorted)"
untie _at_ca is orig, 'values', "still the
changed value in original (orig)"
tie/array/ -gt prove -lv t/.t
21
TIEHANDLE API

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

22
TIEHANDLE (output)

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

23
CatchOut.pm
package CatchOut use strict use warnings our
VERSION 0.04 tie HANDLE, CatchOut gt
lt\TIEDHANDLE \bufgt sub TIEHANDLE my
class shift ref _0 eq __PACKAGE__ and
return _0 ref _0 eq 'SCALAR'
or die "Usage\n\ttie HANDLE, CatchOut gt
lt\TIEDHANDLE \bufgt" bless _0,
class sub PRINT my self shift
self . join "", _at__ sub PRINTF my
self shift my( fmt, _at_args ) _at__
self . sprintf fmt, _at_args 1
24
Testing CatchOut.pm
! perl use warnings use strict use TestMore
'no_plan' use_ok 'CatchOut' my
outbuf local OUT tie
OUT, 'CatchOut', \outbuf print OUT
"Testline\n" untie OUT is
outbuf, ltlt' __EOTEST__', "Caught the right
output" Testline __EOTEST__
25
TIEHANDLE (input)

• Input
• STDIN
• Elke andere GLOB
• Methods
• TIEHANDLE
• READLINE

26
FeedIn.pm
package FeedIn use warnings use strict our
VERSION 0.01 tie FH, FeedIn gt text sub
TIEHANDLE my( class, store ) _at__
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 _at_lines grep length
_ gt self m(.?(?/\z))sg
self undef return _at_lines else
return defined self
s(.?(?/\z))s ? 1 undef 1
27
Testing FeedIn.pm
! perl use warnings use strict use TestMore
'no_plan' use_ok 'FeedIn' local IN
tie IN, 'FeedIn', "regel 1\nregel 2" my
_at_line ltINgt is scalar _at_line, 2, "2 lines in
list-context" is line0, "regel 1\n",
"Read a line 'line0'" is line1, "regel
2", "Read a line 'line1'" local IN
tie IN, 'FeedIn', "regel 1\nregel 2" my
_at_line while ( ltINgt ) push _at_line, _
is scalar _at_line, 2, "2 lines in list-context"
is line0, "regel 1\n", "Read a line
'line0'" is line1, "regel 2", "Read a
line 'line1'" local IN tie IN,
'FeedIn', "regel 1\nregel 2" my lines do
local / ltINgt is lines, "regel
1\nregel 2", "Slurp-mode"
28
Meer informatie

• perldoc perltie

29
COREGLOBAL gebruikers?
30
COREGLOBAL

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

31
COREGLOBALgmtime
! /usr/bin/perl use warnings use strict BEGIN
29 Feb 2008 120000 GMT
COREGLOBALgmtime sub () my
stamp _at__ ? _0 1204286400
COREgmtime( stamp ) printf "
empty s\n", scalar gmtime( ) printf "time()
s\n", scalar gmtime( time )
32
Een test case voor open()

• Ik wil de volgende soort code testen
• open my fh, 'lt', '/proc/cpuinfo'
• Herdefinieer
• COREGLOBALopen
• Gebruik een tied handle voor invoer
• FeedIn.pm

33
MyOpen.pm
package MyOpen use warnings use strict our
VERSION 0.01 sub core_open (_at_) my(
handle, mode, file, _at_list ) _at__ 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 "sNHddd", pkg, , time, rand
100 convert to two
argumented open() defined file and mode .
" file" COREopen( handle, mode )
prepare open() for runtime override BEGIN
COREGLOBALopen \core_open 1
34
Testing MyOpen.pm
! perl use warnings use strict use TestMore
'no_plan' BEGIN use_ok 'MyOpen' ok defined
COREGLOBALopen, "COREGLOBALopen()
defined" my content COREopen( my fh,
'lt', 0 ) or die "Cannot COREopen(0) !"
isa_ok fh, 'GLOB' content do local /
ltfhgt close fh like content,
qr/BEGIN use_ok 'MyOpen' /, "contains
MyOpen" open my fh, 'lt', 0 or die
"Cannot open(0) !" isa_ok fh, 'GLOB'
my file do local / ltfhgt close
fh is file, content, "contents still the
same"
35
Bringing it togther (1/2)
! perl use warnings use strict use TestMore
'no_plan' BEGIN use_ok 'MyOpen' ok defined
COREGLOBALopen, "COREGLOBALopen()
defined" use_ok 'FeedIn' no warnings
'redefine' local COREGLOBALopen
\tied_open open my fh, 'lt', 0 or die
"Cannot tied_open(0) !" isa_ok tied( fh
), 'FeedIn' my file do local / ltfhgt
close fh is file, "open 0",
"tied_open() returned 'file'"
36
Bringing it together (2/2)
sub tied_open (_at_) my( handle, mode,
file ) _at__ 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 "sNHddd",
pkg, , time, rand 100
convert to two argumented open() defined
file and mode . " file" do the
magic-tie for open "lt 0" or pass to
COREopen() if ( mode m/(?lt\s)?(0)/
) tie handle, FeedIn gt "open 1"
else COREopen( handle, mode )

37
Meer informatie

• perldoc perlsub

38
AttributeHandler gebruikers?
39
AttributeHandlers

• 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

40
Types voor een attribute

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

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)

42
Een attribute voor tie()
package Tie_OddEven use strict use
warnings our VERSION 0.01 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
43
Voorbeeld code voor gebruik
! /usr/bin/perl use warnings use strict use
lib 'lib' use Tie_OddEven tie my oe,
Tie_OddEven gt 0 while ( 1 ) print
"Number " chomp( my input ltgt ) last
unless input /-?\d/ oe input
printf "input is oe (d)\n", tied oe
44
Een attribute voor tie()
package Tie_OddEven use strict use
warnings our VERSION 0.01 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
45
Een attribute voor tie()
package Tie_OddEven use strict use
warnings our VERSION 0.01 use
AttributeHandlers sub OddEven ATTR(SCALAR)
my( pkg, symbol, referent, attr, data
) _at__ 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
46
Voorbeeld code voor gebruik
! /usr/bin/perl use warnings use strict use
lib 'lib' use Tie_OddEven tie my oe,
Tie_OddEven gt 0 while ( 1 ) print
"Number " chomp( my input ltgt ) last
unless input /-?\d/ oe input
printf "input is oe (d)\n", tied oe
47
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 ltgt ) last unless input
/-?\d/ oe input printf
"input is oe (d)\n", tied oe
48
Oorspronkelijke attribute
package Tie_OddEven use strict use
warnings our VERSION 0.01 use
AttributeHandlers sub OddEven ATTR(SCALAR)
my( pkg, symbol, referent, attr, data
) _at__ 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
49
Een UNIVERSAL attribute
package Universal_OddEven use strict use
warnings our VERSION 0.01 use
AttributeHandlers sub UNIVERSALOddEven
ATTR(SCALAR) my( pkg, symbol, referent,
attr, data ) _at__ 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
50
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 ltgt ) last unless input
/-?\d/ oe input printf
"input is oe (d)\n", tied oe
51
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 ltgt ) last unless input
/-?\d/ oe input printf
"input is oe (d)\n", tied oe
52
Oorspronkelijke attribute
package Tie_OddEven use strict use
warnings our VERSION 0.01 use
AttributeHandlers sub OddEven ATTR(SCALAR)
my( pkg, symbol, referent, attr, data
) _at__ 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
53
Een attribute en autotie
package Auto_OddEven use strict use
warnings our VERSION 0.01 use
AttributeHandlers autotie gt
'__CALLER__OddEven' gt __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
54
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 ltgt ) last unless input
/-?\d/ oe input printf
"input is oe (d)\n", tied oe
55
Meer informatie

• perldoc AttributeHandlers

56
User-defined lexical pragma gebruikers?
57
fixedtime pragma
SYNOPSIS use TestMore 'no_plan'
my nowstamp time my
fixstamp use
fixedtime stamp gt 1204286400 29 Feb 2008
120000 GMT fixstamp time
is fixstamp, 1204286400, "Fixed
point in time (fixstamp)" is
scalar gmtime, "Fri Feb 29 120000 2008",
"_at_scalar gmtime" no
fixedtime is time, nowstamp, "we
ran fast enough (nowstamp)"
is time, nowstamp, "we ran fast enough
(nowstamp)"
58
User-defined lexical pragma

• Nieuw in Perl 5.10
• H hints hash (compiletime)
• Hyourpragma 1 in sub import
• Hyourpragma 0 in sub unimport
• Alleen "eenvoudige" scalars (integer, string)
• (caller 1)10 ref naar H (runtime)
• Inspecteer hh-gtyourpragma voor status

59
fixedtime.pm (src1)
package fixedtime use 5.010 this is a
user-defined pragma and needs perl 5.10 or
higher use warnings use strict our VERSION
0.01 sub import shift my args
_at__ Hfixedtime exists argsstamp
? argsstamp // COREtime
COREtime sub unimport Hfixedtime
undef sub epoch_offset my level shift
// 0 my ctrl_h ( caller level 1
)10 return ctrl_h-gtfixedtime
60
fixedtime.pm (src2)
BEGIN COREGLOBALtime sub
return fixedtimeepoch_offset() // COREtime
COREGLOBALgmtime sub ()
my stamp shift // fixedtimeepoch_offset()
// COREtime COREgmtime( stamp )
COREGLOBALlocaltime sub ()
my stamp shift // fixedtimeepoch_offset(
) // COREtime CORElocaltime( stamp
) 1
61
Testing fixedtime.pm (1/2)
! perl use warnings use strict use TestMore
'no_plan' my nowstamp time my
fixstamp use fixedtime stamp gt
1204286400 29 Feb 2008 120000 GMT
fixstamp time is fixstamp,
1204286400, "Fixed point in time (fixstamp)"
is scalar gmtime, "Fri Feb 29 120000
2008", "(_at_ scalar gmtime )" no
fixedtime is time, nowstamp, "we ran
fast enough inner (nowstamp)" is
time, nowstamp, "we ran fast enough outer
(nowstamp)" isnt nowstamp, fixstamp,
"now() ! fixed"
62
Testing fixedtime.pm (2/2)
my _at_cgtime gmtime my _at_fgtime ( 0, 0, 12, 29,
1, 108, 5, 59, 0 ) use fixedtime stamp gt
1204286400 29 Feb 2008 120000 GMT my
_at_ftime gmtime is_deeply \_at_ftime, \_at_fgtime,
"gmtime() is fixed (_at_ scalar gmtime )"
or diag Dumper \_at_ftime nested calls
should update the fixed stamp use
fixedtime stamp gt 1204286400 60 60
my _at_fltime _at_fgtime fltime2 1 my
_at_ltime gmtime is_deeply \_at_ltime,
\_at_fltime, "gmtime() in scope (_at_ scalar gmtime
)" or diag Dumper \_at_ltime
_at_ftime gmtime is_deeply \_at_ftime,
\_at_fgtime, "gmtime() is back (_at_ scalar gmtime
)" or diag Dumper \_at_ftime no
fixedtime my _at_gtime gmtime is_deeply
\_at_gtime, \_at_cgtime, "times compare (_at_ scalar
gmtime )" or diag Dumper \_at_gtime my
_at_gtime gmtime is_deeply \_at_gtime, \_at_cgtime,
"times compare (_at_ scalar gmtime )" or
diag Dumper \_at_gtime
63
Meer informatie

• perldoc perlpragma

64
Vragen?
65
Dank je wel!