Perl für Fortgeschrittene

Max Maischein

Frankfurt.pm

Perl für Fortgeschrittene

  • Weites Feld

  • Kleine Schritte

  • Überblick über Kenntnisse

  • Überblick über Techniken

  • Überblick über Anwendung

  • Einzelne Gebiete

Perl für Fortgeschrittene

Was zeichnet einen fortgeschrittenen Perl Programmierer aus? (Nathan Torkington)

Perl für Fortgeschrittene

  • Novize: Perl und CGI sind das selbe

  • Initiierter: Denkt, Perl sollte mehr wie Java sein

  • Anwender: Kennt und nutzt CPAN, verwendet <DATA>

  • Adept: Verwendet s///e , schreibt eigene Module in Perl

  • Hacker: Verwendet AUTOLOAD

  • Guru: Kann alles mit Perl schreiben, und tut es

  • Zauberer: Schreibt keine Spiele in Perl, da Perl das Spiel ist

Perl für Fortgeschrittene

  • Novize: Perl und CGI sind das selbe

  • Initiierter: Denkt, Perl sollte mehr wie Java sein

  • Anwender: Kennt und nutzt CPAN, verwendet <DATA>

  • Adept: Verwendet s///e , schreibt eigene Module in Perl

  • Hacker: Verwendet AUTOLOAD

  • Guru: Kann alles mit Perl schreiben, und tut es

  • Zauberer: Schreibt keine Spiele in Perl, da Perl das Spiel ist

Vorgehensweise

  • Diskussion über Perl Techniken

  • "interessante" Stellen des Codes

  • Buffet statt Menü

Was werden wir sehen?

  • Referenzen und Speicherverwaltung von Perl

  • Closures

  • Erzeugen von Subroutinen/Methoden ohne eval

  • Dispatchtabellen (URL-Regex => Code)

  • /e in regulären Ausdrücken

  • Temporäres Ersetzen von Code mit anderem Code (Tests)

  • Distribution von Anwendungen mittels CPAN.pm

Die Anwendung

Die Anwendung

User

Die Anwendung

Firefox-User

Die Anwendung

Firefox-User

Schnelle Downloads

Die Anwendung

Firefox-User

Schnelle Downloads

Langsame Uploads

Die Anwendung

Firefox-User

Schnelle Downloads

Langsame Uploads

Schnelle Downloads vom privaten Server

Projekt RemoteDownload

  • Client: FireFox mit URL-POST Plugin (selbstgeschrieben)

Projekt RemoteDownload

  • Client: FireFox mit URL-POST Plugin (selbstgeschrieben)

  • Server: CGI bzw. HTTP::Server::Simple Server zum Testen

Projekt RemoteDownload

  • Client: FireFox mit URL-POST Plugin (selbstgeschrieben)

  • Server: CGI bzw. HTTP::Server::Simple Server zum Testen

  • wget zum Download

Projekt RemoteDownload

  • Client: FireFox mit URL-POST Plugin (selbstgeschrieben)

  • Server: CGI bzw. HTTP::Server::Simple Server zum Testen

  • wget zum Download

Projekt RemoteDownload

  • Client: FireFox mit URL-POST Plugin (selbstgeschrieben)

  • Server: CGI bzw. HTTP::Server::Simple Server zum Testen

  • wget zum Download

  • Einfaches HTML für die Fortschrittsanzeige

Projekt RemoteDownload

  • Client: FireFox mit URL-POST Plugin (selbstgeschrieben)

  • Server: CGI bzw. HTTP::Server::Simple Server zum Testen

  • wget zum Download

  • Einfaches HTML für die Fortschrittsanzeige

Philosophie

Frameworks und Bibliotheken

  • You call a library

  • A framework calls you

  • Framework ruft Code auf

  • Framework ruft Code nicht auf

  • Die Stelle für Code ist unauffindbar

Frameworks

  • Frameworks sind mächtig

  • Frameworks behindern das Verständnis

  • Daher: Keine Frameworks

Frameworks (2)

  • Nicht immer effizient (Templates)

  • Erstaunlicherweise klappt es

  • Flexibilität ist hilfreich und behindert (z.B. DBIx::Class)

  • CPAN-Release?

Referenzen und komplexe Datenstrukturen

Referenzen sind das Tor zu komplexen Datenstrukturen

Datentypen in Perl:

  • Scalar - $ - ein einzelnes Element

  • Array - @ - eine geordnete Folge von Skalaren

  • Hash - % - eine ungeordnete Menge von Paaren (String,Skalar)

  • Codereferenz - & - Code

  • Glob - * - ein Eintrag eines globalen Namens

  • Format

Referenzen

  • Eine Referenz ist immer ein Skalar

  • Referenzen sind wie eine Schnur - man hält das eine Ende und hat den Wert am anderen Ende

  • Bessere Metaphern sind willkommen

Referenzen: Skalare

 1:  my $bird = "Woodstock";
 2:  my $piepmatz = \$bird;

Referenzen: Skalare

 1:  my $bird = "Woodstock";
 2:  my $piepmatz = \$bird;
 3:  
 4:  print $bird; # Woodstock
 5:  print $$piepmatz; # Woodstock

Referenzen: Skalare

 1:  my $bird = "Woodstock";
 2:  my $piepmatz = \$bird;
 3:  
 4:  print $bird; # Woodstock
 5:  print $$piepmatz; # Woodstock

Vorsicht beim Ändern von referenzierten Werten:

 1:  $$piepmatz = "Polly";
 2:  print $bird; # Polly

  • Sehr gut zum gemeinsamen (Schreib-)Zugriff auf Werte.

  • Sehr schlecht, wenn doch nicht alles geteilt werden sollte.

Referenzen erzeugen

Einen anonymen Skalar zu erzeugt man durch direktes Nehmen der Referenz:

 1:  my $bird = "Woodstock";
 2:  my $piepmatz = \"Woodstock";
 3:  
 4:  print $bird; # Woodstock
 5:  
 6:  print $piepmatz; # SCALAR(0x1822c34)
 7:  
 8:  print $$piepmatz; # Woodstock

Referenzen: Arrays

[] erzeugt ein Array

 1:  my @cats = ('Tom','Garfield','Hobbes');
 2:  my $katzen = ['Tom','Garfield','Hobbes'];
 3:  
 4:  @cats
 5:  @{ $katzen }
 6:  
 7:  print $cats[0]; # Tom
 8:  print $katzen->[1]; # Garfield

Referenzen: Hashes

{} erzeugt ein Hash

my %animals = (
   dogs => [ 'Snoopy', '' ],
   cats => \@cats,
);

my $tiere = {
   hunde => [ 'Snoopy', '' ],
   #katzen => \@{$katzen},
   katzen => $katzen,
};

Referenzen: Hashes

{} erzeugt ein Hash

my %animals = (
   dogs => [ 'Snoopy', '' ],
   cats => \@cats,
);

my $tiere = {
   hunde => [ 'Snoopy', '' ],
   #katzen => \@{$katzen},
   katzen => $katzen,
};

Referenzen: Hashes

{} erzeugt ein Hash

my %animals = (
   dogs => [ 'Snoopy', '' ],
   cats => \@cats,
);

my $tiere = {
   hunde => [ 'Snoopy', '' ],
   #katzen => \@{$katzen},
   katzen => $katzen,
}

Referenzen: Code

sub erzeugt anonymen Code.

Referenzen: Code

sub erzeugt anonymen Code.

grep

 1:  my @files = grep { -f } readdir DIR;
 2:  
 3:  my @files = grep sub { -f $_ }, readdir DIR;

Referenzen: Code

sub erzeugt anonymen Code.

grep

map

 1:  my @files = map { "$dirname/$_" } readdir DIR;
 2:  
 3:  my @files = map sub { "$dirname/$_" }, readdir DIR;

Referenzen: Code

sub erzeugt anonymen Code.

grep

map

sort

 1:  my @files = sort sub { 
 2:                -s "$dirname/$a" 
 3:                <=>
 4:                -s "$dirname/$b" 
 5:              }, readdir DIR;

Codereferenzen

 1:  sub hello { print "Hello" };
 2:  my $sag_hallo = sub { print "Hallo" };

Codereferenzen

 1:  sub hello { print "Hello" };
 2:  my $sag_hallo = sub { print "Hallo" };
 3:  
 4:  hello(); # Hello
 5:  $sag_hallo->(); # "Hallo"

Codereferenzen

 1:  sub hello { print "Hello" };
 2:  my $sag_hallo = sub { print "Hallo" };
 3:  
 4:  hello(); # Hello
 5:  $sag_hallo->(); # "Hallo"
 6:  
 7:  my $greet = $lang eq 'de' ? $sag_hallo : \&hello;
 8:  $greet->();

Codereferenzen

 1:  sub hello { print "Hello" };
 2:  my $sag_hallo = sub { print "Hallo" };
 3:  
 4:  hello(); # Hello
 5:  $sag_hallo->(); # "Hallo"
 6:  
 7:  my $greet = $lang eq 'de' ? $sag_hallo : \&hello;
 8:  $greet->();
 9:  # "Hallo" oder "Hello",
10:  # abhängig von der Sprache

Eigenes grep schreiben

 1:  sub my_grep (&@) {
 2:      my $code = shift;
 3:      my @result;
 4:      for (@_) {
 5:          if ($code->()) {
 6:              push @result, $_;
 7:          }
 8:      }
 9:      @_
10:  }

Eigenes grep schreiben

 1:  sub my_grep (&@) {
 2:      my $code = shift;
 3:      my @result;
 4:      for (@_) {
 5:          if ($code->()) {
 6:              push @result, $_;
 7:          }
 8:      }
 9:      @_
10:  }
11:  print for my_grep {$_ % 2} (1,2,3,4,5,6);
12:  # 1 3 5

Symbolische Referenzen

Symbolische Referenzen sind Schnüre mit Namen

  • Gut bei eindeutigem Namen

  • Maximilian Johannes Maischein

  • Schlecht bei Allerweltsnamen

  • Ulli Müller

  • Und Tippfehlern

  • Uli Müller

Alternative zu symbolischen Referenzen

 1:  %messages = (
 2:      hallo => [],
 3:  );
 4:  $messages{hello}->[0] = 'World';

  • Schützt nicht vor Tippfehlern

  • Schützt vor unbeabsichtigten Datenlecks

Datenlecks bei symbolischen Referenzen

 1:  use CGI 'param';
 2:  use vars qw($db_login $db_password);
 3:  $db_login = 'scott';
 4:  $db_password = 'tiger';

Datenlecks bei symbolischen Referenzen

 1:  use CGI 'param';
 2:  use vars qw($db_login $db_password);
 3:  $db_login = 'scott';
 4:  $db_password = 'tiger';
 5:  ...
 6:  $sql_query = param('sql_query');
 7:  print "Running $$sql_query\n";     # Whooops
 8:  $sth = $dbh->prepare($$sql_query);

  • $db_login und $db_password können ausgelesen werden

  • Und auch alle anderen (skalaren) Variablen

  • use strict;

  • ... und ein Hash

Zwischenstand

  • \ erzeugt eine Referenz

  • -> führt von der Referenz zum Wert

  • $array[5] ist als Referenz $aref->[5]

  • $hash{fuenf} ist als Referenz $href->{fuenf}

  • Symbolische Referenzen

Exkurs: Sichtbarkeit und Lebensdauer

Exkurs zu meinem letzten Tutorial (Bochum, 2006)

Sichtbarkeit und Lebensdauer

Sichtbarkeit und Lebensdauer

my erzeugt eine lexikalische Bindung ("binding") eines Namens an einen Wert:

 1:  my $x = 3;

  • Bindung nur innerhalb von Sichtbarkeit

  • "Pad" speichert Bindungen

  • use strict; prüft Bindungen

  • Lexikalische Bindungen (my)

  • Globale Bindungen (use vars;)

Sichtbarkeit im Quellcode

Sichtbarkeit hängt nur vom Quellcode ab:

Sichtbarkeit im Quellcode

Sichtbarkeit hängt nur vom Quellcode ab:

Sichtbarkeit im Quellcode

Sichtbarkeit hängt nur vom Quellcode ab:

Sichtbarkeit im Quellcode

Sichtbarkeit hängt nur vom Quellcode ab:

Sichtbarkeit im Quellcode

Sichtbarkeit hängt nur vom Quellcode ab:

Lebensdauer von Werten

  • Lebensdauer von Werten und Sichtbarkeit von Bindungen sind nicht das selbe.

  • Datenstruktur in Zeile 4:

     1:  my $x;
 2:  {
 3:      $x = 3;
 4:      my $r = \$x;
 5:  }

  • Lebensdauer und Sichtbarkeit stimmen überein.

Lebensdauer von Werten (I/2)

Datenstruktur in Zeile 5 (Zwischenschritt):

 1:  my $x;
 2:  {
 3:      $x = 3;
 4:      my $r = \$x;
 5:  }

Lebensdauer von Werten (I/3)

Datenstruktur in Zeile 5:

 1:  my $x;
 2:  {
 3:      $x = 3;
 4:      my $r = \$x;
 5:  }

Lebensdauer von Werten (II/1)

Datenstruktur in Zeile 4:

 1:  my $r;
 2:  {
 3:      my $x = 3";
 4:      $r = \$x;
 5:  }

Lebensdauer von Werten (II/2)

Datenstruktur in Zeile 5:

 1:  my $r;
 2:  {
 3:      my $x = 3";
 4:      $r = \$x;
 5:  }

  • Lebensdauer und Sichtbarkeit stimmen nicht überein.

  • Der Wert 3 lebt weiter

Verwendung mit Objekten

 1:  my %self = ...;
 2:  return bless \%self, $class;

  • Geht nicht mit C!

  • Auto-Variable (bzw. Variable auf dem Stack) dürfen nicht nach dem return verwendet werden.

  • In C: malloc / new / free

Verwendung als Zähler

 1:  sub make_counter {
 2:      my $pos = shift || 1;
 3:      return sub {
 4:          $pos++
 5:      }
 6:  };

Verwendung als Zähler

 1:  sub make_counter {
 2:      my $pos = shift || 1;
 3:      return sub {
 4:          $pos++
 5:      }
 6:  };
 7:  my $c1 = make_counter;
 8:  my $c2 = make_counter(10);
 9:  print $c1->(); # 1
10:  print $c2->(); # 10
11:  print $c1->(); # 2
12:  print $c2->(); # 11

Vorbelegung von Werten

Engl. "Currying"

 1:  sub successor { $_[0] +1 };
 2:  
 3:  sub make_counter {
 4:      my $pos = shift || 1;
 5:      return sub {
 6:          $pos = successor($pos)
 7:      }
 8:  }

Callbacks an Objekte

Erzeugen für Callbacks an Objekte:

 1:  my $call_me = sub {
 2:      $self->phone_call(@_)
 3:  }

Zwischenstand

  • Code Referenzen haben eigene Daten, die den Aufruf überdauern

     1:    sub { $pos++ }

  • "Currying" ist nützlich für Vorbelegung von Werten

     1:      return sub {
 2:          $pos = successor($pos)
 3:      }

  • Callbacks an Objekte:

     1:    my $call_me = sub { $self->phone_call }

Objekte, Closures

Objekte, Closures

Die Downloadqueue ist in einer Datenbank (SQLite).

 1:  job_id    | url              | destination
 2:  ----------+------------------+-------------
 3:  666       | http://google.de | index.html
 4:  ...

  • Ich schreibe aber ungern das simple SQL (INSERT, UPDATE, SELECT).

  • Eigener ORM (Object Relational Mapper)

  • Nachbau von Class::DBI bzw. DBIx::Class, aber auf uns zugeschnitten, und weniger flexibel.

Ein eigener ORM

Tabelle:

 1:  job_id    | url              | destination
 2:  ----------+------------------+-------------
 3:  666       | http://google.de | index.html
 4:  ...

Perl Struktur

 1:  { job_id => 666,
 2:    url => 'http://google.de', 
 3:    destination => 'index.html' }

ORM

  • Transparent direkt in der Datenbank ändern.

  • Ineffizient. Na und?

     1:  print $job->url(); # http://google.de
 2:  $job->url("http://www.perlworkshop.de");
 3:  $job->update(); # Schreibt alle Werte in die Datenbank

  • Die Routinen für die Spalten sollen (halb)automatisch erzeugt werden (job_id, url, destination).

Accessors als Closures

Verwendung der Zugriffsroutinen:

 1:  package RemoteDownload::Job;
 2:  
 3:  @columns = (qw(job_id owner
 4:      pid url destination status position));
 5:  
 6:  __PACKAGE__->mk_accessor($_) for (@columns);

Accessors über eval

 1:  sub mk_accessor {
 2:    my ($class,$name) = @_;
 3:    eval <<CODE;
 4:        sub $class\::$name {
 5:            if (\@_ == 1) {
 6:                \$_[0]->{$name}
 7:            } else {
 8:                \$_[0]->{$name} = \$_[1]
 9:            };
10:        };
11:  CODE

  • Häßlich: Syntaxfehler

  • Quoting

  • String-eval ist ein Risiko

Accessors als Closures

Verwendung einer Closure als $accessor.

 1:  sub mk_accessor {
 2:    my ($class,$name) = @_;
 3:    my $accessor = sub {
 4:        if (@_ == 1) {
 5:            $_[0]->{$name}
 6:        } else {
 7:            $_[0]->{$name} = $_[1]
 8:        };
 9:    };

Accessors als Closures

Verwendung einer Closure als $accessor.

 1:  sub mk_accessor {
 2:    my ($class,$name) = @_;
 3:    my $accessor = sub {
 4:        if (@_ == 1) {
 5:            $_[0]->{$name}
 6:        } else {
 7:            $_[0]->{$name} = $_[1]
 8:        };
 9:    };
10:  
11:    # Accessor installieren
12:    no strict 'refs';
13:    *{"$class\::$name"} = $accessor;
14:  };

Accessors als Closures

 1:  App::RemoteDownload::Queue->mk_accessor(qw(
 2:      job_id url target
 3:  ));

Installiert job_id, url und target

Verwendung der Accessoren

->find ()

 1:  my $job =
 2:    App::RemoteDownload::Job
 3:      ->find( job_id => 666 );
 4:  # SELECT @columns FROM queue
 5:  #   WHERE job_id = 666

Verwendung der Accessoren

->find ()

 1:  my $job =
 2:    App::RemoteDownload::Job
 3:      ->find( job_id => 666 );
 4:  # SELECT @columns FROM queue
 5:  #   WHERE job_id = 666
 6:  print join ",", 
 7:    $job->job_id, $job->url, $job->destination;

Verwendung der Accessoren

->update ()

 1:  $job->update();
 2:  # UPDATE queue SET @columns = @{$self}{@columns}

Verwendung der Accessoren

->update ()

 1:  $job->update();
 2:  # UPDATE queue SET @columns = @{$self}{@columns}

->delete()

 1:  $job->delete();
 2:  # DELETE FROM queue WHERE job_id = $self->{job_id}

Vergleich mit anderen ORMs

  • Wenig Konfiguration, $dbh in globaler Variable, Tabellenname fest

  • Wenig Flexibilität (nur eine Datenbankverbindung)

  • Wenig Code, wenig Abhängigkeiten (100 Zeilen, DBI)

  • Verknüpfungen über Tabellen fehlen

  • wurden aber auch nicht benötigt

  • Siehe SQL::Abstract, DBIx::Class, Class::DBI, Rose::Object

Verknüpfungen von Tabellen

Die Verknüpfungen über Tabellen hinweg als Perl-Objekte sind mit der Methode, wie sie in ->mk_accessor genommen wurde, ebenfalls möglich:

 1:  sub has_many {
 2:      my ($class,$what,$how) = @_;
 3:      *{"$class\::$what"} = sub {
 4:          ...
 5:      };
 6:  };

Queue SQL

 1:  my $sth_lock = $self->dbh->prepare(<<"");
 2:    UPDATE queue SET pid = ?
 3:    WHERE job_id IN (
 4:      SELECT job_id FROM queue WHERE
 5:        pid IS NULL
 6:        AND status IS NULL
 7:        LIMIT $count
 8:    )
 9:  ...

Queue SQL

 1:  my $sth_lock = $self->dbh->prepare(<<"");
 2:    UPDATE queue SET pid = ?
 3:    WHERE job_id IN (
 4:      SELECT job_id FROM queue WHERE
 5:        pid IS NULL
 6:        AND status IS NULL
 7:        LIMIT $count
 8:    )
 9:  
10:  if ($sth_lock->execute($$) > 0) {
11:    $sth_lock->finish;
12:    my $sth_items = $self->dbh->prepare(<<"");
13:      SELECT job_id FROM queue
14:      WHERE pid = ?
15:      AND status IS NULL
16:    ...

Queue SQL - Update

Queue SQL - Update

Queue SQL - Update

Queue SQL - Update

Queue SQL - Update

Queue SQL - Update

Queue SQL - Select

Queue SQL - Select

Zusammenfassung

  • Spezialisieren von Code ist einfach

  • Installieren von Code ist einfach

  • Eigener Persistenzlayer ist einfach

  • Verknüpfung von mehreren Tabellen schwieriger

  • Eigenes SQL unabdingbar

Überblick über Webserver

Überblick über Webserver

Überblick über Webserver

Überblick über Webserver

Überblick über Webserver

Das Webinterface

Das Webinterface

Das Webinterface

Das Webinterface

Zentrale Behandlungsroutine handle_request

URLs mappen

Zuordnung URLs zu Code und Templates

  • ^/$ -> Willkommensseite, GET

  • ^/submit$ -> Neues Download abgeben (User über .htaccess, URL als Parameter, POST)

  • ^/remove/(.*)$ -> Download löschen (User über .htaccess, JobID als Parameter, POST)

  • ^/list$ -> Liste für einen User anzeigen (User über .htaccess, GET)

Dispatch über if

 1:  package App::RemoteDownload::CGI;
 2:  sub handle_request {
 3:    my ($self,$cgi) = @_;
 4:      
 5:    my $p = $cgi->query_path;
 6:    if ($p =~ m!^/!) {
 7:        $self->index();
 8:    } elsif ($p =~ m!^/submit!) {
 9:        ...
10:    }
11:  }

  • Schwer zu warten und zu konfigurieren.

Dispatch Tabellen

  • Zuordnung von URL und Code in Hash

Dispatch Tabellen

  • Zuordnung von URL und Code in Hash

 1:  %handler = (
 2:    '^/$' => 'init',
 3:    '^/submit$' => \&handle_submit,
 4:    '^/remove/(.*)$' => \&handle_remove,
 5:    '^/list$' => \&handle_list,
 6:  );

  • Übersichtlicher zu warten

  • Konfigurierbar

  • Programm kann Konfiguration auslesen

handle_request

 1:  sub handle_request {
 2:    my ($self,$cgi) = @_;

handle_request

 1:  sub handle_request {
 2:    my ($self,$cgi) = @_;
 3:  
 4:    my $p = $cgi->path_info;
 5:    for my $spec (keys %urls) {
 6:        if ($p =~ /$spec/) {
 7:            # Pfad-Parameter extrahieren
 8:            my @args = $p =~ /$spec/;

handle_request

 1:  sub handle_request {
 2:    my ($self,$cgi) = @_;
 3:  
 4:    my $p = $cgi->path_info;
 5:    for my $spec (keys %urls) {
 6:        if ($p =~ /$spec/) {
 7:            # Pfad-Parameter extrahieren
 8:            my @args = $p =~ /$spec/;
 9:  
10:            my $method = $urls{$spec};
11:            $self->$method(query => $cgi,
12:                           args => \@args);
13:            return;
14:        };
15:    };

handle_request

 1:  sub handle_request {
 2:    my ($self,$cgi) = @_;
 3:  
 4:    my $p = $cgi->path_info;
 5:    for my $spec (keys %urls) {
 6:        if ($p =~ /$spec/) {
 7:            # Pfad-Parameter extrahieren
 8:            my @args = $p =~ /$spec/;
 9:  
10:            my $method = $urls{$spec};
11:            $self->$method(query => $cgi,
12:                           args => \@args);
13:            return;
14:        };
15:    };
16:    # ansonsten auf die Startseite
17:    print $cgi->redirect('/'); 
18:  };

Daten statt Code

Daten erlauben Introspektion:

 1:  %handler = (
 2:      '^/$' => 'init',
 3:      '^/submit$' => \&handle_submit,
 4:      '^/remove/(.*)$' => \&handle_remove,
 5:      '^/list$' => \&handle_list,
 6:  );

Daten statt Code

Daten erlauben Introspektion:

 1:  %handler = (
 2:      '^/$' => 'init',
 3:      '^/submit$' => \&handle_submit,
 4:      '^/remove/(.*)$' => \&handle_remove,
 5:      '^/list$' => \&handle_list,
 6:  );
 7:  
 8:  sub nav_links {
 9:      make_links( sort keys %handler )
10:  }

Daten statt Code

Daten erlauben Introspektion:

 1:  %handler = (
 2:      '^/$' => 'init',
 3:      '^/submit$' => \&handle_submit,
 4:      '^/remove/(.*)$' => \&handle_remove,
 5:      '^/list$' => \&handle_list,
 6:  );
 7:  
 8:  sub nav_links {
 9:      make_links( sort keys %handler )
10:  }
    ^/$
    ^/submit$
    ^/remove/
    ^/list$

Daten statt Code

Daten erlauben Introspektion:

 1:  %handler = (
 2:      '^/$' => 'init',
 3:      '^/submit$' => \&handle_submit,
 4:      '^/remove/(.*)$' => \&handle_remove,
 5:      '^/list$' => \&handle_list,
 6:  );
 7:  
 8:  sub nav_links {
 9:      make_links( sort keys %handler )
10:  }

Gruppierung von URLs für Statistik

Atempause

Dispatch-Tabellen

  • Ersetzen if Blöcke

  • Erlauben Introspektion

  • Daten-gesteuertes statt Code-gesteuertes Programm

  • Dispatch-Tabellen aus Datenbank oder Konfiguration

Ausgabe in HTML

Ausgabe in HTML

  • Meine eigene Templating Engine

Meine eigene Templating Engine

Darstellung der Job-Queue für einen User:

Templates (print)

Darstellung der Job-Queue für einen User:

Erste Lösung - direkte Stringausgabe

 1:  print "<html>...</html>";

Templates (CPAN)

Zweite Lösung - CPAN Module

Templates über HTML::Template, Template Toolkit etc.

Templates (Eigene Engine)

Dritte Lösung - die eigene Templating Engine

Templates (Eigene Engine)

Dritte Lösung - die eigene Templating Engine

Syntax:

 1:  $user     # $user
 2:  $hash.key # $hash->{key}

Templates (Eigene Engine)

Dritte Lösung - die eigene Templating Engine:

Syntax:

 1:  $user     # $user
 2:  $hash.key # $hash->{key}

Listen

 1:  [% START jobs %]
 2:  $job_id | $url | $status
 3:  [% END jobs %]

Templates (Eigene Engine)

Dritte Lösung - die eigene Templating Engine:

Syntax:

 1:  $user     # $user
 2:  $hash.key # $hash->{key}

Listen

 1:  [% START jobs %]
 2:  $job_id | $url | $status
 3:  [% END jobs %]

Die Listensyntax ist übernommen von Template::Simple

s///ge

s/A/B/ge sucht A, und führt dann B als Perl Code aus.

s///ge

s/A/B/ge sucht A, und führt dann B als Perl Code aus.

 1:  "123" =~ s/(\d)/$1+1/ge; # 234

Implementation

Einfache Variablensubstitution

Implementation

Einfache Variablensubstitution

 1:  sub process {
 2:      my ($template,$parameters) = @_;
 3:      my $result = $template;
 4:      
 5:      $result =~ s{\$(\w+)}{
 6:                    $parameters->{$1}
 7:                  }mge;
 8:  }

Wie funktioniert's?

 1:  my $parameters = {
 2:    nachname => 'Maischein',
 3:    vorname => 'Max',
 4:    anrede => 'Herr',
 5:  };
 6:  process(
 7:      'Hallo $anrede $nachname, dies kostet $5.',
 8:      $parameters
 9:  );

Wie funktioniert's?

Hallo $anrede $nachname, dies kostet $5.
^ 
 1:  $VAR1 = {
 2:          'vorname' => 'Max',
 3:          'anrede' => 'Herr',
 4:          'nachname' => 'Maischein'
 5:        };
 1:  $1                        :
 2:  $parameters->{$1}||'$'.$1 :

Wie funktioniert's?

Hallo $anrede $nachname, dies kostet $5.
      ^ 
 1:  $VAR1 = {
 2:          'vorname' => 'Max',
 3:          'anrede' => 'Herr',
 4:          'nachname' => 'Maischein'
 5:        };
 1:  $1                        :anrede
 2:  $parameters->{$1}||'$'.$1 :Herr

Wie funktioniert's?

Hallo Herr $nachname, dies kostet $5.
      ^ 
 1:  $VAR1 = {
 2:          'vorname' => 'Max',
 3:          'anrede' => 'Herr',
 4:          'nachname' => 'Maischein'
 5:        };
 1:  $1                        :anrede
 2:  $parameters->{$1}||'$'.$1 :Herr

Wie funktioniert's?

Hallo Herr $nachname, dies kostet $5.
           ^ 
 1:  $VAR1 = {
 2:          'vorname' => 'Max',
 3:          'anrede' => 'Herr',
 4:          'nachname' => 'Maischein'
 5:        };
 1:  $1                        :nachname
 2:  $parameters->{$1}||'$'.$1 :Maischein

Wie funktioniert's?

Hallo Herr Maischein, dies kostet $5.
           ^ 
 1:  $VAR1 = {
 2:          'vorname' => 'Max',
 3:          'anrede' => 'Herr',
 4:          'nachname' => 'Maischein'
 5:        };
 1:  $1                        :nachname
 2:  $parameters->{$1}||'$'.$1 :Maischein

Wie funktioniert's?

Hallo Herr Maischein, dies kostet $5.
                                  ^ 
 1:  $VAR1 = {
 2:          'vorname' => 'Max',
 3:          'anrede' => 'Herr',
 4:          'nachname' => 'Maischein'
 5:        };
 1:  $1                        :5
 2:  $parameters->{$1}||'$'.$1 :$5

Wie funktioniert's?

Hallo Herr Maischein, dies kostet $5.
                                  ^ 
 1:  $VAR1 = {
 2:          'vorname' => 'Max',
 3:          'anrede' => 'Herr',
 4:          'nachname' => 'Maischein'
 5:        };
 1:  $1                        :5
 2:  $parameters->{$1}||'$'.$1 :$5

Wie funktioniert's?

Hallo Herr Maischein, dies kostet $5.
                                     ^ 
 1:  $VAR1 = {
 2:          'vorname' => 'Max',
 3:          'anrede' => 'Herr',
 4:          'nachname' => 'Maischein'
 5:        };
 1:  $1                        :
 2:  $parameters->{$1}||'$'.$1 :

  • Extrem kurz

  • Sehr portabel

  • JavaScript, Python

Implementation (2)

Erweiterung um Pfade in Hashes of Hashes

Implementation (2)

Pfade in Hashes of Hashes

  sub process {
    my ($template,$parameters) = @_;
    my $result = $template;

    $result =~ s{\$(\w+)]}{
      $parameters->{$1} || '$'.$1
    }mge;
  }

Implementation (2)

Erweiterung um Pfade in Hashes of Hashes

  sub process {
    my ($template,$parameters) = @_;
    my $result = $template;

    $result =~ s{\$(\w[\w.]+)]}{
      dive($1,$parameters)|| '$'.$1
    }mge;
  }

Implementation (2)

Erweiterung um Pfade in Hashes of Hashes

  sub process {
    my ($template,$parameters) = @_;
    my $result = $template;

    $result =~ s{\$(\w[\w.]+)]}{
      dive($1,$parameters)|| '$'.$1
    }mge;
  }
 
 1:  process('Hallo $user.name', 
 2:      { user => {name => 'Max', id => 666}});
 3:  # "Hallo Max"

Implementation

 1:  sub dive {
 2:      my ($path,$parameters) = @_;
 3:      my @elems = split /\./, $path;
 4:      my $val = $parameters;
 5:      for (@elems) {
 6:          $val = $val->{$_};
 7:      }
 8:      $val
 9:  }

Implementation

 1:  sub dive {
 2:      my ($path,$parameters) = @_;
 3:      my @elems = split /\./, $path;
 4:      my $val = $parameters;
 5:      for (@elems) {
 6:          $val = $val->{$_};
 7:      }
 8:      $val
 9:  }

Implementation

 1:  sub dive {
 2:      my ($path,$parameters) = @_;
 3:      my @elems = split /\./, $path;
 4:      my $val = $parameters;
 5:      for (@elems) {
 6:          $val = $val->{$_};
 7:      }
 8:      $val
 9:  }

Implementation

Jetzt fehlen noch wiederholende Listen:

Implementation

Jetzt fehlen noch wiederholende Listen:

 1:      s{\[% START (\w+) %\](.*?)\[% END \1 %\]}
 2:       {render_repeat($2,$1,$parameters)}ge;

Implementation

Jetzt fehlen noch wiederholende Listen:

 1:      s{\[% START (\w+) %\](.*?)\[% END \1 %\]}
 2:       {render_repeat($2,$1,$parameters)}ge;
 1:  sub render_repeat { 
 2:      my ($tmpl,$name,$params) = @_;
 3:      @_ = @{ $params->{$name} };
 4:      join '', map { process( $tmpl, $_ )} @_
 5:  }

Wiederholende Listen

 1:  sub process_repeat {
 2:      my ($template,$parameters) = @_;
 3:      my $result = $template;
 4:      
 5:      s{\[% START (\w+) %\](.*?)\[% END \1 %\]}
 6:       {render_repeat($2,$1,$parameters)}ge;
 7:      $result;
 8:  }

Wiederholende Listen

Downloads: [% START jobs %] $url ($size) [% END jobs %] 
 1:  $VAR1 = {
 2:          'jobs' => [
 3:                      {
 4:                        'url' => 'http://microsoft.com',
 5:                        'size' => 7823
 6:                      },
 7:                      {
 8:                        'url' => 'http://google.com',
 9:                        'size' => 1203
10:                      },
11:                      {
12:                        'url' => 'http://yahoo.com',
13:                        'size' => 44983
14:                      }
15:                    ]
16:        };

Wiederholende Listen

Downloads: [% START jobs %] $url ($size) [% END jobs %]

Wiederholende Listen

Downloads: http://microsoft.com (7823) http://google.com (1203) http://yahoo.com (44983)

Wiederholende Listen

Downloads: http://microsoft.com (7823) http://google.com (1203) http://yahoo.com (44983) 
 1:  $VAR1 = {
 2:          'jobs' => [
 3:                      {
 4:                        'url' => 'http://microsoft.com',
 5:                        'size' => 7823
 6:                      },
 7:                      {
 8:                        'url' => 'http://google.com',
 9:                        'size' => 1203
10:                      },
11:                      {
12:                        'url' => 'http://yahoo.com',
13:                        'size' => 44983
14:                      }
15:                    ]
16:        };

Kombiniert

 1:  sub process {
 2:      my ($template,$parameters) = @_;
 3:      my $result = $template;
 4:      
 5:      s{\[%\s*START\s*(\w+)\s*%\](.*?)\[%\s*END\s*\1\s*%\]

Kombiniert

 1:  sub process {
 2:      my ($template,$parameters) = @_;
 3:      my $result = $template;
 4:      
 5:      s{\[%\s*START\s*(\w+)\s*%\](.*?)\[%\s*END\s*\1\s*%\]
 6:        |
 7:        \$(\w[\w.]+)
 8:        }

Kombiniert

 1:  sub process {
 2:      my ($template,$parameters) = @_;
 3:      my $result = $template;
 4:      
 5:      s{\[%\s*START\s*(\w+)\s*%\](.*?)\[%\s*END\s*\1\s*%\]
 6:        |
 7:        \$(\w[\w.]+)
 8:        }
 9:       {
10:         process_item($2, $1||$3, $parameters }
11:       }gsex;
12:      $result;
13:  }

Kombiniert (2)

 1:  # Schon wieder eine Dispatchtabelle
 2:  my %handler = (
 3:      'HASH'  => \&dive,
 4:      'ARRAY' => \&render_repeat,
 5:      '' => sub { $_[1] },
 6:  );

Kombiniert (3)

 1:  # Schon wieder eine Dispatchtabelle
 2:  my %handler = (
 3:      'HASH'  => \&dive,
 4:      'ARRAY' => \&render_repeat,
 5:      '' => sub { $_[1] },
 6:  );
 7:  
 8:  sub process_item {
 9:      my ($template,$name,$parameters) = @_;
10:      my $val = $parameters->{$name};
11:      $handler{ref $val}->($template, $val);
12:  }

Überblick über die Renderstruktur:

process_item ruft auf:

  • dive() für Hash

  • render_repeat() für Array

  • sub { $_[1] } für einfaches Item

Templating Systeme

Templating Systeme Eigenbau

Templating Systeme print

Templating Systeme Template::Simple

Templating Systeme HTML::Template

Templating Systeme HTML::Template::Compiled

Templating Systeme Petal

Templating Systeme Template::Toolkit

Templating Systeme Text::Template

Templating Systeme Mason

Atempause

  • Ist das sinnvoll?

  • Nein, vorgefertigte Lösung

  • Ja, gut zu wissen

Tests von erweiterter IPC

Tests von erweiterter IPC

Tests von erweiterter IPC

WWW::Wget

Tests von erweiterter IPC

WWW::Wget

  • startet wget

  • Liefert Ereignisse zur Überwachung

  • Connecting

  • Redirected to ...

  • Downloading

  • 1k of 4096MB received

  • Done

Tests von erweiterter IPC

WWW::Wget

 1:  sub spawn {
 2:    my ($self,@cmd) = @_;
 3:    my $wget;
 4:    $self->{pid} = open $wget, '-|', @cmd
 5:        or die "Couldn't spawn [@cmd]: $! / $?";
 6:    return $wget
 7:  };

WWW::Wget

WWW::Wget

 1:  sub get {
 2:    ...
 3:    my $wget = $self->spawn(...);
 4:    ...
 5:    while (<$wget>) {
 6:        ...
 7:    }
 8:  }

WWW::Wget

WWW::Wget

 1:  sub get {
 2:    ...
 3:    my $wget = $self->spawn(...);
 4:    ...
 5:    while (<$wget>) {
 6:        ...
 7:    }
 8:  }

... aber wie wollen wir ->get() Testen?

Testen von erweiterter IPC

Testen von erweiterter IPC

  • Schreiben eines eigenen fake-wget

  • Sinnvoller Test?

Testen von erweiterter IPC

  • Ersetzen von ->spawn() durch unseren eigenen Code

  • Aufruf von wget sieht aus wie eine Datei

  • Wir liefern eine andere "Datei" zum Test

Das Testprogramm (Setup)

  • Aufruf von wget sieht aus wie eine Datei

  • Wir liefern eine andere "Datei" zum Test

 1:    use Test::More tests => 4;
 2:    use_ok 'WWW::Wget';
 3:    
 4:    {
 5:        no warnings 'redefine';
 6:        *WWW::Wget::spawn = sub {
 7:            return \*DATA;
 8:        };
 9:    };

Das Testprogramm (Durchführung)

 1:    my @bytes;
 2:    my $wget = WWW::Wget->new(
 3:        on_bytes => sub { push @bytes, $_[1] }
 4:    );

Das Testprogramm (Durchführung)

 1:    my @bytes;
 2:    my $wget = WWW::Wget->new(
 3:        on_bytes => sub { push @bytes, $_[1] }
 4:    );
 5:    isa_ok $wget, 'WWW::Wget';

Das Testprogramm (Durchführung)

 1:    my @bytes;
 2:    my $wget = WWW::Wget->new(
 3:        on_bytes => sub { push @bytes, $_[1] }
 4:    );
 5:    isa_ok $wget, 'WWW::Wget';
 6:    my $saved_as = $wget->get('test://url');

Das Testprogramm (Durchführung)

 1:    my @bytes;
 2:    my $wget = WWW::Wget->new(
 3:        on_bytes => sub { push @bytes, $_[1] }
 4:    );
 5:    isa_ok $wget, 'WWW::Wget';
 6:    my $saved_as = $wget->get('test://url');
 7:    cmp_ok $saved_as, "eq",
 8:        "162.18_..._whql.exe.2",
 9:        "Guessed the right save filename";

Das Testprogramm (Durchführung)

 1:    my @bytes;
 2:    my $wget = WWW::Wget->new(
 3:        on_bytes => sub { push @bytes, $_[1] }
 4:    );
 5:    isa_ok $wget, 'WWW::Wget';
 6:    my $saved_as = $wget->get('test://url');
 7:    cmp_ok $saved_as, "eq",
 8:        "162.18_..._whql.exe.2",
 9:        "Guessed the right save filename";
10:    is_deeply \@bytes, [384*1024, 786432,...,3932160,4325376,4718592],
11:        "The callbacks were called OK";

Das Testprogramm (Die Daten)

 1:    __DATA__
 2:    --16:04:14--  http://...tional_whql.exe
 3:               => `162.18_for...ql.exe.2'
 4:    Resolving de.download.nvidia.com... done.
 5:    Connecting to de...com[84.53.134.241]:80... connected.
 6:    HTTP request sent, awaiting response... 200 OK
 7:    Length: 71,609,184 [application/octet-stream]
 8:    
 9:        0K ................  0%  793.39 KB/s

Nochmal das Überschreiben

 1:    {
 2:        no warnings 'redefine';
 3:        *WWW::Wget::spawn = sub {
 4:            return \*DATA;
 5:        };
 6:    };

Ersetzen von anderen Subroutinen

 1:  sub greet { print "Hallo" };
 2:  sub output_greeting {
 3:      greet;
 4:      print $session->user;
 5:  }

Ersetzen von anderen Subroutinen

 1:  sub greet { print "Hallo" };
 2:  sub output_greeting {
 3:      greet;
 4:      print $session->user;
 5:  }
 6:  {
 7:      # Wir müssen HTML ausgeben
 8:      no warnings 'redefine';
 9:      local *greet = sub {
10:          print "<b>Hallo</b>";
11:      };
12:      output_greeting;
13:      # <b>Hallo</b> Max
14:  }

Ersetzen von anderen Subroutinen

 1:  sub greet { print "Hallo" };
 2:  sub output_greeting {
 3:      greet;
 4:      print $session->user;
 5:  }
 6:  {
 7:      # Wir müssen HTML ausgeben
 8:      no warnings 'redefine';
 9:      local *greet = sub {
10:          print "<b>Hallo</b>";
11:      };
12:      output_greeting;
13:      # <b>Hallo</b> Max
14:  }
15:  output_greeting;
16:  # Hallo Max

Atempause

  • Code Ersetzen ist praktisch

  • Kann verwirrend sein

  • "Monkeypatching" in fremden Modulen

  • local *foo = sub {...}

Installation

  • Installation ist mühsam

  • Installation aus cvs, svn etc.

  • Installation als OS-Packet (.deb, Windows Installer, ...)

  • Installation als .tar.gz Packet

Installation über CVS

 1:  cvs co pserver:...

  • cvs muss über Netzwerk erreichbar sein

  • Prerequisites werden nicht automatisch installiert

Installation als OS-Packet

  • Debian: Prerequisites werden automatisch mit installiert

  • Windows: Prerequisites werde nicht mit installiert

  • Perl ist mehr Cross-Platform als Debian

Installation als .tar.gz Packet

  • make dist

  • Ggf. Debian Package erstellen (make deb)

  • Datei kopieren

  • Datei auspacken

  • cpan .

  • Bei Bedarf auch Upload auf das CPAN (Module::Release, ShipIt)

Erstellen einer CPAN-installierbaren Distribution

Verzeichnislayout:

 1:  ./lib/App/Meine.pm
 2:  ./t
 3:  ./Makefile.PL
 4:  ./Changes

Erstellen eines Makefile.PL

  • Kopiert ein bestehendes Makefile.PL

  • Passt es an.

Erstellen eines Makefile.PL

 1:  use ExtUtils::MakeMaker;
 2:  WriteMakefile(
 3:    'NAME'    => 'App::RemoteDownload',
 4:    'VERSION_FROM'  => 'lib/App/RemoteDownload.pm', # finds $VERSION
 5:    'PREREQ_PM'    => {
 6:                       'parent' => 0.218,
 7:                       ...
 8:                      },
 9:    ($] >= 5.005 ?
10:      (ABSTRACT_FROM => 'lib/App/RemoteDownload.pm',
11:       AUTHOR     => 'Max Maischein <corion@cpan.org>') : ()),
12:  );

Distributionsprozeß

  • perl -w Makefile.PL

  • make dist

  • scp ./App-Meine-0.09.tar.gz mein.server.com:~/server/

  • ssh corion@mein.server.com

Distributionsprozeß

  • ssh corion@mein.server.com

  • cd server

  • tar xzf ./App-Meine-0.09.tar.gz

  • cd ./App-Meine-0.09

  • cpan .

Zusammenfassung

Was haben wir gesehen?

  • Referenzen und Speicherverwaltung von Perl

  • Closures

  • Erzeugen von Subroutinen/Methoden ohne eval

  • Dispatchtabellen (URL-Regex => Code)

  • Temporäres Ersetzen von Code mit anderem Code (Tests)

  • Distribution von Anwendungen mittels CPAN.pm

Danke

Fragen?

Bonus Level

Überwachung der Queue

  • Queue läuft

  • User haben Fragen

  • Schnell Abfragen erstellen

Querylet

 1:  #!/usr/bin/perl -w
 2:  use strict;
 3:  use Querylet;
 4:  
 5:  database: dbi:SQLite:dbname=r...d.sqlite
 6:  
 7:  # User mit der grössten Downloadmenge
 8:  query:
 9:    SELECT owner, count(*), sum(size)
10:    FROM     queue
11:    WHERE    pid is NULL
12:    GROUP BY owner
13:    ORDER BY sum(size)
14:  
15:  output format: html
16:  output file: statistik.html

Querylet (Ausgabe)

Statistik.html

Wie funktioniert Querylet

  • Querylet ist ein Source-Filter.

  • Source Filter sind gefährlich

  • Source Filter sind ungeheuer praktisch

Foto: pdcawley

Source Filter

Source Filter bearbeiten das gesamte Programm

 1:  package PerlSpeling;
 2:  use Filter::Simple;
 3:  
 4:  FILTER {
 5:      s/PERL/Perl/g;
 6:  };

Source Filter

Source Filter bearbeiten das gesamte Programm

 1:  #!/usr/bin/perl -w
 2:  use PerlSpeling;
 3:  print "Das ist PERL!";

Source Filter

Source Filter bearbeiten das gesamte Programm

 1:  #!/usr/bin/perl -w
 2:  use PerlSpeling;
 3:  print "Das ist PERL!";

Ausgabe:

 1:  Das ist Perl!

Source Filter

Source Filter bearbeiten das gesamte Programm

 1:  #!/usr/bin/perl -w
 2:  use PerlSpeling;
 3:  sub printPERL {
 4:      print "Das ist PERL!\n";
 5:      print ((caller(0))[3]); # eigener Name
 6:  };
 7:  printPERL;

Source Filter

Source Filter bearbeiten das gesamte Programm

 1:  #!/usr/bin/perl -w
 2:  use PerlSpeling;
 3:  sub printPERL {
 4:      print "Das ist PERL!\n";
 5:      print ((caller(0))[3]); # eigener Name
 6:  };
 7:  printPERL;

Das ist Perl!

printPerl

Verwenden von Filter::Simple

  • Suchen und Ersetzen ist schwierig

  • Fehlermeldungen sind kryptisch (//)

  • Unangenehme Seiteneffekte

  • Acme::Bleach

Warum filtern?

Warum trotzdem?

 1:  use Querylet;
 2:  
 3:  database: dbi:SQLite:dbname=jobqueue.db
 4:  
 5:  query:
 6:    SELECT user, count(*), sum(size)
 7:    FROM     jobs
 8:    WHERE    pid is NULL
 9:    GROUP BY user
10:  
11:  output format: html

Warum filtern?

Warum filtern?

  • Konfigurationsdatei -> Programm

  • Mächtigkeit von Perl

Anwendungen von Querylet

  • Ausgabe auf Konsole

  • Ausgabe in Datei

  • Ausgabe nach Excel

  • Ausgabe als SVG-Diagramm

  • Leicht in CGI wandelbar

Anwendungen von Source-Filtern

  • Sehr wenig

  • Nicht auf Perl-Code

  • POE (früher?)

  • ACME::Bleach

  • Querylet

Blick in AtExit

  • Locking

  • Freigabe von Locks

  • Temporäre Dateien

  • Resource Initialisation Is Acquisition

Blick in AtExit

  • Locking

  • Freigabe von Locks

  • Resource Initialisation Is Acquisition

 1:  if ($user->is_logged_in) {
 2:    my $tempfile = 
 3:      Lock->new(sub{unlink $tempfilename});
 4:    ...
 5:  };

Locking und Resourcenmanagement

  • Perl hat Resourcenmanagement

  • Scope

  • DESTROY

Aufruf von Code am Ende eines Blocks

 1:  package At::ScopeExit;
 2:  sub new {
 3:      my ($class,$atexit) = shift;
 4:      my $self = {
 5:          atexit => $atexit;
 6:      };
 7:      bless $self, $class
 8:  };

Aufruf von Code am Ende eines Blocks

 1:  package At::ScopeExit;
 2:  sub new {
 3:      my ($class,$atexit) = shift;
 4:      my $self = {
 5:          atexit => $atexit;
 6:      };
 7:      bless $self, $class
 8:  };
 9:  
10:  sub DESTROY {
11:      $_[0]->{atexit}->();
12:  };

Aufruf von Code am Ende eines Blocks

 1:  sub get_mail {
 2:      my $server 
 3:        = Net::POP3->login($user,$password);
 4:      my $quit
 5:        = At::ScopeExit->new( sub { $server->logout });
 6:      ...
 7:      print ">$outfile", $mail
 8:          or die "Couldn't write mail to '$outfile': $!";
 9:  }

Aufruf von Code am Ende eines Blocks

 1:  sub get_mail {
 2:      my $quit 
 3:        = At::ScopeExit->new( sub { print "logout" });
 4:      die "boom!";
 5:  }

Aufruf von Code am Ende eines Blocks

 1:  sub get_mail {
 2:      my $quit 
 3:        = At::ScopeExit->new( sub { print "logout" });
 4:      die "boom!";
 5:  }
 1:  boom! at beispiele\atexit_test.pl line 16.
 2:  logout

Abbrechen des Aufrufs?

 1:  sub get_mail {
 2:      my $server 
 3:        = Net::POP3->login($user,$password);
 4:      my $quit 
 5:        = At::ScopeExit->new( sub { $server->logout });
 6:      ...
 7:      
 8:      if ($server->unreachable) {
 9:          # $server->logout wird trotzdem aufgerufen
10:          return
11:      };
12:  }

Aufruf von Code am Ende eines Blocks

 1:  
 2:  
 3:  
 4:  
 5:  sub DESTROY {
 6:      $_[0]->{atexit}->()
 7:  
 8:  };

Aufruf von Code am Ende eines Blocks

 1:  sub cancel {
 2:      $_[0]->{canceled} = 1;
 3:  }
 4:  
 5:  sub DESTROY {
 6:      $_[0]->{atexit}->()
 7:          unless $_[0]->{canceled};
 8:  };

Abbrechen des Aufrufs?

 1:  sub get_mail {
 2:      my $server 
 3:        = Net::POP3->login($user,$password);
 4:      my $quit 
 5:        = At::ScopeExit->new( sub { $server->logout });
 6:      ...
 7:      
 8:      if ($server->unreachable) {
 9:          $quit->cancel();
10:          return
11:      };
12:  }

Abbrechen des Aufrufs?

 1:  sub get_mail {
 2:      my $server 
 3:        = Net::POP3->login($user,$password);
 4:      my $quit 
 5:        = At::ScopeExit->new( sub { $server->logout });
 6:      ...
 7:      
 8:      if ($server->unreachable) {
 9:          $quit->cancel();
10:          return
11:      };
12:  }
 1:  boom! at beispiele\atexit_test.pl line 16.

Module

  • AtExit

  • Hook::Scope

  • Perl::AtEndOfScope

  • Scope::Guard

  • Hook::LexWrap

  • Object::Destroyer

Danke

Fragen?