strict
constant
Carp
CPAN
CPANPLUS
CPANPLUS::Backend
perltidy
Safe
Opcode
Taint
Getopt::Long
Getopt::Std
AppConfig
Config::General
Pod::Usage
LWP::Simple
LWP
LWP::RobotUA
URI::Find
Net::Dict
HTTP::Daemon
IO::Socket
IO::Select
IO::File
IO::Pty
IPC::Open2
IPC::Open3
Expect
IPC::Shareable
Net::Shared
Parallel::ForkManager
Mail::Audit
Mail::SpamAssassin
Razor::*
Sendmail::Milter
PerlMx
File::Find
find2perl
File::Basename
File::Compare
File::Copy
File::Path
File::Spec
File::stat
File::Temp
Proc::ProcessTable
Digest::MD5
Digest::SHA1
List::Util
Data::Dumper
Storable
Memoize
Text::Wrap
Text::Autoformat
Text::Iconv;
utf8
Unicode::String
Unicode::Japanese
Text::Roman
Lingua::Stem
Text::xSV
Chatbot::Eliza
Bone::Easy
Parse::RecDescent
Parse::Yapp
XML::LibXML, XML::LibXSLT
XML::Parser
XML::SAX
XML::DOM
XML::Simple
XML::Writer
XML::Grove
XML::SimpleObject
XML::TreeBuilder
XML::Twig
XML::XPath
XML::XSLT
XML::TokeParser
XML::CSV
XML::Handler::AxPoint
SOAP::Lite
XML::RPC
Frontier::Client, Frontier::Daemon
Business::Associates
DBI
DBD::Chart
DBIx::Abstract, Ima::DBI, Class::DBI
DBIx::XHTML_Table
DBIx::XML_RDB
SPOPS
DBD::SQLite
DBD::CSV
Alzabo
Tangram
SQL::Catalog
DbFramework
DBIx::XMLMessage
HTML::Clean
CGI
CGI::Pretty
Data::FormValidator
Tk
Gtk
Glade
Wx
Qt
Prima
X11::*
Curses::UI
GD
GD::Graph
Image::Size
SVG
Image::Magick
Gimp
SDL
Date::Calc
Date::Manip
POSIX
HTML::Parser
HTML::LinkExtor
HTML::TreeBuilder
HTML::FormatText
Text::Reform
Text::WikiFormat
MIME
MIME::Tools
MIME::Parser, MIME::Entity (MIME::Tools)
Mail::Mailer
Mail::Send
Net::POP3, Net::IMAP::Simple
Internet::Mail
Net::Jabber
Net::AIM
flock
Inline
PDL
PDL (autres exemples)
Gimp et PDL (non testé)
GraphViz
MIDI::Simple
MIDI::Score
MP3::Info
Audio::Play::MPG123
Festival
WeakRef
Filter::Util::Call
Filter::Simple
Language::Pythonesque
Lingua::Romana::Perligata
Acme::Comment
Switch
Acme::Pony
Acme::Bleach
Inline::Brainfck
Time::HiRes
Devel::Dprof
Devel::SmallProf
Devel::Coverage
Benchmark
perlcc
O
B
B::Bytecode
Cwd
File::Spec
Statistics::Descriptive
Math::BigInt
Math::Pari
Finance::YahooQuote
Params::Validate
Error
Win32
Modules que je n'utilise pas (que je n'ai d'ailleurs jamais utilisés)
A FAIRE
Voici une liste de "quelques" modules Perl qui peuvent s'avérer utiles.
Tout programme en Perl devrait commencer par
#! perl -w
use strict;
use Carp ();
$SIG{__WARN__} = \&Carp::cluck;
$SIG{__DIE__} = \&Carp::confess;Cela demande à Perl d'être intransigeant sur la syntaxe du langage. Si cela semble une contrainte, c'est en fait une manière très simple de faire apparaître certains bugs. Les trois dernières lignes demandent que les messages d'erreur soient plus explicites, en donnant toute la pile des appels de fonctions.
Pour les CGI, c'est même
#! perl -Tw
Il est parfois nécessaire (localement) de se débarasser du -w ou du use strict.
no warnings; no strict;
Souvent, on peu être strict sur tout sauf sur certains points. Par exemple
no strict 'refs';
On peut définir des constantes (en fait, ce sont des fonctions constantes, mais on n'a pas à le savoir).
use constant TRUE => (0==0); use constant FALSE => (0==1);
Lorsque l'on débuggue un programme, l'utilisation de warn ou die pour signaler que quelque chose n'a pas marché est souvent trop laconique : si on est à l'intérieur d'une fonction, on ne sait pas à partir d'où elle a été invoqiée. Les commandes cluck et confess indiquent toute la pile des appels de fonction.
use Carp qw(:DEFAULT cluck); ... open(...) || confess "..."; ... ... || cluck "There may be a problem";
Ce module permet d'installer directement des modules, sans avoir à chercher où les télécharger ni comment les compiler.
En tapant
perl -MCPAN -e shell
on se retrouve avec un shell, auquel on peut dire
install Tk
A titre de comparaison, à la main, cela donnerait :
ncftp ftp.lip6.fr cd /pub/perl/CPAN/modules/by-category/ ls cd 08_User_Interfaces ls cd Tk ls get Tk800.023.tar.gz exit tar zxvf Tk800.023.tar.gz cd Tk/ perl Makefile.PL make make test make install
Et encore, ici, on a eu de la chance : ce module ne dépend pas d'autre module. CPAN s'en charge tout seul, mais à la main, ça peut être très long...
Néanmoins, cela ne marche que si les seules dépendances sont d'autres modules Perl. Si des programmes extérieurs ou des bibliothèques sont nécessaires, il faut les installer à la main (c'est par exemple le cas du module GraphViz).
Remplacement de CPAN (s'utilise exactement de la même manière).
Autre interface de CPANPLUS, pour son utilisation à l'intérieur des programmes (si on écrit des programmes qui installent automatiquement des modules...).
Ce n'est pas un module, mais un reformatteur de code, pour que l'on puisse lire le code mal indenté.
man perlstyle http://wwwinfo.cern.ch/dis/perl/tchrist/style/
Ce module permet de sécuriser la commande eval.
D'une part, le bloc sera isolé dans un espace de nommage, il n'aura pas accès aux variables et fonctions en dehors de celui-ci (sauf si on les autorise explicitement).
D'autre part, on peut limiter le nombre d'opérateurs autorisés lors de la compilation du code (uniquement lors de la compilation : si on autorise des fonctions définies ailleurs et donc déjà compilées, elles peuvent utiliser n'importe quoi).
(Les opérateurs, ou Opcodes, ce sont les instructions de la machine virtuelle de Perl -- Perl fonctionne en fait comme Java : le code Perl est compilé dans un pseudo-code, qui est interprété par une machine virtuelle.)
#! perl -w use strict; use Safe; my $jail = new Safe; $jail->permit(qw(:base_core)); print "Type in an arithmetic expression: "; my $unsafe_code = <>; my $result = $jail->reval($unsafe_code); print "$result\n";
Ce qui donne :
% perl 3.pl Type in an arithmetic expression: sin(3) 0.141120008059867 % perl 3.pl Type in an arithmetic expression: open(A, ">/etc/passwd") open trapped by operation mask at (eval 2) line 3, <> line 1.
À moins de comprendre vraiment ce que l'on fait, il ne faut pas croire que cela va résoudre tous les problèmes de sécurité (mais c'est quand même une chouche de sécurité supplémentaire).
It is important that you read the Opcode(3) module documentation for more information, especially for detailed definitions of opnames, optags and opsets.
Le module Safe est en fait une interface au module Opcode, qui permet d'interdire certains opcodes (un opcode, c'est une instruction pour l'interpréteur Perl, i.e., quelque chose qui se déroule après la compilation).
Attention, il y a deux modules différents qui portent ce nom (ils sont tous les deux sur CPAN) -- et, au moment où j'écris ces lignes, ils ont le même numéro de version. Préférer celui, plus récent (2002 contre 1997), de Dan Sugalski.
Ce module définit des fonctions "tainted" pour vérifier si une variable est sale et "taint" pour en salir une.
Pour ceux qui ne savent pas ce que sont des variables "sales", voir
perldoc perlsec
C'est un module qui regarde ce qu'il y a sur la ligne de commande (i.e., dans @ARGV), et y lit les diverses options du programme.
use Getopt::Long;
my $file;
my $debug=FALSE; # default value;
my @libs = ();
my %defines = ();
GetOptions ('file|fichier=s' => \$file,
'debug!' => \$debug,
'lib=s' => \@libs,
'define=s' => \%defines);
@libs = split(/,/,join(',',@libs));On peut appeler un tel programme de la manière suivante.
foo --nodebug --file foo --libs glib --libs xml,xslt --define foo=bar
Voir Getopt::Long.
Ce module rend à peu près les mêmes services que Getopt::Long, mais les options peuvent être prises à la fois sur la ligne de commande et dans un fichier de configuration.
Encore un module pour lire des fichiers de configurations. Le fichier de configuration peut être divisé en blocs, éventuellement avec des paramètres, exactement comme dans les fichiers de configuration d'Apache.
Lorsque l'on programme, il est préférable de mettre la documentation avec le programme, voire même dans le même fichier. En Perl, c'est possible dans le format POD (Plain Old Documentation).
#! perl -w
use strict
=head1 NAME
Essai - Cesi est un essai
=head1 SYNOPSIS
perl essai.pl arg1 arg2 ... argn
=head1 ARGUMENTS
...
=head1 DESCRIPTION
...
=head2 ...
...
=head2 ...
...
=head1 BUGS
None so far.
=head1 SEE ALSO
...
=head1 AUTHOR
...
=cut
print join(',', @ARGV);Pour plus de renseignement sur ce marquage, voir
man perlpod
Quand une ligne commence par un =, c'est le début de la documentation, et elle continue jusqu'au prochain =cut. La documentation peut bien sur etre entrecoupée de code, chaque morceau de documentation commencera par un = (si on n'a pas de commande par laquelle commencer ce bloc de documentation, on prendra =pod) et se terminera par un =cut.
Quand on veut mettre du code dans cette documentation (ie, des lignes qu'il ne faudra pas reformater), on les fait commencer par une tabulation. (C'est le cas dans la partie SYNOPSIS ci-dessus).
Il est possible de mettre des énumérations (le nombre 4 correspond à l'indentation).
=over 4 =item first item some text =item second item some more text =back
Il est possible de mettre du texte en I<italique>, en B<gras>, de mettre du C<code>, des X<mots> à indexer, d'indiquer que F<toto.txt> est un fichier.
Le module Pod::Usage permet d'afficher une partie de ce texte.
use Pod::Usage; pod2usage(-verbose => 0); pod2usage(-verbose => 2);
On peut l'utiliser avec Getopt::Long
use Getopt::Long;
use Pod::Usage;
my $help = 0;
GetOptions ('help' => \$help) || pod2usage(-verbose => 0);
pod2usage(-verbose => 2) if $help;
Pour récupérer simplement une page Web.
use LWP::Simple qw(get);
my $html = get("http://www.yahoo.co.jp/")
or die "Cannot fetch the URL\n";
Pour les situations où LWP::Simple ne suffit pas (par exemple, envoit d'un formulaire, contenant un fichier entier, avec des cookies et une autentification avec nom d'utilisateur et mot de passe), on peut utiliser directement LWP.
use HTTP::Request::Common; use LWP; our $ua = LWP::UserAgent->new; my $r = $ua->request(GET 'http://fr.finance.yahoo.com/'); die "HTTP problem" unless $r->is_success; my $s = $r->content;
Sans aucune vérification, cela ne prend qu'une ligne
use HTTP::Request::Common;
use LWP::UserAgent;
my $ua = LWP::UserAgent->new;
sub get_url { $ua->request(GET $_[0])->content }Mais il vaut mieux vérifier qu'il n'y a pas eu de problème
use HTTP::Request::Common;
use LWP::UserAgent;
my $ua = LWP::UserAgent->new;
sub get_url {
my $url = shift;
my $r = $ua->request(GET $url);
die "HTTP problem" unless $r->is_success;
return $r->content;
}Ca marche aussi pour des formulaires (ici, $file est le nom d'un fichier qui sera envoyé dans le formulaire).
# phpMyAdmin
my $ua = LWP::UserAgent->new;
my $answer = $ua->request(
POST 'http://sql.free.fr/phpMyAdmin/read_dump.php3',
Content_Type => 'form-data',
Content => [ server => "sql-z.free.fr",
db => $main::login,
goto => "db_details.php",
zero_rows => "Votre requête SQL a été exécutée avec succès",
sql_file => [$file],
],
)->as_string;;On peut aussi rajouter des mots de passe
package RequestAgent;
use LWP::UserAgent;
our @ISA = qw(LWP::UserAgent);
sub get_basic_credentials { return "zoonek", "xcvskjdfvsdf" }
package main;
my $ua = RequestAgent->new;
my $answer = $ua->request(...);On peut aussi utiliser de cookies
perldoc HTTP::Cookies
On commence par le mettre dans une boite à cookies (et on vérifie aussi qu'il sont bien là). On constate que la date d'expiration est en GMT.
use HTTP::Cookies; my $cookie_jar = HTTP::Cookies->new; $cookie_jar->set_cookie(1, l => 3, '/','zoonek2.free.fr',80,0,0,2592000); # 1 month print $cookie_jar->as_string;
Pour les utiliser, je préfère recourrir à HTTP::Request plutot qu'à HTTP::Request::Common (c'est plus long à écrire, mais je peux mettre des print partout pour voir où sont les éventuels problèmes)
#! perl -w
use strict;
use HTTP::Request;
use LWP;
use HTTP::Cookies;
my $cookie_jar = HTTP::Cookies->new;
$cookie_jar->set_cookie(1, l => 3, '/','localhost',5467,0,0,2592000); # 1 month
$cookie_jar->set_cookie(1,B=>'fi4tb64ts2j3d&b=2&f=a','/','.yahoo.com',80,0,0,2592000);
my $ua = LWP::UserAgent->new;
my $request = HTTP::Request->new(GET => 'http://www.fnac.fr/');
$cookie_jar->add_cookie_header($request);
print STDERR $request->as_string;
my $response = $ua->request($request);
unless ($response->is_success) {
print $response->error_as_HTML;
exit 1;
}
$cookie_jar->extract_cookies($response);
print STDERR $response->headers;
print STDERR "The cookies are now:\n";
print STDERR $cookie_jar->as_string;
#print $response->content;Les cookies sont stockés dans les fichiers suivants (respectivement pour mozilla, netscape, konqueror) :
~/.mozilla/*/*/cookies.txt ~/.netscape/cookies ~/.kde/share/apps/kcookiejar/cookies
Leur format est le suivant :
perl -n -e '
next if m/^\#/;
m/^([^\s]+)\s+([^\s]+)\s+([^\s]+)\s+([^\s]+)\s+([^\s]+)\s+([^\s]+)\s+([^\s]+)\s+/
&& print "HOST: $1 NAME: $6 VALUE: $7\n"
' ~/.mozilla/*/*/cookies.txtIl est possible de charger les cookies de netscape, en initialisant la boite à cookies ainsi :
my $cookie_jar = HTTP::Cookies::Netscape->new(
File => "$ENV{HOME}/.netscape/cookies",
AutoSave => 1,
);Quand j'écris des aspirateurs de pages Web, j'utilise donc (par exemple -- j'utilise aussi wget et larbin) :
package Aspi;
require Exporter;
use vars qw(@ISA @EXPORT);
@ISA = qw(Exporter);
@EXPORT = qw(&get);
use strict;
use HTTP::Request;
use LWP;
use HTTP::Cookies;
use vars qw($DEBUG);
# Lecture des cookies qui auront été préalablement sauvegardés par netscape
our $cookie_jar = HTTP::Cookies::Netscape->new(
File => "$ENV{HOME}/.netscape/cookies",
AutoSave => 1,
);
# Ajout de quelques cookies
$cookie_jar->set_cookie(1,foo=>1,'/','.foo.com',80,0,0,2592000);
sub get {
my $url = shift;
print STDERR "\n URL: $url\n\n";
my $ua = LWP::UserAgent->new;
my $request = HTTP::Request->new(GET => $url);
$cookie_jar->add_cookie_header($request);
print STDERR "\n" if $DEBUG;
print STDERR $request->as_string if $DEBUG;
my $response = $ua->request($request);
unless ($response->is_success) {
print STDERR "ERROR\n" . $response->error_as_HTML if $DEBUG;
return "";
}
$cookie_jar->extract_cookies($response);
print STDERR $response->headers->as_string if $DEBUG;
print STDERR $response->content if $DEBUG;
return $response->content;
}(pour les cookies de mozilla, ça ne marche pas)
http://www.perl.com/pub/a/2002/08/20/perlandlwp.html
Normalement, on est sensé écrire des robots polis, i.e., qui respectent les règles contenues dans le fichier robots.txt. Le module LWP::RobotUA, descendant de LWP::UserAgent, peut s'en charger pour nous.
Ce module permet de repérer les URLs (et autres URIs) dans un texte (un texte normal, pas du HTML : pour cela voir HTML::LinkExtor).
#! perl -w
use strict;
use URI::Find;
while(my $line=<>){
find_uris($line,
sub {
my($uri, $orig_uri) = @_;
print "The text '$orig_uri' represents '$uri'\n";
return $orig_uri;
});
}Le résultat pourait être :
The text 'www.foo.bar' represents 'http://www.foo.bar/' The text 'www.yahoo.com' represents 'http://www.yahoo.com/'
Voici un script qui met tous les URIs dans une liste.
#! perl -w
use strict;
use URI::Find;
my @uri = ();
while(my $line=<>){
find_uris($line,
sub {
my($uri, $orig_uri) = @_;
push @uri, $uri;
return $orig_uri;
});
}
print join("\n", @uri) ,"\n";Toujours pris dans la page de manuel, un script qui remplace les URI par des liens (par exemple, lorsqu'on écrit un programme pour convertir du texte en HTML -- le document que vous lisez n'a pas été écrit en HTML).
#! perl -w
use strict;
use URI::Find;
while(my $line=<>){
find_uris($line,
sub {
my($uri, $orig_uri) = @_;
return qq|<a href="$uri">$orig_uri</a>|;
});
print $line;
}
Pour accéder aux dictionnaires qui se trouvent, par exemple, sur dict.org (il s'agit d'un protocole, un peu comme HTTP, pour interroger des dictionnaires).
#! perl -w
use strict;
use Net::Dict;
use Data::Dumper;
die "usage $0 word" unless $ARGV[0];
print Dumper( Net::Dict->new('dict.org')->define($ARGV[0]) );Voici la définition du mot "thane".
$VAR1 = [
[
'web1913',
'Thane \\Thane\\ (th[=a]n), n. [OE. thein, [thorn]ein, AS.
[thorn]egen, [thorn]egn; akin to OHG. degan a follower,
warrior, boy, MHG. degen a hero, G. degen hero, soldier,
Icel. [thorn]egn a thane, a freeman; probably akin to Gr.
te`knon a child, ti`ktein to bear, beget, or perhaps to Goth.
[thorn]ius servant, AS. [thorn]e[\'o]w, G. dienen to serve.]
A dignitary under the Anglo-Saxons and Danes in England. Of
these there were two orders, the king\'s thanes, who attended
the kings in their courts and held lands immediately of them,
and the ordinary thanes, who were lords of manors and who had
particular jurisdiction within their limits. After the
Conquest, this title was disused, and baron took its place.
Note: Among the ancient Scots, thane was a title of honor,
which seems gradually to have declined in its
significance. --Jamieson.
'
],
[
'wn',
'thane
n 1: a feudal lord or baron in Scotland
2: a man ranking above an ordinary freeman and below a noble in
Anglo Saxon England especially one who gave military serve
in exchange for land
'
]
];
On peut écrire un serveur Web en quelques lignes...
#! perl -w
use strict;
use HTTP::Daemon;
use HTTP::Status;
my $d = HTTP::Daemon->new || die;
print "Please contact me at: <URL:", $d->url, ">\n";
while (my $c = $d->accept) {
while (my $r = $c->get_request) {
if ($r->method eq 'GET' and $r->url->path eq "/xyzzy") {
# remember, this is *not* recommened practice :-)
# $c->send_file_response("/etc/passwd");
$c->send_file_response("/etc/timezone");
} else {
$c->send_error(RC_FORBIDDEN)
}
}
$c->close;
undef($c);
}
On peut faire une connection HTTP « à la main ».
#! perl -w
use strict;
use IO::Socket;
my $host = 'www.yahoo.fr';
my $port = 80;
my $remote = new IO::Socket::INET( PeerAddr => $host,
PeerPort => $port,
Proto => 'tcp',
);
die "Could not create socket: $!\n" unless $remote;
print $remote "GET / HTTP/1.0\n\n";
print while <$remote>;ou encore :
use IO::Socket;
$handle = IO::Socket::INET->new('www.perl.com:80')
|| die "can't connect to port 80 on www.perl.com: $!";
$handle->autoflush(1);
if (fork()) { # XXX: undef means failure
select($handle);
print while <STDIN>; # everything from stdin to socket
} else {
print while <$handle>; # everything from socket to stdout
}
close $handle;
exit;On peut aussi faire le contraire, et écrire soi-même un démon (a priori, pas un démon HTTP : on lui fait faire ce que l'on veut, on est libre d'inventer et d'implémenter son propre protocole).
#! perl -w
use strict;
use IO::Socket;
my $localport = 5467;
my $daemon = new IO::Socket::INET ( LocalPort => $localport,
Proto => 'tcp',
Listen => 1,
);
die "Could not create socket: $!\n" unless $daemon;
sub exit_cleanly { close $daemon }
$SIG{INT} = $SIG{TERM} = $SIG{KILL} = \&exit_cleanly;
print STDERR "Listening\n";
while( my $listen = $daemon->accept() ){
print "\nNEW REQUEST from ". $listen->peerhost() ."\n";
print while <$listen>;
close $listen;
}
close $daemon;Voici par exemple un proxy, qui affiche aussi les en-têtes des connections (pour voir tous les cookies, toutes les redirections...) Contrairement à un proxy classique, il ne traite qu'une connection à la fois (les connections suivantes sont mises en attente).
#! perl -w
use strict;
use IO::Socket;
use constant TRUE => (0==0);
use constant FALSE => (0==1);
# On lance le démon
my $localport = 5467;
my $daemon = new IO::Socket::INET ( LocalPort => $localport,
Proto => 'tcp',
Listen => 50,
);
die "Could not create socket: $!\n" unless $daemon;
# On quitte proprement
# (sinon, il faut plusieures dizaines de secondes
# pour que le noyau s'apperçoive qu'il n'y a plus
# de processus qui écoute derrière ce port et qu'il
# est donc ànouveau utilisable).
sub exit_cleanly { print STDERR "catched\n"; close $daemon }
$SIG{INT} = $SIG{TERM} = $SIG{KILL} = \&exit_cleanly;
# La connection vers l'extérieur
my $host;
my $port;
my $remote;
# On écoute, connection après connection
print STDERR "Listening\n";
while( my $local = $daemon->accept() ){
# On traite une requète à la fois
print "\nNEW REQUEST\n";
my $todo = "";
while(my $line = <$local>){
print $line;
if( $line =~ s|^GET\s+http://.*?(/.*)(HTTP/.*)|GET $1 $2| ){
print $line;
}
$todo .= $line;
if( $line =~ m/^Host:\s+(.*)/ ){
$host = $1;
$host =~ s/\s+//gsm;
if( $host =~ m/(.*):([0-9]*)/ ){
$port = $2;
$host = $1;
} else {
$port = 80;
}
print "CONNECTING TO `$host' on port `$port'\n";
$remote = new IO::Socket::INET( PeerAddr => $host,
PeerPort => $port,
Proto => 'tcp',
);
die "Could not create socket: $!\n" unless $remote;
}
if( $remote ){
print $remote $todo;
last if $line =~ m/^\s*$/sm;
$todo = "";
}
}
# Maintenant, on écoute sur $remote et on écrit sur $local
print "HERE IS THE FILE\n";
my $print = TRUE;
while(<$remote>){
print $_ if $print;
$print = FALSE if m/^\s*$/;
print $local $_;
}
close $remote;
close $local;
undef $port;
undef $host;
undef $remote;
print "\nListening\n";
}
close $daemon;Il est peut-être pertinent de rajouter les paramètres suivants au constructeur (sinon, il se passe un certain temps avant que l'on puisse relancer un démon sur le même port), en particulier lors du débugguage.
ReuseAddr => 1, ReusePort => 1,
On peut utiliser ce module pour recevoir plusieures connections en même temps.
#! perl -w
use strict;
use IO::Socket;
use IO::Select;
my $localport = 5467;
my $daemon = new IO::Socket::INET ( LocalPort => $localport,
Proto => 'tcp',
Listen => 100,
);
die "Could not create socket: $!\n" unless $daemon;
sub exit_cleanly { close $daemon }
$SIG{INT} = $SIG{TERM} = $SIG{KILL} = \&exit_cleanly;
print STDERR "Listening\n";
my $select = IO::Select->new();
$select->add( $daemon );
while(1){
foreach my $h ($select->can_read()){
if( $h == $daemon ){
my $new = $h->accept;
print "New connection from ". $new->peerhost ."\n";
$select->add( $new );
} else {
my $msg = <$h>;
if( defined $msg ){
print $h->peerhost .": ". $msg;
} else {
print "Closing connection from ". $h->peerhost ."\n";
close $h;
$select->remove($h);
}
}
}
}On pourrait améliorer notre proxy (ci-dessus) pour qu'il accepte plusieures connections simultanées.
(exercice laissé au lecteur)
Ce module fournit une interface orientée objet aux descripteurs de fichiers.
Il permet aussi de manipuler exactement de la même manière une socket et un fichier (car dans les deux cas, on se retrouve avec des objets de type (dérivé de) IO::Handle).
Ça n'est peut-être pas très utile directement, mais si on écrit (ou si on utilise) une bibliothèque, cela permet de passer facilement et proprement un descripteur de fichier ouvert en argument.
Permet de considérer un scalaire (i.e., une chaine de caractères) comme un fichier, dans lequel on peut lire ou écrire.
Idem.
Voir IO::Lines.
Idem, avec un pipe.
A peu près comme IO::Select (qui permet d'attendre que quelque chose arrive sur une socket), mais pour les fichiers.
Crée un pseudo-terminal (i.e., quelque chose qui se comporte comme un terminal utilisé par un utilisateur, mais qui n'est est pas un et est utilisé par un programme). Voir Expect.
Il arrive que l'on veuille lancer un processus et dialoguer avec lui, en écrivant sur son entrée standard et en lisant sa sortie standard. La fonction Open ne le permet pas ; le module IPC::Open3 y remédie.
Voici un exemple (avec chasen, programme qui découpe les phrases japonaises en mots).
#! perl -w
use strict;
use IPC::Open2;
use Text::Iconv;
my $to_utf = Text::Iconv->new("EUC-JP", "UTF-8");
my $to_euc = Text::Iconv->new("UTF-8", "EUC-JP");
while(my $line_utf = <>){
my $line_euc = $to_euc->convert($line_utf);
my($rdrfh, $wtrfh);
my $pid = open2($rdrfh, $wtrfh, 'chasen', '-F%M %H'."\n")
|| die "Cannot run chasen: $!";
print $wtrfh $line_euc;
close $wtrfh;
while(my $word_euc = <$rdrfh>){
my $word_utf = $to_utf->convert($word_euc);
next if $word_utf =~ m/^EOS/;
my ($word, $part_of_speech) = split(/\s+/, $word_utf);
next if $part_of_speech =~ m/(jodoushi|kigou|michigo)/;
print "/$word";
}
close $rdrfh;
print "/:". $line_utf ."\n";
}Voir aussi IPC::Open3 et Expect.
Comme IPC::Open2, mais on peut aussi lire la sortie d'erreur.
Au début des années 90, expect était un programme qui permettait de dialoguer automatiquement avec des applications interactives (en mode texte, bien sûr), à l'aide du langage de programmation Tcl (qui, je l'espère, est maintenant devenu obsolète).
Le module Expect fait la même chose, mais en Perl. C'est très proche de IPC::Open2, mais Expect fait croire au programme qu'il s'agit réellement d'un terminal, avec un utilisateur humain devant (on peut donc l'utiliser, par exemple, pour tester un programme qui doit se comporter différemment s'il est appelé depuis un terminal).
Pour permettre à plusieurs processus (différents forks d'un même processus initial) de partager des variables. C'est utilisé en particulier par mod_perl, ou de manière générale par des serveurs, qui doivent se forker pour pouvoir traiter plusieures requètes simultanément, mais qui veulent avoir des variables « globales » accessibles et modifiables immédiatement (si on n'a pas besoin en permanence de ces variables, ou si elles sont très grosses et qu'on n'a besoin que d'une petite partie, on peut les mettre dans une base de données).
Remplacement de IPC::Shareable, qui fonctionne aussi avec des processus sur des machines différentes. (Je préfère quand même les bases de données pour ce genre de chose.)
On a parfois besoin de lancer quelques centaines ou quelques milliers de processus en même temps, mais ça n'est pas réaliste car la machine risque de saturer. Pour y remédier, il suffit de ne lancer que quelques dizaines de processus en même temps, en en lançant un nouveau dès que l'un d'entre eux se termine. J'utilise ce genre de chose pour paralléliser l'aspirateur de pages Web wget, par exemple pour récupérer des fontes, des images de fond d'écran, etc.
#! perl -w
use strict;
my $MAX_PROCESSES = shift || 10;
use Parallel::ForkManager;
my $pm = new Parallel::ForkManager($MAX_PROCESSES);
while(<>){
my $pid = $pm->start and next;
system($_);
$pm->finish; # Terminates the child process
}
Module pour écrire des filtres de courrier électronique, i.e., pour écrire des programmes que l'on appellera depuis le ~/.forward et qui vont remplacer procmail (car la syntaxe de procmail, avec toutes ses fonctions dont le nom ne comporte qu'un seul caractère, est assez peu compréhensible).
Voici un exemple :
http://www.perl.com/pub/a/2001/07/17/mailfiltering.html
Voici ce que j'utilise :
#!/share/nfs/users1/umr-tge/zoonek/gnu/Linux/bin/perl -w
use strict;
use Mail::Audit;
sub mess {
my $mess = shift;
open(A, '>>', "/share/nfs/users1/umr-tge/zoonek/log");
print A "$mess\n";
close A;
}
mess("begin");
my $mail = Mail::Audit->new(emergency=>"~/Mail/emergency_mbox");
$mail->noexit(1);
$mail->accept("~/Mail/backup");
$mail->noexit(0);
# Mailing lists
my %lists = qw(
omega-admin Omega
pstricks-admin pstricks
owner-ctan-ann CTAN-Announce
owner-maple-list maple
);
foreach my $a (keys %lists){
# PROBLEME: il faudrait une méthode "sender"
$mail->accept("~/Mail/$lists{$a}.spool")
if $mail->header =~ m/^Sender:.*$a/m;
}
mess(" not a mailing list");
# Important mails that should be _copied_ in a folder
my %important = qw( paypal Argent
florachanxxx Argent
ebay Argent
amazon Argent
jamall Argent
bk1 Argent
);
$mail->noexit(1);
foreach my $a (keys %important) {
$mail->accept("~/Mail/$important{$a}.spool")
if $mail->from =~ m/$a/i
or $mail->to =~ m/$a/i;
}
$mail->noexit(0);
mess(" perhaps not something important");
# Poubelle
my @poubelle = qw/glegrand@ccr.jussieu.fr/;
foreach my $a (@poubelle) {
$mail->accept("~/Mail/poubelle")
if $mail->from =~ m/$a/;
}
my $body = join('', @{ $mail->body });
$mail->accept("~/Mail/poubelle")
if $body =~ m/armée|militaire/;
mess(" It dit not go into the trash can");
## Probablement du spam
# Reconnu par son sujet
$mail->accept("~/Mail/spam.spool")
if $mail->subject =~ m/\b(congratulation|breast|money|mortgage|viagra|sex|cigar)s?\b/i;
$mail->accept("~/Mail/spam.spool")
if $mail->subject =~ m/\$\s*[0-9,]{3,}/;
# Reconnu par son absence de destinataire
$mail->accept("~/Mail/spam.spool")
unless $mail->to =~ m/(zoonek|jussieu)/
or $mail->from =~ m/(zoonek|jussieu)/
or $mail->cc =~ m/(zoonek|jussieu)/;
mess(" no spam");
## Probablement quelque chose de correct
#$mail->accept();
$mail->noexit(1);
$mail->accept("~/Mail/zoonek");
$mail->noexit(0);
# This should be the very last line
mess(" accepting");
$mail->accept();
mess("accepted -- you should NOT be reading this");Voici les détails :
http://www.math.jussieu.fr/~zoonek/UNIX/43_filtrage/Mail%3A%3AFilter.html
Un module de reconnaissance de Spam, que l'on peut utiliser avec Mail::Audit.
SpamAsassin va faire subir différents tests au messages, pour déterminer si c'est du Spam ou pas. Chaque test contribue au « niveau de spam » du message et si un seuil est atteint, le message est déclaré comme tel (exactement comme les quarts, huitièmes et seizième de preuve dans la justice du moyen-âge).
Néanmoins, je constate qu'il ne repère pas le spam que je reçois (???). Pour faire des tests, on peut utiliser l'exécutable spamassassin, qui ajoute des champs à l'en-tête du message, indiquant ce qu'il a fait.
X-Spam-Status: No, hits=0.0 required=5.0 tests= version=2.20 X-Spam-Level:
En Perl, dans un script Mail::Audit, on l'utiliserait comme suit.
#! perl -w
use strict;
use Mail::Audit;
use Mail::SpamAssassin;
my $mail = new Mail::Audit;
my $spam_test = new Mail::SpamAssassin;
# ...
my $status = $spam_test->check($mail);
if( $status->is_spam ){
$status->rewrite_mail();
$mail->accept("~/Mail/spam.spool");
} else {
$mail->accept("~/Mail/non_spam.spool");
}
Interface à Vipul's Razor, un détecteur de spam (qui utilise la signature SHA1 des messages reconnus comme du spam).
Ces modules ne se trouvent pas sur CPAN (?), mais ici :
http://razor.sourceforge.net/
Ces modules, s'ils sont présents, sont utilisés par Mail::SpamAssassin (qui lui-même s'utilise depuis Mail::Audit).
Une interface à milter (l'API de Sendmail qui permet de filtrer le courrier à l'aide de programmes externes à Sendmail). Si on veut que le filtrage s'effectue en amont, directement dans le MTA (à ce niveau, on va quand-même éviter d'effacer les messages, on va se contenter de les marquer, en rajoutant un morceau dans l'en-tête).
Voir un article du Perl Journal :
http://www.sysadminmag.com/documents/sam0207l/
Une autre interface à milter (l'API de Sendmail qui permet de filtrer le courrier à l'aide de programmes externes à Sendmail).
http://www.perl.com/pub/a/2001/10/10/perlmx.html
Module pour chercher des fichiers, exactement comme avec la commande UNIX find.
#! perl -w
use strict;
use File::Find;
sub wanted {
printf "%10d %s\n", (lstat($_))[7],
$File::Find::name;
}
File::Find::find(\&wanted, '.');Pour des exemples plus compliqués voir le résultat de la commande find2perl.
On dit souvent que la commande unix pour avoir la liste des fichiers dans le répertoire courrant et dans tous ses répertoires est ls -l. Il y a pourtant beaucoup plus simple et plus lisible.
find -ls
La commande find2perl prend les mêmes arguments que la commande find, mais au lieu d'effectuer la recherche, elle renvoit un programme perl capable d'effectuer cette recherche. (Attention : le -print est facultatif pour la commande find du gnu, mais pas pour find2perl...)
Par exemple, imaginons que nous ne sachions pas comment trouver tous les fichiers dont la taille est inférieure à 10ko à l'aide de la commande find (on peut, mais la page de manuel est loin d'être limpide). On sait par contre trouver les fichiers dont la taille est exactement 10ko.
find . -size 10k -print
On lance donc
find2perl -size 10k -print
Le résultat utilise File::Find.
#! /share/nfs/users1/umr-tge/zoonek/gnu/Linux/bin/perl -w
eval 'exec /share/nfs/users1/umr-tge/zoonek/gnu/Linux/bin/perl -S $0 ${1+"$@"}'
if 0; #$running_under_some_shell
use strict;
use File::Find ();
# Set the variable $File::Find::dont_use_nlink if you're using AFS,
# since AFS cheats.
# for the convenience of &wanted calls, including -eval statements:
use vars qw/*name *dir *prune/;
*name = *File::Find::name;
*dir = *File::Find::dir;
*prune = *File::Find::prune;
# Traverse desired filesystems
File::Find::find({wanted => \&wanted}, '.');
exit;
sub wanted {
my ($dev,$ino,$mode,$nlink,$uid,$gid);
(($dev,$ino,$mode,$nlink,$uid,$gid) = lstat($_)) &&
(int(((-s _) + 1023) / 1024) == 10) &&
print("$name\n");
}On peut dès lors modifier ce programme pour qu'il fasse ce que l'on veut.
find2perl -size 10k -print | perl -p -e 's/==/>=/g' | perl
Pour des exemples plus compliqués, on peut regarder le résultat de find2perl -ls
#! /share/nfs/users1/umr-tge/zoonek/gnu/Linux/bin/perl -w
eval 'exec /share/nfs/users1/umr-tge/zoonek/gnu/Linux/bin/perl -S $0 ${1+"$@"}'
if 0; #$running_under_some_shell
use strict;
use File::Find ();
# Set the variable $File::Find::dont_use_nlink if you're using AFS,
# since AFS cheats.
# for the convenience of &wanted calls, including -eval statements:
use vars qw/*name *dir *prune/;
*name = *File::Find::name;
*dir = *File::Find::dir;
*prune = *File::Find::prune;
my @rwx = qw(--- --x -w- -wx r-- r-x rw- rwx);
my @moname = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
my (%uid, %user);
while (my ($name, $pw, $uid) = getpwent) {
$user{$uid} = $name unless exists $user{$uid};
}
my (%gid, %group);
while (my ($name, $pw, $gid) = getgrent) {
$group{$gid} = $name unless exists $group{$gid};
}
# Traverse desired filesystems
File::Find::find({wanted => \&wanted}, '.');
exit;
sub wanted {
my ($dev,$ino,$mode,$nlink,$uid,$gid);
(($dev,$ino,$mode,$nlink,$uid,$gid) = lstat($_)) &&
&ls;
}
sub sizemm {
my $rdev = shift;
sprintf("%3d, %3d", ($rdev >> 8) & 0xff, $rdev & 0xff);
}
sub ls {
my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
$atime,$mtime,$ctime,$blksize,$blocks) = lstat(_);
my $pname = $name;
$blocks
or $blocks = int(($size + 1023) / 1024);
my $perms = $rwx[$mode & 7];
$mode >>= 3;
$perms = $rwx[$mode & 7] . $perms;
$mode >>= 3;
$perms = $rwx[$mode & 7] . $perms;
substr($perms, 2, 1) =~ tr/-x/Ss/ if -u _;
substr($perms, 5, 1) =~ tr/-x/Ss/ if -g _;
substr($perms, 8, 1) =~ tr/-x/Tt/ if -k _;
if (-f _) { $perms = '-' . $perms; }
elsif (-d _) { $perms = 'd' . $perms; }
elsif (-l _) { $perms = 'l' . $perms; $pname .= ' -> ' . readlink($_); }
elsif (-c _) { $perms = 'c' . $perms; $size = sizemm($rdev); }
elsif (-b _) { $perms = 'b' . $perms; $size = sizemm($rdev); }
elsif (-p _) { $perms = 'p' . $perms; }
elsif (-S _) { $perms = 's' . $perms; }
else { $perms = '?' . $perms; }
my $user = $user{$uid} || $uid;
my $group = $group{$gid} || $gid;
my ($sec,$min,$hour,$mday,$mon,$timeyear) = localtime($mtime);
if (-M _ > 365.25 / 2) {
$timeyear += 1900;
} else {
$timeyear = sprintf("%02d:%02d", $hour, $min);
}
printf "%5lu %4ld %-10s %3d %-8s %-8s %8s %s %2d %5s %s\n",
$ino,
$blocks,
$perms,
$nlink,
$user,
$group,
$size,
$moname[$mon],
$mday,
$timeyear,
$pname;
1;
}
Ce module définit des fonctions dirname et basename pour décomposer un nom de fichier (ça peut sembler inutile, mais ça permet d'écrire des programmes portables, qui fonctionnent aussi sous OuinDaube).
Compare des fichiers, comme avec la commande diff.
Définit des fonctions copy et move, pour copier et déplacer des fichiers (pour le déplacement, on se contente de renommer le fichier, comme avec la fonction rename, si c'est possible -- si les fichiers sont sur des systèmes de fichiers différents, ce n'est pas possible et il faut faire une copie).
Comme mkdir -p
Pour construire des noms de fichiers portables, avec / \ ou : comme séparateur selon le système d'exploitation.
use File::Spec;
$x = File::Spec->catfile('a', 'b', 'c');
La fonction stat (qui, rappelons-le, permet d'avoir des informations sur un fichier : taille, type, date de dernière modification, droits d'accès, etc.) renvoie une liste, et accéder à ses élements par leur numéro n'est pas très lisible. Ce module permet d'utiliser des appels de méthode, beaucoup plus explicites.
use File::stat; # C'est bien un s minuscule my $st = stat($file) or die "No $file: $!"; ... $st->dev $st->ino $st->mode $st->nlink $st->uid $st->gid $st->rdev $st->size $st->atime $st->mtime $st->ctime $st->blksize $st->blocks
Pour créer des fichiers temporaires (on en construit généralement à l'aide du nom du programme et du numéro du processus, ce qui suffit si le système de fichier n'est visible que par une seule machine, mais si le répertoire est exporté par NFS, ça peut poser des problèmes).
use File::Temp qw/ tempfile tempdir /;
Un fichier temporaire (dans le répertoire courrant) :
$fh = tempfile();
Un fichier temporaire dont le nom a une certaine forme :
$template = '/tmp/temp.XXXX'; ($fh, $filename) = tempfile($template);
Un fichier temporaire avec une extension donnée :
($fh, $filename) = tempfile( $template, SUFFIX => '.dat');
Un fichier temporaire dans un répertoire temporaire :
$dir = tempdir( CLEANUP => 1 ); ($fh, $filename) = tempfile( DIR => $dir );
Permet d'accéder à la table des processus (sur une machine UNIX).
#! perl -w
use strict;
use Proc::ProcessTable;
my $p = new Proc::ProcessTable( 'cache_ttys' => 1 );
my @fields = $p->fields;
my $ref = $p->table;
foreach my $a (@$ref) {
print "Processus\n";
foreach my $b (@fields) {
print " $b: $a->{$b}\n" if defined $a->{$b}
}
}
Ce module permet de calculer une somme de contrôle.
Par exemple, le script suivant repère des fichiers potentiellement identiques, même s'ils ont des noms différents.
#! perl -w
use strict;
use File::Find;
use Digest::MD5 qw(md5_base64);
use vars qw(%check);
undef $/;
sub wanted {
lstat($_) || return;
-f _ || return;
open(F, '<', $File::Find::name) || return;
my $md5 = md5_base64(<F>);
if( exists $check{$md5} ){
print "diff $File::Find::name $check{$md5}\n";
} else {
$check{$md5} = $File::Find::name;
}
}
find(\&wanted, '.');Attention, l'algorithme MD5 n'a pas une très bonne réputation :
MD5 has a well known weakness which was discovered and published by Hans Dobbertin in 1996.
Voir Digest::SHA1.
Calcule une somme de contrôle, comme Digest::MD5, mais avec l'algorithme SHA-1 (considéré comme plus fiable que MD5).
J'ai souvent besoin de mettre un tableau dans le desordre. On peut procéder ainsi.
perldoc -q shuffle
Ce qui nous répond :
How do I shuffle an array randomly?
Use this:
# fisher_yates_shuffle( \@array ) :
# generate a random permutation of @array in place
sub fisher_yates_shuffle {
my $array = shift;
my $i;
for ($i = @$array; --$i; ) {
my $j = int rand ($i+1);
next if $i == $j;
@$array[$i,$j] = @$array[$j,$i];
}
}
fisher_yates_shuffle( \@array ); # permutes @array in placeMais il y a déjà un module qui fait cela
use List::Util qw(first max maxstr min minstr reduce shuffle sum); @cards = shuffle 0..51 # 0..51 in a random order
Lorsque l'on débuggue un programme, on a parfois besoin d'afficher la valeur de certaines variables assez complexes.
#! perl -w
use Data::Dumper;
$Data::Dumper::Terse = 1;
my $foo = [ [1,2,3, ["aa", { 1=>"sdkg", 17=>"sdkgsd" } ] ] ];
print Dumper($foo);Ce qui donne :
$VAR1 = [
[
1,
2,
3,
[
'aa',
{
'1' => 'sdkg',
'17' => 'sdkgsd'
}
]
]
];On peut lui demander d'afficher ne nom de la variable :
print Data::Dumper->Dump([$foo],[qw(foo)]);
Ce qui donne :
$foo = [
[
1,
2,
3,
[
'aa',
{
'1' => 'sdkg',
'17' => 'sdkgsd'
}
]
]
];Ca marche aussi avec des structures récursives (qui font référence à elles-mêmes)
@c = ('c');
$c = \@c;
$b = {};
$a = [1, $b, $c];
$b->{a} = $a;
$b->{b} = $a->[1];
$b->{c} = $a->[2];
print Data::Dumper->Dump([$a,$b,$c], [qw(a b c)]);Ce qui donne :
$a = [
1,
{
'a' => $a,
'b' => $a->[1],
'c' => [
'c'
]
},
$a->[1]{'c'}
];
$b = $a->[1];
$c = $a->[1]{'c'};
Quand on manipule des structures de données complexes et longues à calculer, on peut vouloir les stocker sur le disque
use Storable; store \%a, "foo.storable";
pour les réutiliser plus tard.
use Storable;
%a = %{ retrieve("foo.storable") } if -r "foo.storable";Ce module contient aussi une fonction pour copier des structures de données profondes.
use Storable qw(dclone); $r2 = dclone($r1);
Ce module permet de se souvenir du résultat de certaines fonctions (exactement comme avec l'option remember, sous Maple, très utilisée pour programmer récursivement des algorithmes qui ne sont pas du tout récursifs, comme par exemple, le calcul « par récurrence » des coefficients binômiaux).
#! perl -w
use strict;
use Benchmark;
use Memoize;
sub binom {
my($n, $k) = @_;
if( $k == 0 or $k == $n ){
return 1;
} elsif( $k<0 or $k>$n or $n<0 ) {
return 0;
} else {
return binom($n-1, $k) + binom($n-1, $k-1);
}
}
for( my $n=0; $n<6; $n++ ) {
for( my $k=0; $k<=$n; $k++ ){
print binom($n, $k) . " ";
}
print "\n";
}
timethis(1, sub { binom(40,5) });
memoize('binom');
timethis(1, sub { binom(40,5) });Voici le résultat.
1
1 1
1 2 1
1 3 3 1
1 4 6 4 1
1 5 10 10 5 1
timethis 1: 3 wallclock secs
( 3.68 usr + 0.01 sys = 3.69 CPU) @ 0.27/s (n=1)
(warning: too few iterations for a reliable count)
timethis 1: 0 wallclock secs
( 0.01 usr + 0.00 sys = 0.01 CPU) @ 100.00/s (n=1)
(warning: too few iterations for a reliable count)
Ajoute (ou retire) des retours-chariot dans un texte.
#! perl -w
use strict;
use Text::Wrap;
$Text::Wrap::columns = 72;
my @text = ("Bla bla bla",
"Bla bla bla",
"Bla bla bla",
"Bla bla bla",
"Bla bla bla",
"Bla bla bla",
"Bla bla bla",
"Bla bla bla",
"Bla bla bla",
"Bla " . "bla "x100 . "bla.",
);
# Le premier argument est l'indentation de la
# première ligne du paragraphe, le second celle
# des lignes suivantes.
my @lines = wrap(" ", "", @text);
print join("\n", @lines);Voir aussi Text::Autoformat.
Ajoute (ou retire) des retours-chariot dans un texte, de manière intelligente (par exemple, il sait reconnaitre une citation dans un courrier électronique, contrairement à Text::Wrap).
$formatted = autoformat $rawtext,
{ left=>1, right=>72 };
Accès à la bibliothèque iconv, permettant de passer d'un codage à un autre (c'est ce qu'utilise recode).
#! perl -w
use strict
use Text::Iconv;
use vars qw($c);
$c = Text::Iconv->new("EUC-JP", "UTF-8");
print $c->convert($_) while(<>);
Unicode est un jeu de caractères, qui contient tous les caractères utilisés par les langues vivantes. Certains caractères ont été unifiés, en particulier les caractères japonais et chinois qui ont la même origine, même s'ils diffèrent d'un ou deux traits (dans ces langues, se tromper sur ces traits constitue une "faute d'orthographe", mais cela n'a pas géné les concepteurs d'Unicode).
UTF-8 est l'un des codages possibles d'Unicode. D'autres codages sont UCS-2 (mais les chaines en UCS2 peuvent contenir des octets nuls, ce qui gène certains langages de programmation archaïques, comme le C) ou UTF-7 (qui n'utilise jamais le huitième bit, mais avec lequel une erreur de transmission affectera plusieurs caractères et pas un seul comme pour UTF-8).
A l'heure où j'écris ces lignes Unicode n'est pas encore vraiment supporté par Perl.
Dans perl 5.6, on peut dire que des morceaux de code sont en UTF8, à l'aide de « use utf8 ». C'est expérimental, et quand j'ai essayé, je me suis toujours retrouvé avec du Mojibake (i.e., des caractères corrompus). De plus, c'est expérimental, et ça va changer dans Perl 5.8.
Dans Perl 5.7 (bientôt 5.8), on peut dire que certains descripteurs de fichiers sont en UTF-8.
binmode(STDOUT, ":utf8"); binmode(STDERR, ":utf8"); open FH, ">:ucs2", "file" open FH, ">:utf8", "file"; open FH, ">:Shift-JIS", "file"; perldoc Encode
Pour plus de détails, voir
perldoc perluniintro
Mais ça n'est pas encore très stable : il faut s'attendre à ce que ses programmes se terminent par des SIGSEGV, sans rien pouvoir y faire...
En attendant, le seul moyen de manipuler de l'Unicode, c'est de considérer une chaine en UTF8 comme une suite d'octets, et non pas une suite de caractères. Cela interdit en particulier beaucoup d'expressions régulières (car . désigne un octet et pas un caractère : on risquerait de couper les caractères en deux...). On peut convertir une source en UTF8 à l'aide du module Unicode::MapUTF8. On peut faire des manipulations simples sur les chaines UTF8 (substr, length) à l'aide du module Unicode::String.
module pour manipuler les chaines de caractères Unicode tant que Perl ne sait pas le faire (avant Perl 5.8).
use Unicode::String qw(utf8 latin1); ... my $first = utf8($current_reading); $first = $first->substr(0,1); $first = $first->utf8;
Un autre module pour manipuler du japonais. Il y a par exemple la conversion Hiragana/Katakana.
Pour écrire (ou lire) des chiffres romains.
Permet de trouver le radical des mots anglais (par exemple, si on veut indexer des textes).
Permet de lire des fichiers au format CSV (Comma Separated Values), i.e., de la forme
Date,Open,High,Low,Close,Volume 17-Jun-02,28.50,30.74,24.45,24.45,5736467 10-Jun-02,30.88,31.80,26.10,27.88,7208123 3-Jun-02,33.15,34.30,28.63,29.76,2743253
(mais le séparateur peut être autre chose qu'une virgule). Il est préférable de ne pas utiliser directement la commande split, car les champs peuvent contenir des point-virgules ou des retour chariots (avec des \ ou des ").
#! perl -w
use strict;
use Text::xSV;
my $csv = new Text::xSV;
$csv->open_file("table.csv");
$csv->bind_header();
while ($csv->get_row()) {
my ($date, $close) = $csv->extract(qw(Date Close));
print "On $date, this share costed $close.\n";
}S'il n'y a pas de première ligne avec le titre des colonnes, on définit ces titres à l'aide de la commande bind_fields.
#! perl -w
use strict;
use Text::xSV;
my $csv = new Text::xSV;
$csv->open_file("table.csv");
$csv->bind_fields(0..5);
while ($csv->get_row()) {
my ($date, $close) = $csv->extract(0,4);
print "On $date, this share costed $close.\n";
}(Il y a aussi un module Text::CSV, mais il a l'air très vieux et ne tient pas compte de la présence possible de retour-chariot dans les champs)
On a parfois besoin de texte aléatoire (généralement à des fins de test, par exemple pour programmer des bots IRC ou d'autres démons, ou pour répondre automatiquement à du spam) : on peut alors utiliser ce psychanaliste. Il se contente de "répondre" (en posant des questions)
perl -MChatbot::Eliza -e 'Chatbot::Eliza->new->command_interface'
Idem, dans un programme :
#! perl -wl
use strict;
use Chatbot::Eliza;
my $chatbot = new Chatbot::Eliza;
while( my $user = <> ){
print $chatbot->transform($user);
}
Générateur d'insultes (si on a besoin de texte aléatoire...).
Ce module permet d'écrire très rapidement des parseurs. A priori, le parseur obtenu n'est pas très rapide : il n'est pas obtenu en convertissant la grammaire en automate fini déterministe, comme dans tout compilateur qui se respecte, mais il examine les règles les unes après les autres, jusqu'à ce que ça marche. Néanmoins, pour des fichiers raisonnables, c'est parfaitement utilisable. Le résultat est néanmoins suffisemment rapide.
Ecrivons par exemple un programme qui lise des fichiers BibTeX. Un fichier BibTeX contient des données bibliographiques, sous la forme suivante.
@string{ SV = {Springer Verlag}}
@string{ AW = "Addison Wesley"}
@Book{SGA1,
author = {A. Grothendieck},
title = {Revêtements étales et groupe fondamental},
publisher = SV,
year = 1971,
key = {SGA (Séminaire de géométrie algébrique)},
citekey = {SGA},
numero = 1,
series = {LNM},
volume = {224}
}
@InProceedings{KS,
author = {G.M. Kelly and R. Street},
title = {Review of the elements of $2$-categories},
booktitle = {Category seminar},
pages = {75--103},
year = {1974},
volume = {420},
series = {LNM},
publisher = SV
}
@Article{ivanov,
author = {N.V. Ivanov},
title = {Complexes of curves and the {Teichmüller} modular group},
journal = {Russian math. surveys},
year = 1987,
volume = 42,
pages = {55--107}
}
@InCollection{oda,
author = {T. Oda},
title = {Étale homotopy type of the moduli space of algebraic curves},
crossref = {GGA1},
pages = {85--95},
annote = {On montre que $(\M_{g,n}\tens_\ZZ\bar\QQ)_{\text{ét}} \equiv K(\Gamma_{g,n},1)^\wedge$.}
}
@Proceedings{GGA1,
title = {Geometric {Galois} Actions},
year = 1997,
editor = {L. Schneps and P. Lochak},
volume = 242,
series = {LMSLNS},
publisher = CUP
}
@InCollection{ihara:EGT,
author = {Y. Ihara},
title = {On the embedding of $\gal(\bar\QQ:\QQ)$ into $\wh{GT}$},
crossref = {GTDE},
pages = {289--305}
}Voici une grammaire décrivant ce genre de fichier. Quand on écrit une grammaire, on utilise souvent les caractères « * » et « + » pour indiquer que l'on veut l'élément précédent un nombre quelconque de fois (éventuellement num) ou au moins une fois. Il faut remplacer ces caractères par « (s?) » et « (s) ». La barre verticale indique des alternatives. On ne tient pas compte des espaces (il faudrait ajouter <skip: ''> là où on voudrait en tenir compte). Le /\z/ indique la fin du fichier ou de la chaine.
#! perl -w
use strict;
use Parse::RecDescent;
$::RD_ERRORS = 1; # Make sure the parser dies when it encounters an error
$::RD_WARN = 1; # Enable warnings. This will warn on unused rules &c.
$::RD_HINT = 1; # Give out hints to help fix problems.
$::RD_AUTOACTION = q { print "$item[0]: ". join(', ', @item[1..$#item])."\n"; };
my $grammar = q¤
startrule: bibtex_record(s?) /\z/
bibtex_record: bibtex_string | bibtex_entry
bibtex_string: "@" "string" "{" key "=" value "}"
bibtex_entry: "@" key "{" label key_value_pair(s) "}"
key: /[a-zA-Z]+/
label: /[a-zA-Z0-9_:-]+/
key_value_pair: "," key "=" value
value: value_between_curly_brackets | value_between_double_quotes
value_between_curly_brackets: "{" nested(s) "}"
nested: text_inside_curly_brackets value_between_curly_brackets(?)
value_between_double_quotes: '"' text_inside_double_quotes '"'
text_inside_double_quotes: /([^"\\\]|\\.)*/
text_inside_curly_brackets: /([^\{\}\\\]|\\\.)*/
¤;
my $parser = Parse::RecDescent->new($grammar);
sub check {
print "\n$_[0]\n";
if( $parser->startrule($_[0]) ){
print "OK\n";
} else {
print "NO\n";
}
}
check('@string{ foo = {bar} }');
check('@string{ foo = "bar" }');
check('@string{ foo = {bar\{} }');
check('@book{A, author = {foo bar}, title = {aaa bbb}}');
check('@string{foo={bar}}@book{A,author={foo bar},title={aaa bbb}}');
check('@InCollection{oda,annote={On montre que $(\M_{g,n}\tens_\ZZ\bar\QQ)_{\text{ét}} \equiv K(\Gamma_{g,n},1)^\wedge$.}}');Il faut maintenant associer des actions à chaque règle. (Attention, chaque action doit renvoyer une valeur non nulle, sinon on considère que la règle a échoué.)
#! perl -w
use strict;
use Parse::RecDescent;
$::RD_ERRORS = 1; # Make sure the parser dies when it encounters an error
$::RD_WARN = 1; # Enable warnings. This will warn on unused rules &c.
$::RD_HINT = 1; # Give out hints to help fix problems.
$::RD_AUTOACTION = q { 2 };
my $grammar = q¤
startrule: bibtex_record(s?) /\z/
{ 1 }
bibtex_record: bibtex_string {1} | bibtex_entry {1}
bibtex_string: "@" "string" "{" key "=" value "}"
{ print "STRING: $item[4] = $item[6]\n"; }
bibtex_entry: "@" key "{" label key_value_pair(s) "}"
{
print "ENTRY: $item[4] of type $item[2]\n";
foreach my $kv (@{$item[5]}){
print " $kv->[0] = $kv->[1]\n";
}
}
key: /[a-zA-Z]+/
{ $item[1] }
label: /[a-zA-Z0-9_:-]+/
{ $item[1] }
key_value_pair: "," key "=" value
{ [ $item[2], $item[4] ] }
value: value_between_curly_brackets { $item[1] } | value_between_double_quotes { $item[1] }
value_between_curly_brackets: "{" nested(s) "}"
{ join('', @{$item[2]}) }
nested: text_inside_curly_brackets value_between_curly_brackets(?)
{ $item[1].( scalar @{$item[2]} >0 ? "\{".join('',@{$item[2]})."\}" : "") }
value_between_double_quotes: '"' text_inside_double_quotes '"'
{ $item[2] }
text_inside_double_quotes: /([^"\\\]|\\.)*/
{ $item[1] }
text_inside_curly_brackets: /([^\{\}\\\]|\\\.)*/
{ $item[1] }
¤;
my $parser = Parse::RecDescent->new($grammar);
sub check {
print "\n$_[0]\n";
if( $parser->startrule($_[0]) ){
print "OK\n";
} else {
print "NO\n";
}
}
check('@string{ foo = {bar} }');
check('@string{ foo = "bar" }');
check('@string{ foo = {bar\{} }');
check('@book{A, author = {foo bar}, title = {aaa bbb}}');
check('@string{foo={bar}}@book{A,author={foo bar},title={aaa bbb}}');
check('@InCollection{oda,annote={On montre que $(\M_{g,n}\tens_\ZZ\bar\QQ)_{\text{ét}} \equiv K(\Gamma_{g,n},1)^\wedge$.}}');On peut maintenant mettre les données lues dans une table de hachage.
#! perl -w
use strict;
use Parse::RecDescent;
$::RD_ERRORS = 1; # Make sure the parser dies when it encounters an error
$::RD_WARN = 1; # Enable warnings. This will warn on unused rules &c.
$::RD_HINT = 1; # Give out hints to help fix problems.
use vars qw(%result %string);
my $grammar = q¤
startrule: bibtex_record(s?) /\z/
{ 1 }
bibtex_record: bibtex_string {1} | bibtex_entry {1}
bibtex_string: "@" "string" "{" key "=" value "}"
{ $main::string{$item[4]} = $item[6] }
bibtex_entry: "@" key "{" label key_value_pair(s) "}"
{
$main::result{$item[4]} = { type => $item[2] };
foreach my $kv (@{$item[5]}){
$main::result{$item[4]}->{$kv->[0]} = $kv->[1];
}
}
key: /[a-zA-Z]+/
{ $item[1] }
label: /[a-zA-Z0-9_:\/-]+/
{ $item[1] }
key_value_pair: "," key "=" value
{ [ $item[2], $item[4] ] }
value: value_between_curly_brackets { $item[1] }
| value_between_double_quotes { $item[1] }
| label { $item[1] }
value_between_curly_brackets: "{" nested(s) "}"
{ join('', @{$item[2]}) }
nested: text_inside_curly_brackets value_between_curly_brackets(?)
{ $item[1].( scalar @{$item[2]} >0 ? "\{".join('',@{$item[2]})."\}" : "") }
value_between_double_quotes: '"' text_inside_double_quotes '"'
{ $item[2] }
text_inside_double_quotes: /([^"\\\]|\\.)*/
{ $item[1] }
text_inside_curly_brackets: /([^\{\}\\\]|\\\.)*/
{ $item[1] }
¤;
my $parser = Parse::RecDescent->new($grammar);
sub check {
print "\n$_[0]\n";
if( $parser->startrule($_[0]) ){
print "OK\n";
} else {
print "NO\n";
}
}
check("foo");
open(BIB,"<","these.bib") || die "Cannot open these.bib: $!";
undef $/;
check(<BIB>);
close BIB;
print "Strings (". (scalar (keys %string)) .")\n";
foreach my $s (keys %string){
print " $s: $string{$s}\n";
}
print "\nResults (". (scalar (keys %result)) .")\n";
foreach my $l (keys %result){
print "\n $l:\n";
foreach my $k (keys %{$result{$l}}){
print " $k: $result{$l}->{$k}\n";
}
}Exercice laissé au lecteur : en faire un module. (J'en profite pour signaler qu'il existe déjà un module Text::BibTeX, mais il est pour l'instant indiqué comme « FAIL i686-linux »...)
Autre exercice laissé au lecteur : modifier la grammaire pour qu'elle accepte qu'il y ait une virgule à la fin, comme dans :
@Proceedings{GGA1,
title = {Geometric {Galois} Actions},
year = 1997,
editor = {L. Schneps and P. Lochak},
volume = 242,
series = {LMSLNS},
publisher = CUP,
}Autre exercice, toujours laissé au lecteur : tenir compte d'éventuels commentaires (tout ce qu'il y a entre % et la fin de la ligne).
Il y a des choses que je ne comprends pas : d'après lui, aucune des chaines suivantes n'est conforme à la grammaire.
#! perl -w
use strict;
use Parse::RecDescent;
$::RD_ERRORS = 1; # Make sure the parser dies when it encounters an error
$::RD_WARN = 1; # Enable warnings. This will warn on unused rules &c.
$::RD_HINT = 1; # Give out hints to help fix problems.
$::RD_AUTOACTION = q { print "$item[0]: ". join(', ',@item[1..$#item])."\n"; };
my $grammar = q¤
startrule: "a" b(s) "a"
b: "a"
¤;
my $parser = Parse::RecDescent->new($grammar);
sub check {
print "\n$_[0]\n";
if( $parser->startrule($_[0]) ){
print "OK\n";
} else {
print "NO\n";
}
}
check('a');
check('aa');
check('aaa');
check('aaaa');
check('aaaaa');Par contre, si on met
startrule: "a" b(s) "a" b: "b"
Ca marche comme on s'y attend.
Un autre module pour écrire des parseurs (comme yacc, mais en Perl).
Interface aux bibliothèques libxml, libxslt de Gnome, probablement plus rapide que les autres modules pour manipuler du XML.
Le script suivant applique une feuille de style à un document XML.
#! perl -w use strict; use XML::LibXSLT; use XML::LibXML; die "usage $0 foo.xslt foo.xml" unless scalar @ARGV == 2; my $parser = XML::LibXML->new(); #$parser->expand_entities(0); my $xslt = XML::LibXSLT->new(); my $source = $parser->parse_file($ARGV[1]); my $style_doc = $parser->parse_file($ARGV[0]); my $stylesheet = $xslt->parse_stylesheet($style_doc); my $results = $stylesheet->transform($source); print $stylesheet->output_string($results);
Un programme utilisant DOM ressemblerait à
#! perl -w
use strict;
use XML::LibXML;
my $parser = new XML::DOM::Parser;
my $doc = $parser->parsefile ($ARGV[0]);
my $root = $doc->getDocumentElement;
foreach my $entry (@{ $root->getElementsByTagName("entry") }) {
my @keb = map { $_->getElementsByTagName("keb")
->[0]
->getFirstChild
->getData
} (@$keb);
my $r_ele = $entry->getElementsByTagName("r_ele");
foreach my $r (@$r_ele) {
my $current_reading = $r->getElementsByTagName("reb")->[0]
->getFirstChild->getData;
...
}
...
}Voici un exemple plus conséquent :
http://www.math.jussieu.fr/~zoonek/LaTeX/Dictionnaire_japonais/documentation.html
Il est aussi possible d'utiliser DOM pour modifier ou créer des documents XML. On commence par créer des éléments
my $el1 = $doc->createElement('foo');
my $el2 = $doc->createTextNode("Hello world!");Ensuite, on les ajoute où on veut
$doc->getDocumentElement->appendChild($el1); $el1->appendChild($el2);
Et on peut ensuite modifier leurs attributs
$el1->setAttribute(bar => 1);
Voir plutôt XML::SAX.
Pour plus de renseignements sur XML, voir :
http://www.xml.com/pub/q/perlxml
et en particulier, pour les différents modules
http://www.xml.com/pub/a/2001/04/18/perlxmlqstart1.html http://www.xml.com/pub/a/2001/05/16/perlxml.html http://www.xml.com/pub/a/2001/06/13/perlxml.html
SAX est l'un des trois standards qui visent à manipuler des fichiers XML (avec DOM et XSLT). Son principe est très simple : on lui dit ce qu'il faut faire quand il rencontre une balise ouvrante, une balise fermante, et aussi ce qu'il faut faire du texte entre deux balises. C'est tout.
Ce premier exemple se contente d'indenter le fichier XML. (Je suppose ici qu'aucun des espaces avant ou après une balise n'a d'importance. C'est rarement le cas.)
#! perl -w
use strict;
$|++;
use XML::Parser::PerlSAX;
use vars qw($indent $text $spaces);
$indent=0;
$text="";
$spaces=" ";
sub print_text {
$text =~ s/^\s*//gsm;
$text =~ s/\s*$//gsm;
print $spaces x $indent . $text ."\n"
unless $text eq "";
$text = "";
}
sub handle_start {
my ($self, $el) = @_;
print_text;
print $spaces x $indent . "<$el>\n";
$indent++;
}
sub handle_end {
my ($self, $el) = @_;
print_text;
$indent--;
print $spaces x $indent . "</" . $el .">\n";
}
sub handle_char {
my ($self, $el) = @_;
$text .= $el;
}
my $parser = new XML::Parser(Handlers => {Start => \&handle_start,
End => \&handle_end,
Char => \&handle_char});
$parser->parsefile("essai.xml");Mais en fait, on a oublié les éventuels paramètres. On peut les rajouter ainsi.
sub handle_start {
my ($self, $el, @attr) = @_;
print_text;
my $attr="";
if( @attr ){
for(my $i=0; $i<scalar @attr; $i++){
$attr .= " " . $attr[$i++] .'="'. $attr[$i] .'"';
}
}
print $spaces x $indent . "<$el$attr>\n";
$indent++;
}Voici un exemple plus long (ce que j'utilise pour convertir du XML en HTML).
#!/share/nfs/users1/umr-tge/zoonek/gnu/Linux/bin/perl -w
# xml2html.pl
# Version 0.05
# (c) 2001 Vincent Zoonekynd <zoonek@math.jussieu.fr>
# Distributed under the GPL
use strict;
our @toc;
our $result="";
package TOCHandler;
use strict;
use constant TRUE => (0==0);
use constant FALSE => (0==1);
my $remember = FALSE;
my $string;
my $section_number = 0;
my $subsection_number = 0;
sub new { my $type = shift; return bless {}, $type; }
sub characters {
my ($self,$a) = @_;
my $b = $a->{Data};
$string .= $b;
}
sub start_element {
my ($self, $el) = @_;
if($el->{Name} eq "h1"){
$remember = TRUE;
$string = "";
}
}
sub end_element {
my($self, $el) = @_;
if($el->{Name} eq "h1") {
$remember = FALSE;
$section_number++;
push @toc, [$section_number, $string];
$string = "";
}
}
######################################################################
package MyHandler;
use strict;
sub new { my $type = shift; return bless {}, $type; }
## Constantes
use constant TRUE => (0==0);
use constant FALSE => (0==1);
## Variables globales
our $save_text = FALSE;
our $saved_text;
our $inside_p = 0;
our $section_number=0;
our $charset = "iso-8859-1" || "UTF-8" || "ISO-2022-JP";
our $bgcolor = '#FFFFFF';
our $text = '#000000';
our $alink = '#FFFFFF';
our $link = '#6D8ADA';
our $vlink = '#415383';
our $title_bgcolor = '#ffdb43';
our $title_fgcolor = $text;
our $section_bgcolor = '#6D8ADA';
our $section_fgcolor = '#FFFFFF';
our $code_bgcolor = '#FFFFAA';
our $code_fgcolor = $text;
our $tailer_fgcolor = '#c8c8c8';
our $author = "Vincent Zoonekynd";
our $web = "http://www.math.jussieu.fr/~zoonek/";
our $mail = 'zoonek@math.jussieu.fr';
our $title;
our $imagetitle;
our $date;
our $keywords;
## Affichage (ou sauvegarde) du texte
sub affiche {
my $a = shift;
if($save_text){ $saved_text .= $a }
else{ $result .= $a }
}
sub debug { my $a = shift; affiche "<!-- $a -->"; }
sub characters {
my ($self,$a) = @_;
my $b = $a->{Data};
$b =~ s/\&/\&\;/g;
$b =~ s/\</\<\;/g;
print STDERR "DEBUG: $b\n" if $b =~ m/URL|http/;
$b =~ s#([^\s>]*)|((http|https|ftp|file)://[^\s\">]+)#<A HREF="$1$2">$1$2</A>#g;
affiche $b;
}
sub start_p {
debug "paragraph start";
if( $inside_p == 0 ){
affiche "<center><table width=\"95\%\"><tr><td>";
} else {
affiche "<table width=\"100\%\"><tr><td>";
}
$inside_p++;
# print STDERR "<P> $inside_p\n";
}
sub end_p {
debug "paragraph end";
if( $inside_p == 1 ){
affiche "</td></tr></table></center>\n";
} else {
affiche "</td></tr></table>\n";
}
$inside_p--;
print STDERR "<P> $inside_p\n";
}
sub start_element {
my ($self, $el) = @_;
if($el->{Name} eq "web"){
} elsif($el->{Name} eq "head"){
} elsif($el->{Name} eq "title"){
$save_text = TRUE;
$saved_text = "";
} elsif($el->{Name} eq "date"){
$save_text = TRUE;
$saved_text = "";
} elsif($el->{Name} eq "keywords"){
$save_text = TRUE;
$saved_text = "";
} elsif($el->{Name} eq "imagetitle"){
$imagetitle = $el->{Attributes}->{src};
} elsif($el->{Name} eq "h1"){
$section_number++;
$subsection_number=0;
affiche "\n<!-- Section $section_number -->\n";
affiche "<p></p><table width=\"100\%\" cellpadding=\"2\" cellspacing=\"3\" border=\"0\">\n";
affiche "<tr><td bgcolor=\"$section_bgcolor\"><font color=\"$section_fgcolor\" face=\"Arial,Helvetica\"><A name=\"$section_number\"></A>";
# affiche "$section_number. ";
} elsif($el->{Name} eq "h2"){
$subsection_number++;
affiche "\n<!-- Subsection $section_number.$subsection_number -->\n";
affiche "<p></p><p><b><A name=\"$section_number.$subsection_number\"></A>";
} elsif($el->{Name} eq "a"){
affiche("<a href=\"$el->{Attributes}->{href}\">");
} elsif($el->{Name} eq "p"){
debug "paragraph";
start_p;
} elsif($el->{Name} eq "table"){
debug "table";
start_p;
affiche "<table cellpadding=0 cellspacing=0 border=0>\n";
affiche "<tr><td bgcolor=\"$text\"><table cellpadding=3 cellspacing=1 border=0>";
debug "table body";
} elsif($el->{Name} eq "tr"){
affiche('<tr>');
} elsif($el->{Name} eq "td"){
affiche "<td bgcolor=\"$bgcolor\">";
} elsif($el->{Name} eq "ul"){
debug "unnumbered list";
start_p;
affiche('<ul>');
} elsif($el->{Name} eq "li"){
affiche('<li>');
} elsif($el->{Name} eq "img"){
debug "image";
start_p;
my $alt = $el->{Attributes}->{alt} || "*";
affiche("<center><IMG SRC=\"$el->{Attributes}->{src}\" ALT=\"$alt\"></center>");
end_p;
} elsif($el->{Name} eq "code"){
debug "code";
start_p;
affiche "<table width=\"100\%\"><tr><td bgcolor=\"$code_bgcolor\"><font color=\"$code_fgcolor\"><pre>";
} elsif($el->{Name} eq "em"){
affiche('<em>');
} elsif($el->{Name} eq "tt"){
affiche('<tt>');
} elsif($el->{Name} eq "toc"){
start_p;
affiche '<center>';
foreach(@toc){
my ($n, $t) = @$_;
affiche '<A HREF="#'. $n .'">'. $t .'</A><br>';
}
affiche '</center>';
end_p;
}
}
sub end_element {
my $self=shift;
my $el=shift;
if($el->{Name} eq "web"){
start_p;
affiche "<p align =\"RIGHT\">";
affiche "<font color=\"$tailer_fgcolor\">";
affiche "<a href=\"$web\" style=\"text-decoration: none\">$author</a><br>\n";
affiche "<a href=\"mailto:$mail\" style=\"text-decoration: none\">\<$mail></a><br>\n";
affiche "$date<br>\n" if $date;
affiche "latest modification on ". `date`;
affiche "</font></p>\n";
end_p;
affiche "</body></html>";
} elsif($el->{Name} eq "head"){
affiche "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01 Transitional//EN\"\n";
affiche "\"http://www.w3.org/TR/html4/loose.dtd\">\n";
affiche "<!-- This is a generated file -->\n";
affiche "<html>\n";
affiche " <head>\n";
affiche " <title>$title</title>\n";
affiche " <meta http-equiv=\"Content-Style-Type\" content=\"text/css\">";
affiche " <meta http-equiv=\"Content-Type\" content=\"text/html; charset=$charset\">\n";
affiche " <meta NAME=\"keywords\" CONTENT=\"$keywords\">" if $keywords;
affiche " </head>\n\n";
affiche " <body bgcolor=\"$bgcolor\" text=\"$text\" link=\"$link\" alink=\"$alink\" vlink=\"$vlink\">\n";
affiche "\n<!-- title -->\n";
affiche "<center>\n";
if( defined $imagetitle ){
affiche "<img src=\"$imagetitle\" alt=\"$title\">\n";
} else {
affiche " <table cellpadding=\"10\">\n";
affiche " <tr><td bgcolor=\"$title_bgcolor\">";
affiche "<font color=\"$title_fgcolor\" face=\"Arial,Helvetica\">$title</font></td></tr>\n";
affiche " </table>\n";1
}
affiche "</center><p></p>";
} elsif($el->{Name} eq "title"){
$save_text = FALSE;
$title = $saved_text;
} elsif($el->{Name} eq "date"){
$save_text = FALSE;
$date = $saved_text;
} elsif($el->{Name} eq "keywords"){
$save_text = FALSE;
$keywords = $saved_text;
} elsif($el->{Name} eq "imagetitle"){
} elsif($el->{Name} eq "h1"){
affiche "</font></td></tr></table>\n";
} elsif($el->{Name} eq "h2"){
affiche "</b></p>\n";
} elsif($el->{Name} eq "a"){
affiche("</a>");
} elsif($el->{Name} eq "p"){
end_p;
debug "paragraph end";
} elsif($el->{Name} eq "table"){
debug "table body end";
affiche('</table></td></tr></table>');
end_p;
debug "table end";
} elsif($el->{Name} eq "tr"){
affiche('</tr>');
} elsif($el->{Name} eq "td"){
affiche('</td>');
} elsif($el->{Name} eq "ul"){
affiche('</ul>');
end_p;
debug "unnumbered list end";
} elsif($el->{Name} eq "li"){
affiche('</li>');
} elsif($el->{Name} eq "img"){
} elsif($el->{Name} eq "code"){
affiche('</pre></font></td></tr></table>');
end_p;
debug "code end";
} elsif($el->{Name} eq "em"){
affiche('</em>');
} elsif($el->{Name} eq "tt"){
affiche('</tt>');
}
}
######################################################################
package main;
use strict;
our $xml = join('',<>);
use XML::Parser::PerlSAX;
import MyHandler;
my $toc_handler = TOCHandler->new;
my $toc_parser = XML::Parser::PerlSAX->new( Handler => $toc_handler );
$toc_parser->parse( Source => { String => $xml } );
my $my_handler = MyHandler->new;
my $parser = XML::Parser::PerlSAX->new( Handler => $my_handler );
$parser = XML::Parser::PerlSAX->new( Handler => $my_handler );
$parser->parse( Source => { String => $xml } );
######################################################################
## Correction du codage
{
open(A, '>', 'tmp.html') || die "Cannot open tmp.html for writing: $!";
print A $result;
close A;
system "recode UTF-8..latin1 <tmp.html >tmp2.html"
|| die "Problem with recode: $!";
open(A, '<', "tmp2.html");
$result = join('',<A>);
close A;
# unlink "tmp.html";
# unlink "tmp2.html";
}
######################################################################
## Ajout de la taille des images
{
my $new = "";
while( $result =~ s/^(.*?)SRC\=\"([^"]*)\"//si ){ #"
my $avant = $1;
my $file = $2;
print STDERR "Looking for the size of $file\n";
open(SIZE, "convert -verbose $file /dev/null|") ||
warn "Cannot run `file $file /dev/null': $!";
# warn "Cannot run `convert -verbose $file /dev/null': $!";
my $tmp = join('',<SIZE>);
close SIZE;
my($width,$height)=(320,256);
if($tmp =~ m/([0-9]+)x([0-9]+)/){
$width = $1;
$height = $2;
}
print STDERR " width: $width height: $height\n";
$new .= "$avant WIDTH=$width HEIGHT=$height SRC=\"$file\" ";
}
$new .= $result;
$result = $new;
}
######################################################################
## On essaye d'enlever les espaces avant </pre>
$result =~ s|\s+</pre>|</pre>|gi;
######################################################################
print $result;
Remplacement de XML::Parser.
perldoc XML::SAX:Intro
DOM est un autre standard permettant de manipuler des fichiers XML. Il permet de considérer le fichier XML comme une arborescence, et on dispose de diverses fonctions pour aller au noeud père, au premier noeud fils ou au noeud frere suivant.
Voir plutôt XML::LibXML
(Il ne s'agit pas d'un standard.)
Comme un fichier XML peut se représenter par une arborescence, on peut le mettre dans une structure de donnée arborescente : une table de hachage (contenant d'autres tables de hachages ou des listes, qui elles-mêmes, etc.)
C'est aussi utile si on veut écrire un fichier XML : il suffit de créer une table de hachage contenant les données à écrire.
Si on manipule des fichiers XML dont la structure est relativement simple, c'est probablement le meilleur choix, car il s'intègre très bien aux habitudes de programmation sous Perl (on manipule des structures de données auxquelles on est habitué : tables de hachage et listes).
Quand on décide du schéma (ou du DTD) d'un document HTML, on doit choisir entre représenter l'information sous forme textuelle
<id>0123456789</id>
ou sous forme d'attribut
<id value="0123456789"/>
L'un des inconvénients de XML::Simple, c'est qu'il ne nous laisse pas faire ce choix (c'est l'une des raisons pour lesquelles il n'est pas involutif : si on part d'un fichier XML, si on le lit avec XML::Simple et si on le réécrit, on n'obtient pas nécessairement la même chose). Le module XML::Writer remédie à ce problème.
Ca ressemble beaucoup à XML::Simple : ça permet de mettre un document HTML dans des tables de hachage ou des tableaux.
Jamais utilisé.
Jamais utilisé
Si certains aspect du problème suggèrent d'utiliser DOM alors que d'autres suggèrent d'utiliser SAX, XML::Twig est peut-être une bonne solution : il permet de lire le fichier XML par morceau (typiquement, il s'agit d'une suite très longue d'enregistrements, par exemple, un dictionnaire) et permet d'utiliser une API semblable à DOM sur chacun de ces morceaux, i.e., permet de les considérer comme des arbres.
http://www.xml.com/pub/a/2001/03/21/xmltwig.html
Encore un autre standard pour jouer avec des fichiers XML : XPath ressemble beaucoup à des expressions régulières pour fichiers XML, on peut donc l'utiliser pour chercher un noeud précis à l'intérieur d'un fichier XML . Personnellement, je ne l'ai jamais utilisé : je me contente d'utiliser XPath à l'intérieur de fichiers XSLT.
use XML::XPath;
use XML::XPath::XMLParser;
my $xp = XML::XPath->new(filename => 'test.xhtml');
my $nodeset = $xp->find('/html/body/p'); # find all paragraphs
foreach my $node ($nodeset->get_nodelist) {
print "FOUND\n\n",
XML::XPath::XMLParser::as_string($node),
"\n\n";
}
# Please see the test files in t/ for examples on how to use XPath.Tous les paragraphes qui sont dans un élément <body> de l'élément racine <html> (cela exclut d'éventuels <p> qui seraient plus profonds dans l'arbre) :
/html/body/p
Tous les éléments <species>, à n'importe quelle profondeur de l'arbre :
//species
La valeur de l'attribut "name" du noeud courrant :
@name
La valeur de l'attribut "status" du noeud <conservation> contenu dans le noeud courrant :
conservation/@status
Les blocs <div>, contenus à n'importe quelle profondeur et dont l'attribut "background" vaut "blue".
//dvi[@background="blue"]
Exemple :
$xp = XML::XPath->new(filename => $file)
foreach my $species ($xp->find('//species')->get_nodelist) {
print $species->find('common_name')->string_value;
print $species->find('@name');
print $species->find('conservation/@status');
}
Jamais utilisé. Voir XML::LibXSLT
Une autre manière (simple) de lire des fichiers XML.
Ce module convertit des fichiers CSV (Comma Separated Value, reconnus par beaucoup de tableurs) en documents XML.
Pour donner un exemple, prenons un fichier CSV (des données boursières de Yahoo).
Date,Open,High,Low,Close,Volume 17-Jun-02,28.50,30.74,24.45,24.45,5736467 10-Jun-02,30.88,31.80,26.10,27.88,7208123 3-Jun-02,33.15,34.30,28.63,29.76,2743253 27-May-02,33.40,35.08,31.32,33.60,5268085 20-May-02,33.02,35.32,31.50,33.49,3023722 13-May-02,30.00,34.24,29.02,33.05,6040990 6-May-02,31.73,32.68,28.46,31.00,8007369 29-Apr-02,36.33,36.87,31.52,31.52,6588158 22-Apr-02,40.00,40.20,36.56,36.75,4804380 15-Apr-02,37.80,40.85,37.42,40.15,6856377 8-Apr-02,39.50,39.90,35.31,37.32,11164665 2-Apr-02,44.00,44.24,39.32,39.50,5372157 25-Mar-02,43.48,44.58,42.64,44.58,3482954
On le transforme en XML comme suit.
#! perl -w
use strict;
use XML::CSV;
my $csv = new XML::CSV;
$csv->parse_doc("table.csv", {headings => 1});
$csv->declare_xml({ version => '1.0',
encoding => 'UTF-8',
standalone => 'yes',
});
$csv->print_xml("table");Voici le résultat.
<?xml version="1.0" encoding="UTF-8" standalone="yes"?>
<records>
<record>
<Date>17-Jun-02</Date>
<Open>28.50</Open>
<High>30.74</High>
<Low>24.45</Low>
<Close>24.45</Close>
<Volume>5736467</Volume>
</record>
...
</records>
Ce module, initialement un morceau d'AxKit, permet de produire du PDF à partir d'un document XML.
On peut aussi utiliser le module Apache::AxKit::Language::AxPoint, depuis mod_perl dans un serveur Apache, ou la commande axpoint depuis un shell.
Voir aussi
http://www.xml.com/pub/a/2002/06/19/perl-xml.html
SOAP est un protocole, basé sur XML, pour accéder à des services Web.
Un service web, c'est comme un formulaire sur une page Web, à ceci près que c'est un être humain (ou un programme qui fait semblant d'être humain) qui se connecte sur une page Web et un programme qui se connecte à un service web. Par exemple, on pourrait imaginer un service Web qui permette d'obtenir le titre et l'auteur d'un livre à partir de son ISBN. Amazon est une page web qui permet de faire cela : l'interface peut changer, la présentation des résultats peut changer, mais un être humain parviendra toujours à lire le résultat ; ce n'est pas un service web, car un programme qui s'y connecterait serait déconcerté par de tels changements.
Comme exemple de service web [c'est très dur de trouver un exemple de service Web : ça existe, mais ils sont essentiellement utilisés pour le B2B, i.e., pour la communication inter-entreprises -- pour le particulier, ils sont invisibles], nous prendrons google : la page web que vous connaissez est juste une pages web et pas un service web, mais il y a aussi un service web correspondant.
http://www.google.com/apis/. http://groups.google.com/groups?hl=en&group=google.public.web-apis
Voici quelques listes de services Web. On est sensé les trouver dans des annuaires de services Web (UDDI) (mais je n'y comprends absolument rien).
http://www.xmethods.net/ http://demo.alphaworks.ibm.com/browser/ http://uddi.microsoft.com/
Il faut tout d'abord décrire le service web : quel est le nom des fonctions auxquelles on aura accès ? à quel URL se trouvent-elles ? quels types d'objets prennent-elles en arguments ? quels types d'objets renvoient-elles ? (ces types peuvent être des types complexes, avec des tableaux, des tables de hachage ou même des arbres). La description du service web se trouve dans un fichier WSDL. Voici celui de Yahoo.
<?xml version="1.0"?>
<!-- WSDL description of the Google Web APIs.
The Google Web APIs are in beta release. All interfaces are subject to
change as we refine and extend our APIs. Please see the terms of use
for more information. -->On commence par déclarer plein d'espaces de nomage. On reconnait SOAP (et SOAP-enc), WSDL et XSD (utilisé pour écrire des schémas, i.e., des DTD en XML).
<definitions name="urn:GoogleSearch"
targetNamespace="urn:GoogleSearch"
xmlns:typens="urn:GoogleSearch"
xmlns:xsd="http://www.w3.org/2001/XMLSchema"
xmlns:soap="http://schemas.xmlsoap.org/wsdl/soap/"
xmlns:soapenc="http://schemas.xmlsoap.org/soap/encoding/"
xmlns:wsdl="http://schemas.xmlsoap.org/wsdl/"
xmlns="http://schemas.xmlsoap.org/wsdl/">On définit ensuite les différents types que l'on va manipuler.
<!-- Types for search - result elements, directory categories -->
<types>
<xsd:schema xmlns="http://www.w3.org/2001/XMLSchema"
targetNamespace="urn:GoogleSearch">
<xsd:complexType name="GoogleSearchResult">
<xsd:all>
<xsd:element name="documentFiltering" type="xsd:boolean"/>
<xsd:element name="searchComments" type="xsd:string"/>
<xsd:element name="estimatedTotalResultsCount" type="xsd:int"/>
<xsd:element name="estimateIsExact" type="xsd:boolean"/>
<xsd:element name="resultElements" type="typens:ResultElementArray"/>
<xsd:element name="searchQuery" type="xsd:string"/>
<xsd:element name="startIndex" type="xsd:int"/>
<xsd:element name="endIndex" type="xsd:int"/>
<xsd:element name="searchTips" type="xsd:string"/>
<xsd:element name="directoryCategories" type="typens:DirectoryCategoryArray"/>
<xsd:element name="searchTime" type="xsd:double"/>
</xsd:all>
</xsd:complexType>
<xsd:complexType name="ResultElement">
<xsd:all>
<xsd:element name="summary" type="xsd:string"/>
<xsd:element name="URL" type="xsd:string"/>
<xsd:element name="snippet" type="xsd:string"/>
<xsd:element name="title" type="xsd:string"/>
<xsd:element name="cachedSize" type="xsd:string"/>
<xsd:element name="relatedInformationPresent" type="xsd:boolean"/>
<xsd:element name="hostName" type="xsd:string"/>
<xsd:element name="directoryCategory" type="typens:DirectoryCategory"/>
<xsd:element name="directoryTitle" type="xsd:string"/>
</xsd:all>
</xsd:complexType>
<xsd:complexType name="ResultElementArray">
<xsd:complexContent>
<xsd:restriction base="soapenc:Array">
<xsd:attribute ref="soapenc:arrayType" wsdl:arrayType="typens:ResultElement[]"/>
</xsd:restriction>
</xsd:complexContent>
</xsd:complexType>
<xsd:complexType name="DirectoryCategoryArray">
<xsd:complexContent>
<xsd:restriction base="soapenc:Array">
<xsd:attribute ref="soapenc:arrayType" wsdl:arrayType="typens:DirectoryCategory[]"/>
</xsd:restriction>
</xsd:complexContent>
</xsd:complexType>
<xsd:complexType name="DirectoryCategory">
<xsd:all>
<xsd:element name="fullViewableName" type="xsd:string"/>
<xsd:element name="specialEncoding" type="xsd:string"/>
</xsd:all>
</xsd:complexType>
</xsd:schema>
</types>Voici maintenant la liste des différents messages que l'on peut envoyer et/ou recevoir. Par exemple, si on envoie un message de type doGetCachedPage, on reçoit une réponse de type doGetCachedPageResponse.
<!-- Messages for Google Web APIs - cached page, search, spelling. -->
<message name="doGetCachedPage">
<part name="key" type="xsd:string"/>
<part name="url" type="xsd:string"/>
</message>
<message name="doGetCachedPageResponse">
<part name="return" type="xsd:base64Binary"/>
</message>
<message name="doSpellingSuggestion">
<part name="key" type="xsd:string"/>
<part name="phrase" type="xsd:string"/>
</message>
<message name="doSpellingSuggestionResponse">
<part name="return" type="xsd:string"/>
</message>
<message name="doGoogleSearch">
<part name="key" type="xsd:string"/>
<part name="q" type="xsd:string"/>
<part name="start" type="xsd:int"/>
<part name="maxResults" type="xsd:int"/>
<part name="filter" type="xsd:boolean"/>
<part name="restrict" type="xsd:string"/>
<part name="safeSearch" type="xsd:boolean"/>
<part name="lr" type="xsd:string"/>
<part name="ie" type="xsd:string"/>
<part name="oe" type="xsd:string"/>
</message>
<message name="doGoogleSearchResponse">
<part name="return" type="typens:GoogleSearchResult"/>
</message>On a maintenant la liste des fonctions que l'on peut appeler (elles ont le même nom que les messages (=types) précédemment définis.
<!-- Port for Google Web APIs, "GoogleSearch" -->
<portType name="GoogleSearchPort">
<operation name="doGetCachedPage">
<input message="typens:doGetCachedPage"/>
<output message="typens:doGetCachedPageResponse"/>
</operation>
<operation name="doSpellingSuggestion">
<input message="typens:doSpellingSuggestion"/>
<output message="typens:doSpellingSuggestionResponse"/>
</operation>
<operation name="doGoogleSearch">
<input message="typens:doGoogleSearch"/>
<output message="typens:doGoogleSearchResponse"/>
</operation>
</portType>Maintenant, je ne sais pas trop ce que c'est. J'ai l'impression que c'est à nouveau la liste des fonctions, mais cette fois-ci, on précise qu'on utilisera SOAP pour y accéder.
<!-- Binding for Google Web APIs - RPC, SOAP over HTTP -->
<binding name="GoogleSearchBinding" type="typens:GoogleSearchPort">
<soap:binding style="rpc"
transport="http://schemas.xmlsoap.org/soap/http"/>
<operation name="doGetCachedPage">
<soap:operation soapAction="urn:GoogleSearchAction"/>
<input>
<soap:body use="encoded"
namespace="urn:GoogleSearch"
encodingStyle="http://schemas.xmlsoap.org/soap/encoding/"/>
</input>
<output>
<soap:body use="encoded"
namespace="urn:GoogleSearch"
encodingStyle="http://schemas.xmlsoap.org/soap/encoding/"/>
</output>
</operation>
<operation name="doSpellingSuggestion">
<soap:operation soapAction="urn:GoogleSearchAction"/>
<input>
<soap:body use="encoded"
namespace="urn:GoogleSearch"
encodingStyle="http://schemas.xmlsoap.org/soap/encoding/"/>
</input>
<output>
<soap:body use="encoded"
namespace="urn:GoogleSearch"
encodingStyle="http://schemas.xmlsoap.org/soap/encoding/"/>
</output>
</operation>
<operation name="doGoogleSearch">
<soap:operation soapAction="urn:GoogleSearchAction"/>
<input>
<soap:body use="encoded"
namespace="urn:GoogleSearch"
encodingStyle="http://schemas.xmlsoap.org/soap/encoding/"/>
</input>
<output>
<soap:body use="encoded"
namespace="urn:GoogleSearch"
encodingStyle="http://schemas.xmlsoap.org/soap/encoding/"/>
</output>
</operation>
</binding>Dernière chose : l'URL où il faut se connecter.
<!-- Endpoint for Google Web APIs -->
<service name="GoogleSearchService">
<port name="GoogleSearchPort" binding="typens:GoogleSearchBinding">
<soap:address location="http://api.google.com/search/beta2"/>
</port>
</service>
</definitions>Le module SOAP::Lite est capable de lire un fichier WSDL pour accéder à des services web.
Par exemple (il faut mettre sa clef d'accès, que l'on a reçue après s'être enregistré, dans $key) :
#! perl -w
use strict;
use SOAP::Lite;
# Pour éviter le message "Wrong boolean value 'false'"
# D'après http://groups.yahoo.com/group/soaplite/message/895
*SOAP::XMLSchema1999::Deserializer::as_boolean =
*SOAP::XMLSchemaSOAP1_1::Deserializer::as_boolean =
\&SOAP::XMLSchema2001::Deserializer::as_boolean;
my $key='000000000000000000000000';
my $query=$ARGV[0] || die "usage $0 word";
my $googleSearch = SOAP::Lite -> service("file:GoogleSearch.wsdl");
my $result = $googleSearch -> doGoogleSearch(
$key,
$query,
0, # start
10, # max results
"false", # filter
"", # restrict
"false", # safeSearch
"", # lr
"latin1", # ie (input encoding)
"latin1", # oe (output encoding)
);
use Data::Dumper;
print Dumper($result);Voici un résultat :
$VAR1 = bless( {
'directoryCategories' => [],
'estimateIsExact' => 0,
'startIndex' => '1',
'searchTime' => '0.254403',
'resultElements' => [
bless( {
'summary' => '',
'title' => 'Index of /~<b>zoonek</b>/LaTeX/Fontes/Images',
'hostName' => '',
'URL' => 'http://www.math.jussieu.fr/~zoonek/LaTeX/Fontes/Images/',
'directoryCategory' => bless( {
'specialEncoding' => '',
'fullViewableName' => ''
}, 'DirectoryCategory' ),
'cachedSize' => '7k',
'relatedInformationPresent' => 1,
'directoryTitle' => '',
'snippet' => 'Index of /~<b>zoonek</b>/LaTeX/Fontes/Images. Name Last modified<br> Size Description Parent Directory <b>...</b> '
}, 'ResultElement' ),
bless( { ... }, 'ResultElement' ),
...
],
'estimatedTotalResultsCount' => '1370',
'searchTips' => '',
'searchComments' => '',
'searchQuery' => 'zoonek',
'endIndex' => '10',
'documentFiltering' => 0
}, 'GoogleSearchResult' );On peut donc écrire un script qui affiche les 10 premiers URLs trouvés.
#! perl -w
use strict;
use SOAP::Lite;
# Pour éviter le message "Wrong boolean value 'false'"
# D'après http://groups.yahoo.com/group/soaplite/message/895
*SOAP::XMLSchema1999::Deserializer::as_boolean =
*SOAP::XMLSchemaSOAP1_1::Deserializer::as_boolean =
\&SOAP::XMLSchema2001::Deserializer::as_boolean;
my $key='000000000000000000000000';
my $query=$ARGV[0] || die "usage $0 word";
my $googleSearch = SOAP::Lite -> service("file:GoogleSearch.wsdl");
my $result = $googleSearch -> doGoogleSearch(
$key,
$query,
0, # start
10, # max results
"false", # filter
"", # restrict
"false", # safeSearch
"", # lr
"latin1", # ie (input encoding)
"latin1", # oe (output encoding)
);
foreach my $e (@{ $result->{'resultElements'} }) {
print $e->{'URL'} ."\n";
}Jusqu'ici, on a utilisé SOAP, mais sans le dire : SOAP est le protocole utilisé dans les communications, on ne le voit pas. En fait, voici ce quii se passe. Le client envoie
POST /search/beta2 HTTP/1.1
TE: deflate,gzip;q=0.3
Connection: TE, close
Accept: text/xml
Accept: multipart/*
Host: localhost:8080
User-Agent: SOAP::Lite/Perl/0.51
Content-Length: 885
Content-Type: text/xml; charset=utf-8
SOAPAction: "urn:GoogleSearchAction"
<?xml version="1.0" encoding="UTF-8"?>
<SOAP-ENV:Envelope
xmlns:SOAP-ENC="http://schemas.xmlsoap.org/soap/encoding/"
SOAP-ENV:encodingStyle="http://schemas.xmlsoap.org/soap/encoding/"
xmlns:SOAP-ENV="http://schemas.xmlsoap.org/soap/envelope/"
xmlns:xsi="http://www.w3.org/1999/XMLSchema-instance"
xmlns:xsd="http://www.w3.org/1999/XMLSchema">
<SOAP-ENV:Body>
<namesp1:doGoogleSearch xmlns:namesp1="urn:GoogleSearch">
<key xsi:type="xsd:string">000000000000000</key>
<q xsi:type="xsd:string">toto</q>
<start xsi:type="xsd:int">0</start>
<maxResults xsi:type="xsd:int">10</maxResults>
<filter xsi:type="xsd:boolean">false</filter>
<restrict xsi:type="xsd:string"/>
<safeSearch xsi:type="xsd:boolean">false</safeSearch>
<lr xsi:type="xsd:string"/>
<ie xsi:type="xsd:string">latin1</ie>
<oe xsi:type="xsd:string">latin1</oe>
</namesp1:doGoogleSearch>
</SOAP-ENV:Body>
</SOAP-ENV:Envelope>Et le serveur envoie sa réponse.
<?xml version='1.0' encoding='UTF-8'?>
<SOAP-ENV:Envelope
xmlns:SOAP-ENV="http://schemas.xmlsoap.org/soap/envelope/"
xmlns:xsi="http://www.w3.org/1999/XMLSchema-instance"
xmlns:xsd="http://www.w3.org/1999/XMLSchema">
<SOAP-ENV:Body>
<ns1:doGoogleSearchResponse xmlns:ns1="urn:GoogleSearch" SOAP-ENV:encodingStyle="http://schemas.xmlsoap.org/soap/encoding/">
<return xsi:type="ns1:GoogleSearchResult">
<documentFiltering xsi:type="xsd:boolean">false</documentFiltering>
<estimatedTotalResultsCount
xsi:type="xsd:int">1560000</estimatedTotalResultsCount>
<directoryCategories
xmlns:ns2="http://schemas.xmlsoap.org/soap/encoding/"
xsi:type="ns2:Array"
ns2:arrayType="ns1:DirectoryCategory[2]">
<item xsi:type="ns1:DirectoryCategory">
<specialEncoding xsi:type="xsd:string"></specialEncoding>
<fullViewableName xsi:type="xsd:string">Top/Arts/Music/Bands_and_Artists/T/Toto</fullViewableName>
</item>
<item xsi:type="ns1:DirectoryCategory">
<specialEncoding xsi:type="xsd:string">EUC-JP</specialEncoding>
<fullViewableName xsi:type="xsd:string">Top/World/Japanese/????/?????</fullViewableName>
</item>
</directoryCategories>
<searchTime xsi:type="xsd:double">0.385847</searchTime>
<resultElements
xmlns:ns3="http://schemas.xmlsoap.org/soap/encoding/"
xsi:type="ns3:Array" ns3:arrayType="ns1:ResultElement[10]">
<item xsi:type="ns1:ResultElement">
<cachedSize xsi:type="xsd:string">8k</cachedSize>
<hostName xsi:type="xsd:string"></hostName>
<snippet xsi:type="xsd:string">
The summary for this Japanese page contains
characters that cannot be correctly
displayed in this language/character
set.
</snippet>
<directoryCategory xsi:type="ns1:DirectoryCategory">
<specialEncoding xsi:type="xsd:string">EUC-JP</specialEncoding>
<fullViewableName xsi:type="xsd:string">
Top/World/Japanese/????????/?????/toto
</fullViewableName>
</directoryCategory>
<relatedInformationPresent xsi:type="xsd:boolean">
true
</relatedInformationPresent>
<directoryTitle xsi:type="xsd:string">
<b>toto</b>
</directoryTitle>
...Le module SOAP::Lite peut aussi fonctionner sans fichier WSDL (si l'interface est relativement simple).
Le module SOAP::Lite permet aussi d'écrire un serveur (si on le met sur un serveur web, comme CGI ou avec mod_soap). (Mais je n'ai pas compris comment.)
Voir Frontier::Client et Frontier::Daemon.
Modules permettant d'utiliser XML-RPC (Frontier est le nom de l'entreprise qui a développé XML-RPC). Si on veut aussi écrire un démon, c'est probablement plus simple qu'avec SOAP::Lite.
http://www.tldp.org/HOWTO/XML-RPC-HOWTO/xmlrpc-howto-perl.html http://www-106.ibm.com/developerworks/webservices/library/ws-xpc1/
Chacun peut mettre des liens vers Amazon.com sur son site et gagner de l'argent si les visiteurs y achètent quelque chose : on est alors un "associé" d'Amazon. Amazon propose un service Web à ses associés, pour interroger son catalogue et fabriquer des liens plus personnalisés : c'est ce que permet ce module.
C'est l'interface aux bases de données SQL. Il s'agit d'une interface unique pour toutes les bases de données, de manière qu'on n'ait pas à réécrire tout son code lorsque l'on change de base de données.
DBI tout seul ne fait rien, il a besoin d'un Driver pour la base de donnée à laquelle on va se connecter (car les API (en C) des différentes bases de données sont toutes différentes). Par exemple DBD::Mysql pour MySQL ou DBD::Pg pour PostgreSQL.
Citons aussi DBD::RAM, qui se contente d'accéder à la mémoire, et DBD::CSV, qui utilise un fichier CVS (Comma separated value).
Voici des bribes d'exemples.
Le programme commencera par
#! perl -w use strict; use DBI;
On se connecte à la base de données.
$dbh = DBI->connect("dbi:Pg:dbname=test",
"zoonek", "aaaaaa",
{ RaiseError => 1, AutoCommit => 1 })
or die "Cannot connect to db: $DBI::errstr";On effectue des requètes. C'est une bonne idée de préparer les requètes avant de les exécuter : si la base de donnée le permet, la requète ne sera compilée qu'une seule fois. Par ailleurs, il faut utiliser des paramètres dans les requètes (les points d'interrogation) : ainsi, c'est Perl qui se charge de rajouter des guillemets autour des chaines de caractères et de prendre garde aux caractères dangereux.
$sth = $dbh->prepare("INSERT INTO table(foo,bar,baz)
VALUES (?,?,?)");
while(<CSV>) {
chomp;
my ($foo,$bar,$baz) = split /,/;
$sth->execute( $foo, $bar, $baz )
or die "Can't execute statement: $DBI::errstr";
}Si on sait qu'on va réutiliser la même requête un peu plus loin, on peut demander à l'ordinateur de se souvenir des requêtes déjà préparées. A utiliser avec soin, pour éviter les fuites de mémoire.
$sth = $dbh->prepare_cached("...");On peut récupérer les résultats d'une recherche sous forme d'un tableau (il faut donc bien faire attention à l'ordre et au nombre de colonnes).
$sth = $dbh->prepare("SELECT foo, bar
FROM table WHERE baz=?");
$sth->execute( $baz )
or die "Can't execute statement: $DBI::errstr";
while ( $row = $sth->fetchrow_arrayref ) {
print "@$row\n";
}On peut aussi les récupérer sous forme de table de hachage (c'est plus lent, mais plus lisible).
fetchrow_hashref
Il est aussi possible de récupérer toutes les lignes de la réponse en une seule fois.
fetchall_arrayref fetchall_hashref
Quand on a fini, on peut se déconnecter.
$rc = $dbh->disconnect;
Voici un exemple complet (pas très utile : on écrit la table de multiplication de Z/21Z et on regarde comment on peut obtenir 0, 3, 7 et 10).
#! perl -w
use strict;
use DBI;
my $dbh = DBI->connect("dbi:Pg:dbname=test", undef, undef,
{ RaiseError => 1, AutoCommit => 0 })
or die $DBI::errstr;
$dbh->do("DROP TABLE dbi_test");
$dbh->do("CREATE TABLE dbi_test (foo int, bar int, baz int)")
or die "Cannot create table: $DBI::errstr";
my $sth = $dbh->prepare("INSERT INTO dbi_test(foo,bar,baz)
VALUES (?,?,?)");
# Table de multiplication de Z/21Z (anneau non intègre)
foreach my $i (0..20) {
foreach my $j (0..20) {
$sth->execute( $i, $j, ($i*$j) % 21 )
or die "Can't execute statement: $DBI::errstr";
}
}
$dbh->commit;
$sth = $dbh->prepare("SELECT foo,bar,baz
FROM dbi_test WHERE baz=?");
foreach my $i (0,3,7,10) {
$sth->execute($i)
or die "Can't execute statement: $DBI::errstr";
while ( my $row = $sth->fetchrow_arrayref ) {
print "$row->[2] = $row->[0] x $row->[1]\n";
}
}
$dbh->disconnect;
Permet de créer un graphe en le considérant comme une base de données, accessible uniquement en écriture : quand on rajoute des données dans la base, elle crée automatiquement un graphique que l'on récupère par un SELECT BARCHART FROM Mychart.
C'est un exemple d'utilisation de DBI comme couche d'abstraction (ou pourrait parler de « design patterns » et dire « proxy ») entre le programme et le module GD::Graph, dont je conseillerais plutôt l'utilisation directe.
Pour les gens qui n'aiment pas la syntaxe de SQL, ces modules la remplacent par des appels de fonctions. Exactement comme le module CGI pour les allergiques au HTML.
@adult = Person->retrieve_from_sql('WHERE age >= ?', 18);
Pour transformer automatiquement le résultat d'une requète en un tableau (X)HTML.
Note : On me dit que ce module a été remplacé par XML::Generator::DBI.
Ce module permet de transformer une table en un document XML, par exemple pour la transformer (SAX, DOM, XSLT, etc.), pour la stocker, pour la transférer vers une autre base de données.
A FAIRE : ça ne marche pas...
#! perl -w
use strict;
use Carp ();
$SIG{__WARN__} = \&Carp::cluck;
$SIG{__DIE__} = \&Carp::confess;
use DBI;
use DBIx::XML_RDB;
print STDERR "Creating the DB\n";
my $dbh = DBI->connect("dbi:SQLite:dbname=test", undef, undef,
{ RaiseError => 1, AutoCommit => 0 })
or die $DBI::errstr;
$dbh->do("CREATE TABLE Essai (foo INT, bar INT, baz INT)")
or die "Cannot create table: $DBI::errstr";
my $sth = $dbh->prepare("INSERT INTO Essai (foo,bar,baz)
VALUES (?,?,?)");
$sth->execute(1, 2, 3)
or die "Can't execute statement: $DBI::errstr";
$sth->execute(4, 5, 6)
or die "Can't execute statement: $DBI::errstr";
$sth->execute(7, 8, 9)
or die "Can't execute statement: $DBI::errstr";
$dbh->disconnect();
print STDERR "Reading it\n";
my $xmlout = DBIx::XML_RDB->new("dbi:SQLite:dbname=test",
"SQLite", undef,undef)
or die "Failed to make new xmlout";
$xmlout->DoSql("SELECT * FROM Essai");
print $xmlout->GetData;
Permet de sauvegarder et de récupérer (mais visiblement pas d'effectuer des recherches, contrairement à Tangram) des objets dans une base de données.
Voir aussi : Tangram, Alzabo.
Module Perl qui contient déjà une base de donnée (pas besoin d'installer et de configurer MySQL ou PostgreSQL, tout est déjà dedans). Pour faire des tests rapides (il y a même des transactions).
#! perl -w
use strict;
use DBI;
my $dbh = DBI->connect("dbi:SQLite:dbname=test", undef, undef,
{ RaiseError => 1, AutoCommit => 0 })
or die $DBI::errstr;
#$dbh->do("DROP TABLE IF EXISTS dbi_test");
$dbh->do("CREATE TABLE dbi_test (foo int, bar int, baz int)")
or die "Cannot create table: $DBI::errstr";
my $sth = $dbh->prepare("INSERT INTO dbi_test(foo,bar,baz)
VALUES (?,?,?)");
# Table de multiplication de Z/21Z (anneau non intègre)
foreach my $i (0..20) {
foreach my $j (0..20) {
$sth->execute( $i, $j, ($i*$j) % 21 )
or die "Can't execute statement: $DBI::errstr";
}
}
...Voir aussi DBD::CSV.
Permet d'utiliser des fichiers CSV (voir Text:xSV) comme tables d'une base de données. Pour faire des tests (voir aussi DBD::SQLite) ou pour stocker de petites tables, sur lesquelles on n'effectuera pas de recherches compliquées et qui pourront $etre réutilisées facilement par d'autres programmes.
Alzabo est constitué de deux parties.
D'une part, un outil de conception de schéma de base de donnée, qui permet de définir des tables, leus champs et leurs relations (à l'aide de HTML::Mason).
D'autre part, il fournit une interface orientée objet à une base de données ainsi conçue. C'est donc une manière de transformer un SGBD (par exemple MySQL, omniprésent, rapide, mais limité) en un SGBDOO.
http://www.linuxjournal.com/article.php?sid=4887
Je n'ai jamais utilisé ni l'un ni l'autre, mais Tangram a l'air plus simple.
Permet de stocker des objets dans une base de donnée normale (il permet donc de transformer un SGBD en SGBDOO). Pour des bases de données relativement simples, avec deux ou trois tables, ça ne présente aucun intérêt, mais pour des bases de données plus complexes, avec plus d'une dizaine de tables, raisonner en termes de classes plutôt qu'en termes de tables permet de beaucoup simplifier la conception de la base (j'ai pris un exemple : mes quinze tables, toutes reliées entre elles, et dont la description faisait près de deux pages, se sont réduites à trois classes...).
La documentation est très claire. On commence par définir le schéma qu'on va utiliser, on construit nos objets, on les stocke (on peut donc utiliser Tangram simplement comme une manière de rendre persistantes les données, simplement comme le module Storable).
On peut ensuite effectuer des recherches sur les objets stockés ; ce n'est pas du SQL, mais c'est plus propre et ça m'a l'air aussi puissant. Par exemple :
# On crée deux variables indéterminées ("placeholders"),
# qu'on utilisera dans la recherche
my $person1 = $storage->remote('NaturalPerson');
my $person2 = $storage->remote('NaturalPerson');
my (@parents) = $storage->select( $person1,
$person1->{children}->includes($person2)
& $person2->{firstName} eq 'Bart'
& $person2->{name} eq 'Simpson'
);[C'est un très bel exemple d'application de la surcharge des operateurs (overloading)].
Je ne l'ai jamais utilisé.
Contrairement à Alzabo (qui fait la même chose), la description du schéma n'oblige pas à créer les tables de relation soi-même et permet d'implémenter facilement des relations d'héritage.
http://www.webtechniques.com/archives/2000/03/jepson/
On peut néanmoins formuler quelques critiques :
Il n'y a pas de « fonctions de groupe » du genre MAX.
Je n'ai pas l'impression qu'on puisse lui dire quels index il faut créer (mais ça n'est pas trop génant, on peut le faire à la main).
Je me pose aussi certaines question (dont je n'ai pas trouvé les réponses). Y a-t-il un mécanisme de blocage (si deux programmes lisent les données pour les modifier plus tard) ? Y a-t-il des « fonction aggrégées » (MAX, etc.) ? Y a-t-il de l'héritage multiple ? (je crois que oui) Les index sont-ils crés automatiquement ? Peut-on utiliser des fonctions définies par l'utilisateur dans les requètes ?
On peut contrôler la manière dont les objets sont répartis en différentes tables.
perldoc Tangram::Relational::Mappings
Une manière de séparer le code Perl et le code SQL consiste à mettre le code SQL dans une table à deux colonne, la première contenant le nom de la fonction que l'on appellera (en Perl, ou un autre langage), la seconde contient le code SQL.
Cela permet aussi de faire des recherches dans les requètes.
Pour des bases de données complexes, c'est généralement une bonne idée de mettre le schéma directement dans la base de données. Et on programme alors, non pas en utilisant notre connaissance de ce schéma, mais en allant chercher ce schéma directement dans la base de données -- le programme est alors résistant aux changements de ce schéma.
C'est ce que permet de faire ce module.
perldoc DbFramework::Catalog
Il y a aussi une classe DbFramework::Template, pour remplir un moule (template) avec les résultats d'une requète SQL.
Pour les gens qui préfèrent écrire du XML plutôt que du SQL...
Réduit la taille des fichiers HTML (ils sont plus faciles à lire pour les machines -- mais pas pour les êtres humains), en enlevant les espaces, les commentaires, les balises inutiles, en remplaçant certaines balises par des synonymes (<strong> et <b>).
Ce module a deux fonctions : d'une part, il permet de récupérer le contenu d'un formulaire HTML envoyé à un serveur Web, d'autre part, il permet de produire du HTML (à chaque balise HTML correspond une fonction de même nom).
#! perl -Tw
use strict;
$|++;
use CGI qw(:all);
print header, start_html("Essai");
print h1("Essai"), hr;
print p( a({href => "ici.html"}, "Cliquez ici.") );
print img({src => "foo.png", alt => "*"});
print start_form,
"Name: ", textfield('name'), br,
submit,
endform;
print end_html;On n'oubliera pas de vérifier que le HTML (ou XHTML) produit est bien conforme.
http://www.htmlhelp.org/tools/validator/
On notera aussi la fonction escapeHTML, qui permet d'afficher du texte quelconque (même avec des < ou des &).
print escapeHTML('sdkgh sdkh < sdkgj &hfsk');Ce module permet aussi de manipuler les différents paramètres envoyés à un script CGI par l'intermédiaire d'un formulaire (POST) ou directement dans l'URL (GET).
print p("Boujour, ". param('name') );
C'est le même module que ci-dessus, mais il produit du HTML indenté, humainement lisible.
#! perl -Tw use strict; $|++; use CGI::Pretty qw(:all); $CGI::Pretty::INDENT = " "; ...
(En fait, ça pourrait quand même être un peu plus indenté.)
Quand on met un formulaire dans un site Web (par exemple, pour qu'un visiteur s'enregistre, pour qu'il rentre de nouvelles informations dans une base de données), il convient de vérifier que tous les champs obligatoires ont été remplis et qu'il contiennent des valeurs correctes (par exemple, une adresse électronique qui ne contiendrait pas de caractère @ serait suspecte).
Le module Data::FormValidator permet d'effectuer ces vérifications.
#! perl -w
use strict;
use Data::FormValidator;
my $validator = new Data::FormValidator('profile');
my %param = (
Name => 'Vincent',
address => 'foobar',
quality => 'baad',
comment => '',
);
my ($valid, $missing, $invalid, $unknown) =
$validator->validate(\%param, 'info');
sub print_fields {
my $a = shift;
foreach my $k (keys %$a) {
print " $k => $a->{$k}\n";
}
}
print "Valid fields:\n";
foreach my $k (keys %$valid) {
print " $k => $valid->{$k}\n";
}
print "Missing fields: @$missing\n";
print "Invalid fields: @$invalid\n";
print "Unknown fields: @$unknown\n";Le fichier "profile" contient les vérifications à effectuer pour les différents types de formulaires.
{
info => {
optional => [qw/comment/],
required => [qw/name address quality/],
constraints => { email => 'email', # any function
quality => '/^(good|bad)$/',
},
filters => [qw/trim/],
},
}
C'est un module permettant d'accéder à la bibliothèque Tk, qui permet d'écrire des logiciels WYSIWYG, avec plein de boutons, de menus, d'icones (i.e., des cliquodromes).
Voir
http://www.math.jussieu.fr/~zoonek/UNIX/10_ptk/1.html
(Avertissement : je n'ai pas fini d'écrire cette partie -- et je ne la finierai pas.)
Analysons l'exemple minimal du manuel.
#! perl -w
use Gtk '-init';
my $window = new Gtk::Window;
my $button = new Gtk::Button("Quit");
$button->signal_connect("clicked", sub {Gtk->main_quit});
$window->add($button);
$window->show_all;
Gtk->main;Le programme commence par
use Gtk '-init';
et se termine par
Gtk->main;
Entre deux, il faut créer une fenêtre
my $window = new Gtk::Window;
la remplir (on verra ça plus loin)
et l'afficher
$window->show_all;
Pour remplir une fenêtre, on commence par créer et configurer les machins (en anglais "widgets") qui la composent
my $button = new Gtk::Button("Quit");
$button->signal_connect("clicked", sub {Gtk->main_quit});et on ajoute le machin à la fenêtre
$window->add($button);
Voici un exemple plus long. On commence par rajouter un peu de texte, une zône ou on pourra taper des choses, une image. Si on essaye de mettre les widguètes les uns après les autres, ça ne marche pas. Il faut dire à Gtk comment il doit les organiser. Par exemple, les mettres les uns à côté des autres, ou les uns en dessous des autres.
#! perl -w
use strict;
use constant FALSE => (0==1);
use constant TRUE => (0==0);
use Gtk;
init Gtk;
my $window = new Gtk::Window;
$window->border_width(4);
my $vbox = new Gtk::VBox(FALSE, 0);
my $label = new Gtk::Label("Password");
$label->show;
$vbox->pack_start($label, FALSE, FALSE, 5);
my $entry = new Gtk::Entry;
$entry->set_text("");
$entry->set_visibility( FALSE );
$entry->signal_connect( "activate",
sub {
my ($widget, $entry) = @_;
if( $entry->get_text() eq "pass" ){
print STDERR "Correct\n";
Gtk->main_quit;
} else {
print STDERR "Incorrect password\n";
$entry->set_text("");
}
},
$entry );
$entry->show;
$vbox->pack_start($entry, FALSE, FALSE, 5);
my $buttons = new Gtk::HBox(TRUE, 0); # TRUE: chaque case a la même taille
my $ok = new Gtk::Button("OK");
$ok->signal_connect("clicked", sub {Gtk->main_quit});
$ok->show;
$buttons->pack_start($ok, FALSE, TRUE, 10); # TRUE: les boutons sont la même taille
my $cancel = new Gtk::Button("Cancel");
$cancel->signal_connect("clicked", sub {Gtk->main_quit});
$cancel->show;
$buttons->pack_start($cancel, FALSE, TRUE, 10);
$buttons->show;
$vbox->pack_start($buttons, FALSE, FALSE, 5);
$vbox->show;
$window->add($vbox);
$window->show;
Gtk->main;
Il est aussi possible de positionner les widgets à l'aide d'une table
perldoc Gtk::Table A FAIRE
Pour décrire des Interfaces utilisateur, on peut aussi utiliser Glade-Perl
http://www.glade.perl.connectfree.co.uk/index.html A FAIRE
Je donne maintenant une liste d'exemples de widguètes (c'est purement descriptif, c'est juste histoire de savoir ce qui existe).
Un Label permet d'écrire du texte (au plus une ligne, pour des textes plus longs, voir le Widguète Text).
#! perl -w
use strict;
use Gtk;
init Gtk;
my $window = new Gtk::Window;
$window->border_width(4);
my $label = new Gtk::Label("Hello, world!");
$label->show;
$window->add($label);
$window->show;
Gtk->main;
Une Entry permet à l'utilisateur d'entrer du texte (au plus une ligne). On peut lui demander de ne pas afficher ce qui est tapé (judicieux s'(il s'agit d'un mot de passe).
#! perl -w
use strict;
use Gtk;
init Gtk;
my $window = new Gtk::Window;
$window->border_width(4);
my $entry = new Gtk::Entry;
$entry->signal_connect("activate", \&entry, $entry);
$entry->show;
$window->add($entry);
$window->show;
Gtk->main;
sub entry {
my ($widget, $entry) = @_;
print "Hello ". $entry->get_text() ."\n";
}
Button : indispensable sur un cliquodrome.
#! perl -w
use strict;
use Gtk;
init Gtk;
my $window = new Gtk::Window;
$window->border_width(4);
my $w = new Gtk::Button("You may click here");
$w->signal_connect("clicked", \&doit);
$w->show;
$window->add($w);
$window->show;
Gtk->main;
sub doit { print STDERR "clicked!\n" }
On peut varier le genre de bouton : Togglebutton.
#! perl -w
use strict;
use Gtk;
init Gtk;
my $window = new Gtk::Window;
$window->border_width(5);
my $w = new Gtk::ToggleButton();
# Comme on ne peut pas modifier le texte d'un bouton,
# on met un Label dans ce bouton
my $label = new Gtk::Label("Off");
$label->show;
$w->add($label);
$w->signal_connect("clicked", \&doit, $label);
$w->show;
$window->add($w);
$window->set_default_size(100, 30);
$window->show;
Gtk->main;
sub doit {
my ($w, $l) = @_;
if( $w->active ){
$l->set_text("On");
} else {
$l->set_text("Off");
}
}
#! perl -w
use strict;
use constant TRUE => (0==0);
use constant FALSE => (0==1);
use vars qw($answer);
$answer = FALSE;
use Gtk;
init Gtk;
my $window = new Gtk::Window;
$window->border_width(5);
my $w = new Gtk::CheckButton("Perl programmer");
$w->signal_connect("clicked", \&doit);
$w->show;
$window->add($w);
$window->show;
Gtk->main;
sub doit {
my $w = shift;
if( $w->active ){
print "Yes\n";
$answer = TRUE;
} else {
print "No\n";
$answer = FALSE;
}
}
Encore un autre type de bouton : Radiobutton.
#! perl -w
use strict;
use constant TRUE => (0==0);
use constant FALSE => (0==1);
use vars qw($answer);
$answer = FALSE;
use Gtk;
init Gtk;
my $window = new Gtk::Window;
$window->border_width(5);
my $box = new Gtk::VBox;
# We have to chain the radio buttons
my $b1 = new Gtk::RadioButton("First choice");
$b1->set_active(TRUE); # default choice
$b1->show;
$box->pack_start($b1, FALSE, TRUE, 0);
my $b2 = new Gtk::RadioButton("Second choice", $b1);
$b2->show;
$box->pack_start($b2, FALSE, TRUE, 0);
my $b3 = new Gtk::RadioButton("Last choice", $b2);
$b3->show;
$box->pack_start($b3, FALSE, TRUE, 0);
my $quit = new Gtk::Button("Quit");
$quit->signal_connect("clicked", \&doit,
{1 => $b1, 2 => $b2, 3 => $b3});
$quit->show;
$box->pack_start($quit, FALSE, FALSE, 0);
$box->show;
$window->add($box);
$window->show;
Gtk->main;
sub doit {
my ($w, $l) = @_;
foreach my $v (keys %$l) {
my $b = $l->{$v};
if( $b->active ){
print STDERR "Choice: $v\n";
}
}
Gtk->main_quit;
}
Il est aussi possible de mettre les boutons dans des ButtonBoxes (mais je ne vois pas la différence avec les boites).
#! perl -w
use strict;
use constant TRUE => (0==0);
use constant FALSE => (0==1);
use vars qw($answer);
$answer = FALSE;
use Gtk;
init Gtk;
my $window = new Gtk::Window;
$window->border_width(5);
my $box = new Gtk::VBox;
my $bbox = new Gtk::VButtonBox;
# We still hav to chain the radio buttons
my $b1 = new Gtk::RadioButton("First choice");
$b1->set_active(TRUE); # default choice
$b1->show;
$bbox->add($b1);
my $b2 = new Gtk::RadioButton("Second choice", $b1);
$b2->show;
$bbox->add($b2);
my $b3 = new Gtk::RadioButton("Last choice", $b2);
$b3->show;
$bbox->add($b3);
$bbox->show;
$box->pack_start($bbox, FALSE, TRUE, 0);
my $quit = new Gtk::Button("Quit");
$quit->signal_connect("clicked", \&doit,
{1 => $b1, 2 => $b2, 3 => $b3});
$quit->show;
$box->pack_start($quit, FALSE, FALSE, 0);
$box->show;
$window->add($box);
$window->show;
Gtk->main;
sub doit {
my ($w, $l) = @_;
foreach my $v (keys %$l) {
my $b = $l->{$v};
if( $b->active ){
print STDERR "Choice: $v\n";
}
}
Gtk->main_quit;
}
Les Frames sont des boites visibles, avec un titre, qui permettent de bien séparer les différents éléments de la fenêtre.
#! perl -w
use strict;
use constant TRUE => (0==0);
use constant FALSE => (0==1);
use vars qw($answer);
$answer = FALSE;
use Gtk;
init Gtk;
my $window = new Gtk::Window;
$window->border_width(5);
my $frame = new Gtk::Frame("Frame");
my $l1 = new Gtk::Label("Hello World!");
$l1->show;
$frame->add($l1);
$frame->show;
$window->add($frame);
$window->show;
Gtk->main;
Les séparateurs jouent un rôle comparable.
#! perl -w
use strict;
use constant TRUE => (0==0);
use constant FALSE => (0==1);
use vars qw($answer);
$answer = FALSE;
use Gtk;
init Gtk;
my $window = new Gtk::Window;
$window->border_width(5);
my $box = new Gtk::VBox;
for(my $i=1; $i<4; $i++){
my $l = new Gtk::Label("Hello World $i!");
$l->show;
$box->pack_start($l, FALSE, TRUE, 0);
}
my $sep = new Gtk::HSeparator;
$sep->show;
$box->pack_start($sep, FALSE, TRUE, 0);
for(my $i=4; $i<7; $i++){
my $l = new Gtk::Label("Hello World $i!");
$l->show;
$box->pack_start($l, FALSE, TRUE, 0);
}
$box->show;
$window->add($box);
$window->show;
Gtk->main;
Dans le Widguète Entry, on peut réagir à la pression de la touche entrée.
$entry->signal_connect( "activate", \&enter_callback, $entry );
Quand on a plusieurs boutons, l'un d'entre eux correspond souvent à un choix par défaut. On peut demander à Gtk de le dessiner différemment, à l'aide des commandes can_default et grab_default.
A FAIRE
(ça ne donne pas exactement ça)
#! perl -w
use strict;
use constant TRUE => (0==0);
use constant FALSE => (0==1);
use vars qw($answer);
$answer = FALSE;
use Gtk;
init Gtk;
my $window = new Gtk::Window;
$window->border_width(5);
my $vbox = new Gtk::VBox;
for(my $i=1; $i<4; $i++){
my $l = new Gtk::Label("Hello World $i!");
$l->show;
$vbox->pack_start($l, FALSE, TRUE, 0);
}
my $sep = new Gtk::HSeparator;
$sep->show;
$vbox->pack_start($sep, FALSE, TRUE, 0);
my $confirm_box = new Gtk::HBox(TRUE, 10);
my $cancel = new Gtk::Button("Cancel");
$cancel->signal_connect("clicked", sub{ Gtk->exit(0) });
$cancel->show;
$confirm_box->pack_start($cancel, TRUE, TRUE, 0);
my $ok = new Gtk::Button("OK");
$ok->signal_connect("clicked", sub { print "OK\n"; Gtk->exit(0); });
$ok->can_default(TRUE);
$ok->grab_default;
$ok->show;
$confirm_box->pack_start($ok, TRUE, TRUE, 0);
$confirm_box->show;
$vbox->pack_start($confirm_box, FALSE, TRUE, 0);
$vbox->show;
$window->add($vbox);
$window->show;
Gtk->main;
Une barre d'avancement.
#! perl -w
use strict;
use constant TRUE => (0==0);
use constant FALSE => (0==1);
use vars qw($answer);
$answer = FALSE;
use Gtk;
init Gtk;
my $window = new Gtk::Window;
$window->border_width(5);
my $vbox = new Gtk::VBox;
my $l = new Gtk::Label("Processing data...");
$l->show;
$vbox->pack_start($l, FALSE, TRUE, 0);
my $progress = new Gtk::ProgressBar();
$progress->update(0);
$progress->show;
$vbox->pack_start($progress, FALSE, TRUE, 0);
my $cancel = new Gtk::Button("Cancel");
$cancel->signal_connect("clicked", sub{ Gtk->exit(0) });
$cancel->show;
$vbox->pack_start($cancel, TRUE, TRUE, 0);
$vbox->show;
$window->add($vbox);
$window->show;
Gtk->main;Mais il faut la remplir, cette barre d'avancement. On peut par exemple demander à Gtk de l'avancer un peu toutes les 100 ms.
#! perl -w
use strict;
use constant TRUE => (0==0);
use constant FALSE => (0==1);
use vars qw($answer);
$answer = FALSE;
use Gtk;
init Gtk;
my $window = new Gtk::Window;
$window->border_width(5);
my $vbox = new Gtk::VBox;
my $l = new Gtk::Label("Processing data...");
$l->show;
$vbox->pack_start($l, FALSE, TRUE, 0);
my $progress = new Gtk::ProgressBar();
$progress->update(0);
$progress->show;
$vbox->pack_start($progress, FALSE, TRUE, 0);
my $cancel = new Gtk::Button("Cancel");
$cancel->signal_connect("clicked", sub{ Gtk->exit(0) });
$cancel->show;
$vbox->pack_start($cancel, TRUE, TRUE, 0);
$vbox->show;
$window->add($vbox);
$window->show;
my $ms = 0;
my $timer;
sub increase {
print "$ms\n";
$ms++;
$progress->update(.01*$ms);
if($ms==100){
print "Finished\n";
Gtk->timeout_remove($timer); # instead, we could say « return FALSE »
Gtk->exit(0);
}
return TRUE;
}
$timer = Gtk->timeout_add(500, \&increase);
Gtk->main;
A FAIRE Menus Comment dessiner
A FAIRE (en cours) :
#! perl -w
use strict;
use Gtk;
init Gtk;
my $window = new Gtk::Window;
$window->signal_connect( 'destroy', sub { Gtk->exit( 0 ); } );
my $drawing = new Gtk::DrawingArea();
sub draw_all {
my $drawable = $drawing->window;
# C'est assez compliqué et je ne comprends pas tout.
# Il faut tout d'abord récupérer le contexte graphique
# (c'est un peu comme l'état graphique du PostScript,
# si j'ai bien compris : un ensemble de variables qui disent
# comment on doit tracer les choses, couleur du tracé, couleur
# du fond, épaisseur des traits, arrondis aux extrémités des
# polylignes, fonte courrante, etc).
# Il y a visiblement plusieurs contextes graphiques,
# on prend le "normal", qui correspond à la couleur du tracé.
# Il y a deux couleurs qui sont TOUJOURS là : le blanc et le noir.
my $gc = $drawing->style->black_gc;
# On peut maintenant tracer un segment.
$drawable->draw_line( $gc, 10, 10, 100, 100 );
# Essayons maintenant de tracer une ligne dans une autre couleur.
# C'est plus compliqué, car il faut d'abord allouer la couleur
# dans la table des couleurs (oui, même s'il n'y a pas de table
# de couleurs parce qu'on est en 16, 24 ou 32 bits).
my $red = Gtk::Gdk::Color->parse_color( 'red' );
$red = $drawing->window->get_colormap()->color_alloc( $red );
# Et après ???
# A FAIRE
# Essayons maintenant de tracer du texte
# Il faut préalablement charger une fonte
# On peut aussi charger un ensemble de fontes, à l'aide de
# la méthode fontset_load.
my $font = Gtk::Gdk::Font->load("fixed");
$drawable->draw_string( $font, $gc, 15, 70, "Essai" );
# Essayons enfin de mettre une image.
# $draw_area->draw_pixmap( $gc, $gdk_pixmap,
# $xsrc, $ysrc,
# $xdest, $ydest,
# $width, $height );
# $drawing_area->window->set_background( $bgcolor );
my $black_gc = $drawing->style->black_gc;
$drawable->draw_rectangle( $black_gc, 0, 10, 10, 100, 100 );
return 1;
}
# On doit soi-même se souvenir de ce qui a été tracé.
# afin de pouvoir le redessiner quand la fenêtre redevient visible
# après avoir été cachée.
$drawing->signal_connect( 'configure_event', \&draw_all );
$drawing->signal_connect( 'expose_event', \&draw_all );
$drawing->show;
$window->add($drawing);
$window->show;
Gtk->main;Il y a plein d'autres Widguètes, je renvoie à la documentation et au tutoriel pour plus de détails.
http://personal.riverusers.com/~swilhelm/gtkperl-tutorial/index.html
EFFACER :
$text = new Gtk::Text( $hadj, $vadj );
$text->set_point( $index );
$text->get_point();
$text->get_length();
$text->insert( $font, $foreground, $background, $string );
$text->set_editable(TRUE);
$adj = new Gtk::Adjustment( $value,
$lower,
$upper,
$step_increment,
$page_increment,
$page_size );
$spin = new Gtk::SpinButton( $adjustment, $climb_rate, $digits );
The $climb_rate argument take a value between 0.0 and 1.0 and indicates the
amount of acceleration that the Spin Button has. The $digits argument
specifies the number of decimal places to which the value will be displayed.
$spin->set_value( $value );
The current value of a Spin Button can be retrieved as either a floating point
or integer value with the following functions:
$spin->get_value_as_float();
$spin->get_value_as_int();
If you want to alter the value of a Spin Value relative to its current value,
then the following function can be used:
$spin->spin( forward => $increment );
$spin->spin( backward => $increment );
Il faudra comprendre ce que sont les ajustements.
Menus
http://personal.riverusers.com/~swilhelm/gtkperl-tutorial/menu.html
$style = $window->get_style()->bg( 'normal' );
( $pixmap, $mask ) = Gtk::Gdk::Pixmap->create_from_xpm_d( $window->window,
$style,
@xpm_data );
# a pixmap widget to contain the pixmap
$pixmapwid = new Gtk::Pixmap( $pixmap, $mask );
$pixmapwid->show();
# Or from a file :
gdkpixmap = Gtk::Gdk::Pixmap->create_from_xpm( $window,
$mask,
$transparant_color,
$filename );
$pixmap = new Gtk::Pixmap( $gdkpixmap, $mask );
Ils mettent souvent des
$window->signal_connect( "delete_event", sub { Gtk->exit( 0 ); } );Voici un autre exemple : une fenêtre dans laquelle on peut dessiner.
A FAIRE http://www-zeuthen.desy.de/computing/documentation/perl/gtkperl-tutorial/tut-56.html DESSIN
Liste des widgets
http://personal.riverusers.com/~swilhelm/gtkperl-tutorial/widget.html A FAIRE : donner des exemples.
Pour d'autres exemples, voir
http://personal.riverusers.com/~swilhelm/gtkperl-tutorial/
Voir aussi
http://mail.gnome.org/archives/gtk-perl-list/
Si on lit la documentation en C (il y en a beaucoup plus qu'en Perl), il faut la traduire en Perl, comme suit (les premières lignes sont en C, la dernière en Perl).
gtk_init(&argc, &argv);
use Gtk '-init';
GtkWidget *window;
window = gtk_window_new (GTK_WINDOW_TOPLEVEL);
my $window = new Gtk::Window;
button = gtk_button_new_with_label ("Hello World");
my $button = new Gtk::Button("Hello world");
gtk_signal_connect (GTK_OBJECT (button), "clicked",
GTK_SIGNAL_FUNC (hello), NULL);
$button->signal_connect("clicked", sub {Gtk->main_quit});
gtk_container_add (GTK_CONTAINER (window), button);
$window->add($button);
gtk_widget_show (button);
gtk_widget_show (window);
$window->show_all;
gtk_main ();
Gtk->main;
gtk_main_quit();
Gtk->main_quit;En particulier, je conseille la lecture de
http://www.gtk.org/tutorial
Glade est un cliquodrome en Gtk+ pour construire des cliquodromes en Gtk+, dans des langages très variés (C, C++, Ada, Perl, Eiffel).
perl -MCPAN -e 'install Glade::PerlProject' glade &
Apparait un joli cliquodrome, qui nous permet de construire l'interface à la souris. n demande ensuite à glade d'écrire le code source du projet (en fait, glade se contente de créer un fichier XML qui est ensuite donné à Glade::PerlGenerate, qui le convertit en Perl. Il faut ensuite remplir les blancs dans le code ainsi généré.
A FAIRE
C'est un autre ensemble de Widguètes, comme Tk ou Gtk. Il marche aussi sous OuineDoze. Il existe un cliquodrome à construire des cliquodromes commercial : wxDesigner.
A l'heure où j'écris ces lignes, il n'existe pas de module Perl pour utiliser la bibliothèque Qt (c'est un ensemble de Widguètes, comme Tk, Gtk ou Wx) -- enfin si, il y en a un, mais il n'est plus maintenu et est devenu obsolète.
Septembre 2002 : PerlQt3 vient de sortir.
Encore des Widguètes portables (Unix/Windoze) pour Perl, avec bien sûr un cliquodrome à construire des cliquodromes).
http://www.prima.eu.org/ http://www.prima.eu.org/conf/PRIMA_1200.ps.gz
A n'utiliser que si l'on sait ce que l'on fait -- j'ai par exemple déjà entendu des gens suggérer d'utiliser X11::Protocol pour simuler l'utilisation d'un cliquodrome.
Pour faire des interfaces utilisateurs (avec des boites de dialogue, des menus déroulants et tout et tout) en mode texte. La page de manuel se termine par un tutoriel, donc je n'en dis pas plus.
Pour faire des dessins (png, par exemple).
Il y a un exemple ici (pas le premier morceau de code, qui fait de l'art ASCII, mais le troisième).
http://www.perlmonks.org/index.pl?node_id=189941
Pour faire des graphes, au format PNG. Prenons par exemple les logs de
http://crookshanks.free.fr/dvdhk/
dont les lignes ont le format suivant.
Mozilla/4.0 (compatible; MSIE 6.0; Windows 98; Wanadoo 5.3)£80.11.211.90£80.11.211.90£POST£action=search£/crookshanks.free.fr/dvdhk/index.php3?action=search£2002-02-25 14:21:53£gundam£
Comme séparateur, j'ai choisi un caractère inutilisé : £.
On peut par exemple représenter dans un camembert les différents systèmes d'exploitation.
cut -d£ -f 1 log |
perl -n -e 'm/((Win|Lin|Mac).*?)[\);]/ && print "$1\n"' |
sort | uniq -c |
perl 1.pl
#! perl -w
use strict;
use GD::Graph::pie;
my @labels;
my @values;
while(<>) {
next unless m#^\s*(.+?)\s+(.+)#;
push @labels, $2;
push @values, $1;
}
my @data = ( [@labels], [@values] );
my $graph = GD::Graph::pie->new(400,400);
$graph->set(
start_angle => 90,
'3d' => 0,
label => 'OS',
);
my $gd = $graph->plot(\@data);
open(PNG, '>', "gd1.png") || die "Cannot write to 1.png: $!";
print PNG $gd->png;
close PNG;
Les fontes sont un peu trop petites.
#! perl -w
use strict;
use GD::Graph::pie;
my @labels;
my @values;
while(<>) {
next unless m#^\s*(.+?)\s+(.+)#;
push @labels, $2;
push @values, $1;
}
my @data = ( [@labels], [@values] );
my $graph = GD::Graph::pie->new(400,400);
$graph->set(
start_angle => 90,
'3d' => 0,
label => 'OS',
transparent => 0,
);
$graph->set_value_font(GD::Font->Giant);
my $gd = $graph->plot(\@data);
open(PNG, '>', "gd2.png") || die "Cannot write to 1.png: $!";
print PNG $gd->png;
close PNG;
On peut préférer un camembert tridimensionnel.
#! perl -w
use strict;
use GD::Graph::pie;
my @labels;
my @values;
while(<>) {
next unless m#^\s*(.+?)\s+(.+)#;
push @labels, $2;
push @values, $1;
}
my @data = ( [@labels], [@values] );
my $graph = GD::Graph::pie->new(600,400);
$graph->set(
start_angle => 90,
label => 'OS',
transparent => 0,
);
$graph->set_value_font(GD::Font->Giant);
my $gd = $graph->plot(\@data);
open(PNG, '>', "gd2bis.png") || die "Cannot write to 2bis.png: $!";
print PNG $gd->png;
close PNG;
On peut aussi représenter le nombre de visiteurs en fonction de l'heure de la journée.
cut -d£ -f 7 log |
perl -n -e 'm#^.+?\s+([0-9]+?):# && print "$1\n"' |
sort -n | uniq -c | perl 1.pl
#! perl -w
use strict;
use GD::Graph::bars;
my @labels = (0..23);
my @values = map {0} @labels;
while(<>) {
next unless m#^\s*(.+?)\s+(.+)#;
$values[$2] = $1;
}
my @data = ( [@labels], [@values] );
my $graph = GD::Graph::bars->new(600,400);
$graph->set(
x_label => 'Heure',
y_label => 'Nombre de visiteurs',
title => 'Affluence selon l\'heure de la journée',
# shadows
bar_spacing => 8,
shadow_depth => 4,
shadowclr => 'dred',
transparent => 0,
) ;
my $gd = $graph->plot(\@data);
open(PNG, '>', "gd3.png") || die "Cannot write to 3.png: $!";
print PNG $gd->png;
close PNG;
Ou en fonction du jour de la semaine.
#! perl -w
use strict;
use Date::Calc qw(Parse_Date Day_of_Week);
use GD::Graph::bars;
my @labels = qw(Lundi Mardi Mercredi Jeudi Vendredi Samedi Dimanche);
my @values = map {0} @labels;
while(<>) {
my $date = (split('£'))[6];
$date =~ m#([0-9]*)-([0-9]*)-([0-9]*)#;
my ($year,$month,$day) = ($1, $2, $3);
my $dow = Day_of_Week($year, $month, $day);
$values[$dow-1]++;
}
my @data = ( [@labels], [@values] );
my $graph = GD::Graph::bars->new(600,400);
$graph->set(
x_label => 'Jour de la semaine',
y_label => 'Nombre de visiteurs',
title => 'Affluence selon le jour de la semaine',
# shadows
bar_spacing => 8,
shadow_depth => 4,
shadowclr => 'dred',
transparent => 0,
) ;
my $gd = $graph->plot(\@data);
open(PNG, '>', "gd4.png") || die "Cannot write to 4.png: $!";
print PNG $gd->png;
close PNG;(Comme le dessin a été fait un peu plus de 24 heures après la création du log, le graphe est un peu vide...)
Pour récupérer la taille d'une image.
use Image::Size;
($x,$y) = imgsize("image.gif");
($x,$y) = imgsize("image.jpg");Par exemple, pour rajouter la taille des images dans un fichier HTML.
#! perl -w
use strict;
package MyParser;
use base 'HTML::Parser';
use Image::Size;
sub start {
my($self, $tagname, $attr, $attrseq, $origtext) = @_;
if( $tagname eq 'img' ){
my ($x, $y) = imgsize($attr->{src});
$attr->{width} = $x if $x;
$attr->{height} = $y if $y;
print '<img ';
foreach my $a (keys %$attr){
print "$a=\"$attr->{$a}\" ";
}
print '>';
} else {
print $origtext;
}
}
sub end {
my($self, $tagname, $attr, $attrseq, $origtext) = @_;
print "</$tagname>";
}
sub text {
my($self, $origtext, $is_cdata) = @_;
print $origtext;
}
package main;
my $p = MyParser->new();
$p->parse_file("index.html");
SVG est un schéma XML permettant de décrire des dessins vectoriels, éventuellement avec des animations ou des interactions avec l'utilisateur (décrites en JavaScript).
http://www.xml.com/pub/a/2002/03/27/svg-tips-tricks.html http://roasp.com/tutorial/index.shtml
Voici un exemple :
#! perl -w
use strict;
use SVG;
my $svg = SVG->new(width=>200,height=>200);
$svg->comment('A circle');
$svg->circle(id=>'first_circle',
cx=>100, cy=>100, r=>50,
stroke=>'red', fill=>'green');
$svg->comment('A group');
my %group_style = (
'opacity'=>1,fill=>'red',
'stroke'=>'green','fill-opacity'=>0.4,
'stroke-opacity'=>'1');
my $gp1 = $svg->group(id=>'group_1',style=>\%group_style);
$gp1->comment('Another group...');
my $a1 = $gp1->anchor(-href=>'www.w3c.org');
$a1->circle(id=>'this_circle',cx=>170,cy=>100,r=>20);
$a1->circle(id=>'that_circle',cx=>100,cy=>170,r=>20);
$a1->circle(id=>'the_other_circle',
cx=>180,cy=>160,r=>20,
style=>{stroke=>'cyan'});
$svg->comment('Some text');
$svg->text(x=>80,y=>20)->cdata('Foo bar');
print $svg->xmlify;Les messages d'erreur bénins sont inclus dans le XML produit :
<a errors="that_circle Already Defined in document :
Illegally re-using ID that_circle in element
object SVG::Element=HASH(0x8187880)"
xlink:href="www.w3c.org">Il est aussi possible de faire des animations (ici, on change des paramètres numériques, mais on peut aussi changer les couleurs).
my $an_ellipse = $svg->ellipse( cx=>30,cy=>150, rx=>10,ry=>10, id=>'an_ellipse', stroke=>'rgb(130,220,70)', fill=>'rgb(30,20,50)', ); $an_ellipse-> animate( attributeName=>"ry", values=>"30;50;10;20;70;150;30", dur=>"15s", repeatDur=>'indefinite', ); $an_ellipse-> animate( attributeName=>"rx", values=>"30;75;10;100;80;20;120;30", dur=>"20s", repeatDur=>'indefinite', );
Il est même possible de rajouter des moreceaux de JavaScript pour réagir aux actions de l'utilisateur (par exemple, modifier telle ou telle chose quand la souris passe à tel endroit, ou quand l'utilisateur clique à tel autre endroit).
Ce module permet de faire des manipulations un peu plus complexes avec des images. On pourrait par exemple réécrire l'exemple précédent en remplaçant Image::Size par Image::Magick.
($width, $height, $size, $format) = Image::Magick->Ping('logo.png');De manière surprenante, perldoc Image::Magick est très laconique et renvoie à
http://www.simplesystems.org/ImageMagick/www/perl.html http://www.imagemagick.org/
Toutes les manipulations qui suivent sont probablement très faciles à réaliser directement en shell.
Ajouter du texte sur une image :
#! perl -w
use strict;
use Image::Magick;
my $image = new Image::Magick;
$image->Read("chateau.jpg");
$image->Annotate(x => 50, y => 50,
font => 'comic.ttf',
pointsize => 40,
fill => 'red',
text => 'Hello World!');
$image->Write("chateau2.jpg");On peut préférer centrer ce texte.
#! perl -w
use strict;
use Image::Magick;
my $image = new Image::Magick;
$image->Read("chateau.jpg");
my @parameters = (font => 'comic.ttf',
pointsize => 40,
fill => 'red',
text => 'Hello World!');
my ($x_ppem, $y_ppem, $ascender, $descender,
$w, $h, $max_advance) =
$image->QueryFontMetrics(@parameters);
my ($width, $height) = $image->Get(qw(width height));
$image->Annotate(x => ($width - $w)/2,
y => ($height - $h)/2 + $ascender,
@parameters);
# La commande Display affiche l'image à l'écran
# (sans la sauver).
$image->Display;
Modifier la correction gamma d'une image
$image->Gamma(gamma => 3);
La méthode Resize permet de changer la taille d'une image.
La méthode composite permet de mélanger deux images.
#! perl -w
use strict;
use Image::Magick;
sub min ($$) { $_[0]<$_[1] ? $_[0] : $_[1] }
# Première image
my $image = new Image::Magick;
$image->Read("small_castle.jpg");
# Deuxième image
my ($w,$h) = $image->Get(qw(width height));
my $r = 20;
my $circle = new Image::Magick(size => $w ."x". $h);
$circle->ReadImage('xc:white');
$circle->Draw(qw(primitive circle fill blue),
points => ($w/2-$r) .','. ($h/2-$r) ." ".
($w/2+$r) .','. ($h/2+$r));
# Superposition
$image->Composite(qw(Compose Multiply), Image => $circle);
$image->Display;
C'est un module permettant d'accéder aux fonctionnalités de The Gimp, un logiciel de dessin (bitmap) ou de retouche d'image.
http://gimp-savvy.com/BOOK/
Un programme utilisant ce module pourra être interactif (ouvrir une fenêtre pour poser des questions à l'utilisateur) ou non (fonctionner uniquement en ligne de commande).
Voici un exemple
#! /share/nfs/users1/umr-tge/zoonek/gnu/Linux/bin/perl -w
use strict;
use Gimp;
use Gimp::Fu;
use Gimp::Util;
#Gimp::set_trace(TRACE_ALL);
sub max ($$) {
my ($a, $b) = @_;
return $a > $b ? $a : $b;
}
register
"recolle",
"Recolle deux images",
"Ce script prend en argument deux images JPEG et retourne une image obtenue en mettant ces deux images côte à côte",
"Vincent Zoonekynd",
"zoonek\@math.jussieu.fr",
"0.1",
"<Toolbox>/Xtns/Essais/recolle",
"",
[
[PF_STRING, "fichier", "fichier (JPEG) contenant l'image de gauche"],
[PF_STRING, "fichier", "fichier (JPEG) contenant l'image de droite"],
[PF_STRING, "fichier", "fichier (JPEG) qui contiendra le résultat", "resultat.jpg"],
],
sub {
my ($file_left, $file_right, $resultat) = @_;
# Lecture des fichiers
my $left = Gimp->file_jpeg_load($file_left, $file_left);
my $left_layer = $left->get_layers;
my $right = Gimp->file_jpeg_load($file_right, $file_right);
my $right_layer = $right->get_layers;
# Création d'une nouvelle image
my $image = new Image( $left->width + $right->width,
max($left->height, $right->height),
RGB);
my $background = $image->layer_new($image->width, $image->height,
RGB_IMAGE,
"Background",
100, NORMAL_MODE);
$image->add_layer($background, 0);
$background->drawable_fill(BG_IMAGE_FILL);
# Copie des deux fichiers dans la nouvelle image
# (si on ne précise pas d'offset, l'image des centrée)
$left_layer->edit_copy();
my $a = $background->edit_paste(0);
$a->set_offsets(0, 0);
$a->anchor;
$right_layer->edit_copy();
my $b = $background->edit_paste(0);
$b->set_offsets($left->width, 0);
$b->anchor;
# Sauvegarde du fichier
my $flat = $image->flatten;
$flat->file_jpeg_save($resultat, $resultat, .75, 1, 1, 1,
"Created with the Gimp",
0,1,0,0);
};
# Ne pas oublier cette dernière ligne...
exit main;Pour plus de détails, voir
http://www.math.jussieu.fr/~zoonek/UNIX/23_perl_gimp/GIMP.html
Ce module permet d'accéder à la bibliothèque SDL (Simple Direct Layer), permettant, entres autres, de faire des jeux (de d'autres applicatios qui ont besoin de graphisme, d'animations ou de son). L'exemple typique est Frozen Bubble :
http://www.frozen-bubble.org/
Il y a quelques exemples ici, mais aucun ne fonctionne (pourquoi ?) :
http://www.pegasys.org.uk/download.html
Pour des exemples qui marchent, regardons dans le répertoire test/.
Quand j'essaye de l'utiliser moi-même, j'obtient des messages d'erreur du genre
perl: relocation error: /usr/lib/libmcop.so.0: undefined symbol: internalFreeAll__Q24Arts14StartupManager
Comme je n'arrive pas à l'utiliser, je ne donne pas d'exemple (mais jouez à Frozen Bubble !).
Pour effectuer des calculs sur des dates.
use Date::Calc qw(Delta_Days Today); $delta = Delta_Days($y,$m,$d, Today());
Pour convertir une chaine de caractères en une date.
use Date::Manip; my $date = "wed nov 28 12:38:33 CET 2001"; $date = ParseDate($date); die "Error in date" unless $date; $date =~ s#^(....)(..)(..)(..):(..):(..)#$1/$2/$3 $4:$5:$6#; print "$date\n";
Il peut être nécessaire de préciser le fuseau horaire par défaut.
use Date::Manip;
Date::Manip::Date_Init("TZ=+01:00");
my $date = "wed nov 28 12:38:33 CET 2001";
$date = ParseDate($date);
die "Error in date" unless $date;
$date =~ s#^(....)(..)(..)(..):(..):(..)#$1/$2/$3 $4:$5:$6#;
print "$date\n";
Si on a besoin des fonctions d'arrondi floor et ceil.
use POSIX;
sub arrondi {
my $a = shift;
return POSIX::ceil(100*$a-.5)*.01;
}ou :
use POSIQ qw(ceil);
sub arrondi {
my $a = shift;
return ceil(100*$a-.5)*.01;
}
Pour lire un fichier HTML (chaque balise ouvrante ou fermante correspond à un évènement : c'est exactement comme la programmation évènementielle sous X, ou SAX).
package MyParser;
use base 'HTML::Parser';
sub start {
my($self, $tagname, $attr, $attrseq, $origtext) = @_;
print "START tag=$tagname\n";
print " attr ";
foreach my $a (keys %$attr){
print "$a=$attr->{$a} ";
}
print "\n";
print " attrseq ";
foreach my $a (@$attrseq){
print "$a ";
}
print "\n";
print " origtext=$origtext\n";
}
sub end {
my($self, $tagname, $origtext) = @_;
print "END tag=$tagname origtext=$origtext\n";
}
sub text {
my($self, $origtext, $is_cdata) = @_;
}
package main;
my $p = MyParser->new();
$p->parse_file("index.html");On peut aussi lui donner une chaine de caractères
use HTTP::Request::Common; use LWP::UserAgent; my $ua = LWP::UserAgent->new; my $answer = $ua->request(GET $url)->content; my $p = MyParser->new(); $p->parse($answer); $p->eof;
Ce module permet de récupérer les liens présents dans une page HTML.
#! perl -w
use strict;
use Aspi;
use HTML::LinkExtor;
my $base = "http://www.perlmonks.org";
my $url = $base;
my $p = HTML::LinkExtor->new(\&cb, $base);
sub cb {
my($tag, %links) = @_;
print "$tag @{[%links]}\n";
}
$p->parse(get($url));Si on veut juste les URLs :
#! perl -w
use strict;
use Aspi;
use HTML::LinkExtor;
my $base = "http://www.perlmonks.org";
my $url = $base;
my $p = HTML::LinkExtor->new(\&cb, $base);
sub cb {
my($tag, %links) = @_;
foreach my $k (keys %links){
print "$links{$k}\n";
}
}
$p->parse_file("index.html");
Pour se promener dans un fichier HTML, représenté sous forme d'un arbre (comme avec DOM).
Pour convertir du HTML en texte. (sans tenir compte des tables ou des formulaires).
Pour formatter du texte (on dit de manière laconique qu'il faut justifier un paragraphe, center un autre, etc.). Ca me fait presque penser à la commande format, qui venait du Fortran et qui existait encore sous Perl4. (Je viens de vérifier : elle existe toujours dans Perl5...)
Convertir le format Wiki en HTML. Voici un exemple de texte sous ce format.
Certains ''mots'' sont en ''italique'',
d'autres sont en '''gras'''.
Voici une ligne horizontale :
----
Ceci est un [lien|Lien].
Ceci est EncoreUnLien (un mot avec plusieures majuscules).
Voici une énumération (chaque ligne commence par 4 espaces
ou une tabulation).
* Bla bla bla
bla bla bla bla ;
* Bla bla bla bla
bla bla bla...
Le texte indenté est considéré comme du code.
#! perl -w
use strict;
$|++;
...
Pour décoder du base64
use MIME::Base64; print decode_base64($mail);
Pour décoder du quoted printable
use MIME::QuotedPrint; print decode_qp($mail);
On a de même des fonctions encode_base64 et encode_qp.
Ensemble de modules pour lire et écrire au format MIME (c'est par exemple le format utilisé pour les pièces jointes dans le courrier électronique).
Morceaux de MIME::Tools permettant de lire, de manipuler ou d'écrire des fichiers MIME.
Voici un exemple qui regarde si le message contient uniquement du HTML (on pourrait l'utiliser avec Mail::Filter pour reconnaitre du spam, par exemple).
A FAIRE : exemple
Voici un exemple qui regarde si le message contient deux parties équivalentes, l'une en HTML, l'autre en texte, et qui enlève le HTML.
#!/usr/bin/perl -w
use strict;
$|++;
my $envelope = <STDIN>;
use MIME::Parser;
use MIME::Entity;
my $parser = MIME::Parser->new;
$parser->output_to_core(1);
$parser->tmp_to_core(1);
my $ent = eval { $parser->parse(\*STDIN) };
die "$@" if $@;
if ($ent->effective_type eq "multipart/alternative"
and $ent->parts == 2
and $ent->parts(0)->effective_type eq "text/plain"
and $ent->parts(1)->effective_type eq "text/html") {
my $newent = MIME::Entity->build(Data =>
$ent->parts(0)->body_as_string .
"\n\n[[HTML alternate version deleted]]\n");
$ent->parts([$newent]);
$ent->make_singlepart;
$ent->sync_headers(Length => 'COMPUTE',
Nonstandard => 'ERASE');
}
print $envelope;
$ent->print;J'ai volé cet exemple ici :
http://www.perlmonks.org/index.pl?node_id=53404
Pour d'autres exemples :
http://www.google.fr/search?hl=fr&lr=&ie=UTF-8&oe=UTF8&q=MIME::Parser++site:perlmonks.thepen.com+perlmonks
Pour envoyer du mail
use Mail::Mailer qw(mail); $mailer = new Mail::Mailer; $mailer = new Mail::Mailer $type, @args; my %headers = (Subject=>'example subject', To=>'timbo'); $mailer->open(\%headers); my $body = ...; print $mailer $body; $mailer->close;
On peut préciser la manière d'envoyer le courrier : à l'aide de la commande mail, avec sendmail, ou directement par SMTP.
Interface à Mail::Mailer.
Ces modules permettent de récupérer (ou de manipuler) du courrier électronique sur un serveur POP3 ou IMAP.
A FAIRE : exemple
Rappelons quelques uns des protocoles utilisés lors de la transmision du courrier électronique.
SMTP (Simple Mail Transfer Protocol) est utilisé quand on envoie un courrier, entre la machine devant laquelle on est et la machine qui gère le courrier électronique du destinataire.
POP (Post Office Protocol) est utilisé entre la machine qui gère le courrier du destinataire et la machine devant laquelle le destinataire se trouve. Il en existe deux versions, POP2 (qui date des années 80) et POP3.
IMAP4 (Internet Message Access Protocol) assure le même rôle que POP3, avec quelques fonctionnalités supplémentaires. La principale différence, c'est que POP transfère les messages sur la machine du destinataire, alors qu'IMAP les laisse sur le serveur.
POPS, c'est simplement POP au dessus de SSL (SSL désigne les comunications cryptées, exactement comme pour les sites web en https://). Par défaut, POP ou IMAP font tout circuler en clair, messages comme mots de passe.
Pendant que nous y sommes, complétons la liste des sigles.
MUA (Mail User Agent) : le logiciel qu'on utilise pour lire son courrier électronique, par exemple Gnus, mutt, pine, Evolution, Sylpheed.
MTA (Mail Transfert Agent) : c'est le programme qui se charge de gérer la réception du courrier électronique, en particulier de le répartir dans les boites aux lettres des différens utilisateurs, par exemple Sendmail, Exim, Postfix, qmail.
Module pour manipuler des messages au format du courrier électronique (RFC 822).
Voir Mail::Box, MIME::Parser.
Jabber est un protocole de messagerie instatannée (IM). Si j'ai bien compris, la messagerie instantannée, c'est un mélange d'IRC et de courrier électronique. Pour mieux comprendre, essayons d'utiliser un client Jabber, par exemple gabber.
http://www.saint-andre.com/jabber/userguide/
Je crois que je comprends : l'IM (Instant Messaging), c'est comme le courrier électronique, sauf que le message n'arrive que si le destinataire est connecté -- sinon, on nous dit qu'il est absent. Par contre, s'il est présent, on peut continuer la discussion, directement, comme avec la commande talk.
En corollaire, Jabber permet de savoir si quelqu'est est joignable ou pas. (Sur la plupart des clients Jabber, on peut définir une liste de contacts, et à chaque fois qu'on se connecte, on voit qui est en ligne.)
D'autre part, Jabber permet des discussions à plusieurs, exactement comme avec IRC. Il peut s'agir de discussions publiques, ou de conférences privées.
Il y a aussi un annuaire, permettant de trouver la personne que l'on désire contacter, si on connait juste son nom.
Il existe des passerelles pour communiquer, depuis Jabber, avec des gens qui utilisent IRC, AIM, ICQ ou Yahoo Messenger (elles ne sont peut-être pas toutes très stables).
Enfin, les communications s'effectuent en XML.
Il est possible de crypter les communications (avec SSL).
Je n'ai pas très bien compris si on pouvait transférer des fichiers, comme avec IRC.
http://www.openp2p.com/lpt/a//p2p/2002/02/08/chatbot_two.html http://www.openp2p.com/lpt/a//p2p/2002/01/11/jabber_bots.html http://sourceforge.net/projects/chatbot/ http://webreference.com/perl/tutorial/13/ http://www.oreilly.com/catalog/jabber/chapter/ch05.html
Le module Net::Jabber permet d'écrire facilement des clients Jabber, par exemple à l'intérieur d'un site Web (pour informer le responsable de tel ou tel changement).
Interface à AIM (AOL Instant Messaging).
http://webreference.com/perl/tutorial/13/
Pour que plusieurs programmes (par exemple, le même, forké une dizaine de fois) puissent écrire dans le même fichier (un fichier de log), en même temps, on peut procéder ainsi.
use POSIX ":sys_wait_h"; # As the man page says... use Fcntl ':flock'; # import LOCK_* constants open(DONE, ">>$file") || die "cannot open $file for appending: $!"; flock(DONE,LOCK_EX); seek(DONE, 0, 2); select DONE; print ...; $|=1; # flush select STDOUT; flock(DONE,LOCK_UN); close DONE;
Si certaines parties de notre programme sont trop lentes, on peut vouloir les réécrire en C (ou dans un autre langage, si on est masochiste -- ou si on sous-traite ce travail). C'est possible, mais je n'ai pas d'exemple pertinent : voici celui du manuel.
#! perl -w
use Inline C;
greet('Ingy');
greet(42);
__END__
__C__
void greet(char* name) {
printf("Hello %s!\n", name);
}On peut aussi utiliser ce module pour accéder aux fonctions d'une bibliothèque en C (mais là non plus, je n'ai pas d'exemple pertinent).
On peut aussi utiliser Inline en conjonction avec PDL (voir plus loin).
Pour de plus amples renseignements, des exemples plus concrets et plus complexes (par exemples, sur la manipulation des listes ou des tables de hachage en C), voir :
perldoc Inline::C-Cookbook
PDL permet d'utiliser Perl pour manipuler des tableaux de nombres, à la matlab.
#! perl -w use PDL; use PDL::Math; use constant WIDTH => 10; use constant HEIGHT => 10; use constant LEFT => -2; use constant RIGHT => 2; use constant TOP => 2; use constant BOTTOM => -2; my $x = LEFT + (RIGHT - LEFT)/WIDTH *(xvals zeroes(WIDTH+1,HEIGHT+1)); my $y = BOTTOM + (TOP - BOTTOM)/HEIGHT*(yvals zeroes(WIDTH+1,HEIGHT+1)); my $z = sin($x) * cos($y); $z = .1*floor(10*$z); print "$z\n";
Ce qui donne :
[ [ 0.3 0.4 0.3 0.2 0.1 -0 -0.2 -0.3 -0.4 -0.5 -0.4] [ 0 0 0 0 0 -0 -0.1 -0.1 -0.1 -0.1 -0.1] [-0.4 -0.4 -0.4 -0.3 -0.2 0 0.1 0.2 0.3 0.3 0.3] [-0.7 -0.7 -0.7 -0.5 -0.3 0 0.2 0.4 0.6 0.6 0.6] [-0.9 -1 -0.9 -0.7 -0.4 0 0.3 0.6 0.8 0.9 0.8] [ -1 -1 -1 -0.8 -0.4 0 0.3 0.7 0.9 0.9 0.9] [-0.9 -1 -0.9 -0.7 -0.4 0 0.3 0.6 0.8 0.9 0.8] [-0.7 -0.7 -0.7 -0.5 -0.3 0 0.2 0.4 0.6 0.6 0.6] [-0.4 -0.4 -0.4 -0.3 -0.2 0 0.1 0.2 0.3 0.3 0.3] [ 0 0 0 0 0 -0 -0.1 -0.1 -0.1 -0.1 -0.1] [ 0.3 0.4 0.3 0.2 0.1 -0 -0.2 -0.3 -0.4 -0.5 -0.4] ]
Il y a d'innombrables fonctions graphiques. Pour les tester, on peut utiliser le "shell" de PDL, perldl, et taper 'demo'.
perlDL shell v1.31 PDL comes with ABSOLUTELY NO WARRANTY. For details, see the file 'COPYING' in the PDL distribution. This is free software and you are welcome to redistribute it under certain conditions, see the same file for details. ReadLines, NiceSlice enabled Reading PDL/default.perldlrc... Found docs database /share/nfs/users1/umr-tge/zoonek/gnu/Linux/lib/perl5/site_perl/5.6.1/i686-linux/PDL/pdldoc.db Type 'help' for online help Type 'demo' for online demos Loaded PDL v2.3.2 perldl>
On peut l'utiliser directement pour faire des dessins. Voici par exemple les exposants de Lyapunov du système dynamique
z_2n+1 = x * z_2n * (1-x_2n) z_2n+2 = y * z_2n+1 * (1-x_2n+1) URL A FAIRE DESSIN
On peut être ammené à écrire ses propres fonctions, en pseudo-C, à l'aide du module Inline.
Voici par exemple une fonction (inutile) qui incrémente son argument d'une unité. L'argument Pars est la signature de la fonction (ici, elle prend un argument $i (à n dimensions) et retourne un argument $o à autant de dimensions) ; l'argument Code est le code en pseudo-C.
#! perl -w
use PDL;
use Inline Pdlpp;
$a = sequence 10;
print "$a\n";
print $a->inc ."\n";
# On n'est pas obligé d'utiliser la syntaxe orientée objets :
$a = pdl [ [1, 2, 3], [4, 5, 6] ];
print PDL::inc($a) ."\n";
__DATA__
__Pdlpp__
pp_def('inc',
Pars => 'i();[o] o()',
Code => '$o() = $i() + 1;',
);Voici une fonction qui fait la somme des éléments dans une dimension (une telle fonction existe déjà, elle s'appelle sumover)
#! perl -w
use PDL;
use Inline Pdlpp;
$a = sequence 10;
print "$a\n";
print $a->doit ."\n";
$a = pdl [ [1, 2, 3], [4, 5, 6] ];
print "$a\n";
print PDL::doit($a) ."\n";
__DATA__
__Pdlpp__
pp_def('doit',
Pars => 'i(n);[o] o()',
Code => '$o()=0; loop(n) %{ $o() += $i(); %}',
);Le résultat :
[0 1 2 3 4 5 6 7 8 9] 45 [ [1 2 3] [4 5 6] ] [6 15]
Voici un exemple plus compliqué, qui dessine des fractales. Pour PDL, un nombre complexe, c'est juste un piddle à deux éléments. Pour avoir la signature de notre fonction, on regarde simplement dans le manuel de PDL::Complex, pour savoir comment accéder aux parties réelle et imaginaire, on regarde dans le source, par exemple dans Basic/Complex/complex.pd).
Tout d'abord l'ensemble de Manderbrot.
#! perl -w
# http://hypertextbook.com/chaos/
use strict;
use PDL;
use PDL::Math; # floor
use PDL::Complex;
use Inline 'Pdlpp';
use PDL::Graphics::TriD;
use PDL::Graphics::TriD::Image;
use PDL::IO::Pic;
use constant COULEURS => 256;
sub compute {
my ($c, $left, $right, $width, $bottom, $top, $height) = @_;
my $z = $left + ($right - $left)/$width *(xvals zeroes($width+1,$height+1))
+ i * ( $bottom + ($top - $bottom)/$height*(yvals zeroes($width+1,$height+1)) );
return real $z->mandel;
}
sub compute_palette {
my $z = shift;
my $values = $z->flat->qsort->uniq;
my $couleurs = 256;
return $values->reshape($values->nelem/$couleurs+1, $couleurs)
->slice('(0),:')
->qsort;
}
sub compute_picture {
my ($r, $g, $b);
my $z = shift;
my $values = shift;
$r = 1-$z->my_index($values)/COULEURS;
$r = 1.5*$r;
$g = .5*(1-cos(11*$r));
$b = .5*(1-cos(7*$r));
$r = .5*(1-cos(5*$r));
return [$r,$g,$b];
}
my $c = .3 - i;
my @lim = (-2.5,1,500, -2,2,500);
my $z = compute($c, @lim);
my $palette = compute_palette($z);
my $img = cat @{ compute_picture($z, $palette) };
$img = $img->xchg(0,2)->xchg(1,2);
$img->wpic('mandel.gif');
imagrgb( compute_picture($z, $palette) );
__DATA__
__Pdlpp__
pp_def('mandel',
Pars => 'a(m=2); [o] b()',
Code => '
double x=$a(m=>0);
double y=$a(m=>1);
double tmp;
#define doit tmp = x*x - y*y + $a(m=>0); y = 2*x*y + $a(m=>1); x = tmp;
doit; doit; doit; doit; doit; doit; doit; doit; doit; doit;
$b() = x*x + y*y;
');
pp_def('my_index',
Pars => 'a(); b(n); [o] c()',
Code => '
int avant = 0;
int apres = $SIZE(n)-1;
while(apres-avant>1){
int milieu = (avant+apres)/2;
if($a()>$b(n=>milieu)){ avant=milieu; }
else{ apres=milieu; }
}
$c()=avant;
');
Ensuite, l'ensemble de Julia.
#! perl -w
# http://hypertextbook.com/chaos/
use strict;
use PDL;
use PDL::Math; # floor
use PDL::Complex;
use Inline 'Pdlpp';
# Pour visualiser le dessin
use PDL::Graphics::TriD;
use PDL::Graphics::TriD::Image;
# Pour le sauvegarder
use PDL::IO::Pic;
use constant COULEURS => 256;
sub compute {
my ($c, $left, $right, $width, $bottom, $top, $height) = @_;
my $z = $left + ($right - $left)/$width *(xvals zeroes($width+1,$height+1))
+ i * ( $bottom + ($top - $bottom)/$height*(yvals zeroes($width+1,$height+1)) );
return real $z->julia(pdl $c);
}
sub compute_palette {
my $z = shift;
my $values = $z->flat->qsort->uniq;
my $couleurs = 256;
return $values->reshape($values->nelem/$couleurs+1, $couleurs)
->slice('(0),:')
->qsort;
}
sub compute_picture {
my ($r, $g, $b);
my $z = shift;
my $values = shift;
$r = 1-$z->my_index($values)/COULEURS;
$r = 1.5*$r;
$g = .5*(1-cos(11*$r));
$b = .5*(1-cos(7*$r));
$r = .5*(1-cos(5*$r));
return [$r,$g,$b];
}
my $c = .3 - i;
my @lim = (-2,2,500, -2,2,500);
my $z = compute(.3 -.5*i, @lim);
my $palette = compute_palette($z);
my $img = cat @{ compute_picture($z, $palette) };
$img = $img->xchg(0,2)->xchg(1,2);
$img->wpic('julia.gif');
__DATA__
__Pdlpp__
pp_def('julia',
Pars => 'a(m=2); c(m=2); [o] b()',
Code => '
double x=$a(m=>0);
double y=$a(m=>1);
double tmp;
#define doit tmp = x*x - y*y + $c(m=>0); y = 2*x*y + $c(m=>1); x = tmp;
doit; doit; doit; doit; doit; doit; doit; doit; doit; doit;
$b() = x*x + y*y;
');
pp_def('my_index',
Pars => 'a(); b(n); [o] c()',
Code => '
int avant = 0;
int apres = $SIZE(n)-1;
while(apres-avant>1){
int milieu = (avant+apres)/2;
if($a()>$b(n=>milieu)){ avant=milieu; }
else{ apres=milieu; }
}
$c()=avant;
');
Il est aussi possible de lui demander d'afficher le résultat dans une fenetre.
for(my $i=1; $i<20; $i++){
$z = compute($c+i*.1*$i, @lim);
imagrgb( compute_picture($z, $palette) );
}On pourrait même lui demander de créer une animation et de la stocker dans un fichier *.mpg.
Attention, toutefois, les messages d'erreur lors de la compilation sont inexistants ou confus.
http://www.perlmonks.org/index.pl?node_id=179748
The main (only?) example of the use of piddles with Gimp is in
examples/map_to_gradient use Gimp::Feature 'pdl'; use Gimp 1.1; use Gimp::Fu; use PDL::LiteF;
On peut créer des piddles à partir des fonctions Gimp qui retournent des listes.
my $grad = pdl byte, map $_*255, @{(Gimp->gradients_get_gradient_data($gradient,256))[1]};Pour les images, on peut procéder ainsi
my $src = new PixelRgn ($drawable,@bounds,0,0);
my $data = $src->data;
$data = $data->slice("0:-2") if $alpha; # get rid of alphaOn écrit un piddle dans une image ainsi :
my $dst = new PixelRgn ($drawable,@bounds,1,1); $dst->data( some piddle );
par exemple
$dst->data( index($grad,$data->dummy(0,$depth)) );
Ce module est une interface à http://www.graphviz.org/ un logiciel pour dessiner des graphes. (il faut faire attention lorsqu'on l'installe, il faut d'abord installer graphviz, i.e., dot et neato).
use GraphViz;
my $g = GraphViz->new();
$g->add_node('London');
$g->add_node('Paris', label => 'City of\nlurve');
$g->add_node('New York');
$g->add_edge('London' => 'Paris');
$g->add_edge('London' => 'New York', label => 'Far');
$g->add_edge('Paris' => 'London');
print $g->as_png;
Ce module permet de créer des graphes orientés ou non.
my $g = GraphViz->new(); # Orienté my $g = GraphViz->new(directed => 1); # Orienté my $g = GraphViz->new(directed => 0); # Non orienté
Le constructeur peut préciser, entre autres, la fonte par défaut, la forme des boites, etc.
my $g = GraphViz->new(node => {fontname => 'comic', shape => 'box'});Mais on peut aussi le préciser boite par boite.
$g->add_node("Foobar", shape => 'egg');
On peut même lui demander d'utiliser une fonte non latine (ici, la fonte True Type unicode Cyberbit ; le texte est tapé en UTF8). (A FAIRE : en fait, ça ne marche pas vraiment. Il faudrair que j'isole le bug et que j'envoie un rapport de bug.)
On peut aussi préciser la taille de la fonte (fontsize), la couleur (color), la couleur de remplissage (fillcolor), ou le style (il y a aussi un style invisible (invis) qui n'apparait pas clairement sur la figure suivante).
$g->add_node("FooBar",
style => 'filled',
fontsize => 24,
fillcolor => 'yellow',
color => 'red',
fontcolor => 'blue');
On dispose aussi de choix similaires pour les arrêtes (edges).
On peut aussi préciser la forme des flèches (arrowhead, arrowtail).
Les méthodes d'affichage du dessin final sont assez nombreuses, par exemple, as_ps, as_png ou as_svg.
Le module GraphViz::XML permet de visualiser des structures XML.
#! perl -w
use strict;
use GraphViz::XML;
my $xml = "<entry><a>...</a><b>...<c>...</c>...</b><a/></entry>";
my $g = GraphViz::XML->new($xml,
node => {fontname => 'cyberbit'});
print $g->as_png;
Voici un exemple moins trivial (un morceau de dictionnaire).
Un peu plus haut, nous avons utilisé le module Parse::RecDescent pour lire des fichiers BibTeX : on peut visualiser la grammaire que nous avons écrite de la manière suivante.
#! perl -w use strict; use GraphViz::Parse::RecDescent; my $grammar = q#...#; my $g = GraphViz::Parse::RecDescent->new($grammar); print $g->as_png;
Il y a d'autres modules pour visualiser des grammaires, GraphViz::Parse::Yapp et GraphViz::Parse::Yacc.
Le module GraphViz::ISA permet de visualiser les relations d'héritage (ça n'est pas vraiment de l'UML...).
#! perl -w use strict; use GraphViz::ISA; use Tk; my $object = MainWindow->new(); my $g = GraphViz::ISA->new($object); print $g->as_png;
Parmi les autres modules du même genre, signalon GraphViz::DBI, pour représenter graphiquement les liens (foreign keys) entre les différentes tables d'une base de données, GraphViz::Data::Dumper, qui représente graphiquement des structures de données complexes et Devel::GraphVizProf, qui est une interface graphique à Devel::SmallProf.
http://www.astray.com/graphing_perl/
Voir aussi MIDI::Score.
http://larsen.perlmonk.org/perl/mozart.html
Permet de récupérer ou de modifier les informations textuelles contenues dans un fichier MP3.
Par exemple, le programme
#! perl -w use strict; use MP3::Info; use Data::Dumper; my $file = "1.mp3"; my $tag = get_mp3tag($file); print Dumper($tag);
donne :
$VAR1 = {
'YEAR' => '2002',
'ARTIST' => 'Sakamoto Maaya',
'COMMENT' => 'RahXephon - Opening single',
'TRACKNUM' => '01',
'ALBUM' => 'Hemisphere (VICL-35358)',
'TITLE' => 'Hemisphere',
'GENRE' => '',
'TAGVERSION' => 'ID3v1.1 / ID3v2.3.0'
};
Interface à mpg123 (un lecteur de fichiers MP3).
Ce n'est pas un module, mais un programme externe. Un synthétiseur vocal. On peut l'utiliser pour avoir des messages d'erreur (ou de log) parlés, pour rendre Eliza un peu plus vivante, pour annoncer le titre des fichiers MP3 que l'on va entendre, etc.
http://www.cstr.ed.ac.uk/projects/festival/
En Perl, les objets (ou les variables) sont détruits quand ils ne sont plus référencés nulle part. Pour ce faire, Perl compte le nombre de références à chaque objet : quand il n'y en a plus, on peut l'effacer.
Une référence faible est une référence qui n'intervient pas dans ce compte. C'est utile pour éviter des fuites de mémoire avec certaines structures de données récursives (par exemple une table de hachage qui contient une référence vers elle-même).
D'autres langages de programmation n'on pas ce genre de problème, car ils utilisent des systèmes un peu plus complexes -- par exemple, Java, comme expliqué dans les livres de B. Eckels :
http://www.mindview.net/Books/TIJ/
Je n'ai jamais eu besoin de ce module.
On peut définir des macros sous Perl, ou même complètement changer la syntaxe du langage.
Voir Filter::Simple.
Comme Filter::Util::Call, en plus simple.
Exemple d'utilisation de Filter::Util::Call : on peut programmer commen en Python, sans mettre de point-virgule.
Un autre exemple d'utilisation de Filter::Util::Call : au lieu de mettre des *$%@\ devant les noms de variable, on peut _décliner_ (oui, oui, les déclinaisons latines que l'on apprenait au collège) les noms de variable. Les appels de fonction aussi, se déclinent (ou se conjuguent), les mots-clef du langage sont traduits en latin. Pire encore : les caractères non alphabétiques (du genre +;{}<>"' ) disparaissent !
http://www.csse.monash.edu.au/~damian/papers/HTML/Perligata.html
Damian donne l'exemple du crible d'Eratosthène :
#! /usr/local/bin/perl -w
use Lingua::Romana::Perligata;
maximum inquementum tum biguttam egresso scribe.
meo maximo vestibulo perlegamentum da.
da duo tum maximum conscribementa meis listis.
dum listis decapitamentum damentum nexto
fac sic
nextum tum novumversum scribe egresso.
lista sic hoc recidementum nextum cis vannementa da listis.
cis.Certaines personnes cherchent des "compilateurs" Perl, pour rendre leurs programmes illisibles : il serait peut-être plus efficace de les traduire en latin.
Encore un autre exemple d'utilisation de Filter::* : on peut désormais utiliser des commentaires sur plusieurs lignes, comme en C (en fait, on pouvait déjà, avec POD).
http://www.perl.com/pub/a/2002/08/13/comment.html
Encore un autre exemple d'utilisation de Filter::*, pour ajouter une instruction switch.
Efface le programme courrant pour le remplace par de l'ascii art. Le programme fonctionne toujours.
Voir Filter::Simple.
Efface le programme courrant (mais il fonctionne toujours : on a juste remplacé les caractères visibles par des caractères non imprimables).
Voir Filter::Simple.
Une application de Filter::Simple qui permet d'écrire des morceaux de programmes en Brainfuck (c'est un langage qui implémente une machine de Turing) pour ceux qui trouvent que le langage machine est un langage de beaucoup trop haut niveau, trop facile à lire.
http://www.perlmonks.org/index.pl?node_id=193742
Permet de mesurer des durées très brèves (moins d'une seconde), ou d'attendre (usleep) pendant une durée très brève.
use Time::HiRes qw(usleep ualarm gettimeofday tv_interval); $t0 = [gettimeofday]; ... $t1 = [gettimeofday]; print "It took ". tv_interval($t0, $t1) ." seconds\n";
Module pour profiler (?) un programme, i.e., pour savoir quelles sont les fonctions qui prennent le plus de temps, quelles sont les fonctions qu'il faudra optimiser.
perl -d.DProf 1.pl less tmon.out dprofpp dprofpp -T perldoc dprofpp
Module pour "profiler" un programme, non pas fonction par fonction, mais ligne par ligne.
% perl -d:SmallProf 1.pl % less smallprof.out % sort -k 2nr,2 smallprof.out | less
Ce module permet de savoir quelles sont les morceaux de code qui ne sont jamais exécutés.
% cat 0.pl
#! perl -w
use strict;
if(0<1){
print "OK\n";
} else {
print "KO\n";
}
% perl -d:Coverage 0.pl
% coverperl 0.pl.cvp
Total of 1 instrumentation runs.
/share/nfs/scratch/users/zoonek/spool/JUNK/0.pl
3 line 2
1 line 3
1 line 4
0 line 6On peut lancer le programme testé plusieures fois, les résultats s'additionneront.
Ce module permet de mesurer le temps pris par une fonction. Si la fonction s'exécute très rapidement, il va la lancer plusieurs (millions de) fois.
#! perl -w
use strict;
use Benchmark;
# Mesurer la vitesse d'une fonction
timethis(1e6, sub { my $t = 'aaa'; my $pat = '^\s*[abc]*\s*$'; $t =~ m/$pat/ });
# La vitesse de deux fonctions
timethese(1e6, {
A => sub { my $t = 'aaa'; my $pat = '^\s*[abc]*\s*$'; $t =~ m/$pat/ },
B => sub { my $t = 'aaa'; my $pat = '^\s*[abc]*\s*$'; $t =~ m/$pat/o },
});
# Pour un morceau de code, et plus pour une fonction
my $t0 = new Benchmark;
for(my $i=0; $i<1e6; $i++){
my $t = 'aaa'; my $pat = '^\s*[abc]*\s*$'; $t =~ m/$pat/;
}
my $t1 = new Benchmark;
my $td = timediff($t1, $t0);
print "the code took:",timestr($td),"\n";
# Si on n'a pas la moindre idée du temps que ça va mettre
timethis(0, sub {my $t = 'aaa'; my $pat = '^\s*[abc]*\s*$'; $t =~ m/$pat/;});Pour des mesures plus précises du temps, voir Time::HiRes.
Pour obtenir un exécutable.
Par exemple si on veut un exécutable binaire.
% perl -MO=C 0.pl > 0.c % perl cc_harness -o 0 0.c
Ca plante ??? Ca ne devrait pas planter. Mais si on tente de le recompiler à la main, ça finit par marcher.
% cc -fno-strict-aliasing -I/usr/local/include -D_LARGEFILE_SOURCE \
-D_FILE_OFFSET_BITS=64 \
-I/share/nfs/users1/umr-tge/zoonek/gnu/Linux/lib/perl5/5.6.1/i686-linux/CORE \
-o 0 0.c \
-L/usr/local/lib/share/nfs/users1/umr-tge/zoonek/gnu/Linux/lib/perl5/5.6.1/i686-linux/CORE/libperl.a \
-lnsl -lndbm -lgdbm -ldl -lm -lc -lcrypt -lutil
/tmp/ccLE7yfU.o: In function `xs_init':
/tmp/ccLE7yfU.o(.text+0x4e1): undefined reference to `boot_DynaLoader'
collect2: ld returned 1 exit status
% locate
% cp /usr/lib/perl5/5.6.0/i386-linux/auto/DynaLoader/DynaLoader.a .
% cp /scratch/users/zoonek/gnu_Linux/lib/perl5/5.6.1/i686-linux/CORE/libperl.a .
% cc -fno-strict-aliasing -I/usr/local/include -D_LARGEFILE_SOURCE \
-D_FILE_OFFSET_BITS=64 \
-I/share/nfs/users1/umr-tge/zoonek/gnu/Linux/lib/perl5/5.6.1/i686-linux/CORE \
-o 0 0.c \
libperl.a DynaLoader.a \
-lnsl -lndbm -lgdbm -ldl -lm -lc -lcrypt -lutil
% ./0De manière plus générale, le module O (comme Output), permet de transformer le programme. On peut par exemple le compiler en pseudo-code :
% perl -MO=Terse,exec 0.pl
OP (0x8184d90) enter
COP (0x8106cf0) nextstate
OP (0x8184dd0) pushmark
SVOP (0x8184db0) const PV (0x81038d0) "OK\n"
LISTOP (0x8184ce8) print
LISTOP (0x8106d28) leave [1]
% perl -MO=Debug 0.pl
LISTOP (0x8199018)
op_next 0x0
op_sibling 0x0
op_ppaddr PL_ppaddr[OP_LEAVE]
op_targ 1
op_type 178
op_seq 6625
op_flags 13
op_private 64
op_first 0x8199cc0
op_last 0x81a04a0
op_children 3
OP (0x8199cc0)
op_next 0x81a04c8
op_sibling 0x81a04c8
op_ppaddr PL_ppaddr[OP_ENTER]
op_targ 0
op_type 177
op_seq 6620
op_flags 0
op_private 0
COP (0x81a04c8)
op_next 0x8106d20
op_sibling 0x81a04a0
op_ppaddr PL_ppaddr[OP_NEXTSTATE]
op_targ 0
op_type 174
op_seq 6621
op_flags 1
op_private 0
cop_label
cop_stashpv main
cop_file 0.pl
cop_seq 6621
cop_arybase 0
cop_line 3
cop_warnings 0x0
LISTOP (0x81a04a0)
op_next 0x8199018
op_sibling 0x0
op_ppaddr PL_ppaddr[OP_SCOPE]
op_targ 0
op_type 179
op_seq 0
op_flags 5
op_private 0
op_first 0x8199ce0
op_last 0x8106cf8
op_children 2
OP (0x8199ce0)
op_next 0x8106d20
op_sibling 0x8106cf8
op_ppaddr PL_ppaddr[OP_NULL]
op_targ 174
op_type 0
op_seq 0
op_flags 1
op_private 0
LISTOP (0x8106cf8)
op_next 0x8199018
op_sibling 0x0
op_ppaddr PL_ppaddr[OP_PRINT]
op_targ 0
op_type 209
op_seq 6624
op_flags 5
op_private 0
op_first 0x8106d20
op_last 0x8199c18
op_children 2
OP (0x8106d20)
op_next 0x8199c18
op_sibling 0x8199c18
op_ppaddr PL_ppaddr[OP_PUSHMARK]
op_targ 0
op_type 3
op_seq 6622
op_flags 2
op_private 0
SVOP (0x8199c18)
op_next 0x8106cf8
op_sibling 0x0
op_ppaddr PL_ppaddr[OP_CONST]
op_targ 0
op_type 5
op_seq 6623
op_flags 2
op_private 0
op_sv 0x81038c8
PV (0x81038c8)
REFCNT 1
FLAGS 0x4840004
xpv_pv "OK\n"
xpv_cur 3On peut aussi demander à Perl de compiler puis de décompiler un programme. Cela permet de voir les optimisations qu'il fait.
perl -MO=Deparse 3.pl
Par exemple, le programme
#! perl -w use strict; use constant TRUE => (0==0); use constant FALSE => (0==1); use constant DEBUG => FALSE; print STDERR "starting...\n" if DEBUG; print TRUE ."\n";
donne
sub DEBUG () {
package constant;
$scalar;
}
sub FALSE () {
package constant;
$scalar;
}
sub TRUE () {
package constant;
$scalar;
}
'???';
print "1\n";
3.pl syntax OKCa marche aussi avec -e
perl -MO=Deparse -e '$a = 1; print $a+2*$a+$a' $a = 1; print $a + 2 * $a + $a; -e syntax OK
On peut aussi lui demander de nous montrer où il met les parenthèses.
perl -MO=Deparse,-p -e '$a = 1; print $a+2*$a+$a' ($a = 1); print((($a + (2 * $a)) + $a)); -e syntax OK
C'est le compilateur Perl. Normalement, on n'en a pas besoin. Voir le module O.
Si on veut séparer la compilation de l'exécution... (Il faut un exécutable particulier, bypeperl, pour interpréter le code ainsi compilé).
Pour des raisons de compatibilité, on suggère de remplacer
chomp($a = `pwd`);
par
use Cwd; $a = cwd;
Le caractère utilisé pour séparer les noms de répertoire diffère selon les systèmes d'exploitation : "/" sous Unix, "\" sous DOS, ":" sous MacOS. Ce module permet de programmer de manière portable en tenant compte de ces différences.
Si on a besoin de choses comme la moyenne, l'écrat-type (dont on a tendance à oublier la définition et les formules).
#! perl -w -l use strict; use Statistics::Descriptive; my @data = qw/12 14.5 8 17 11 13 14 11 9/; my $stat = Statistics::Descriptive::Full->new(); $stat->add_data(@data); print "Moyenne: ". $stat->mean; print "Ecart-type: ". $stat->standard_deviation;
Interface au logiciel Pari (pour faire des calculs en théorie des nombres).
Pour consulter la bourse américaine :
use Finance::YahooQuote;
die "Usage: $0 symbol [symbol ...]" if $#ARGV == -1;
@h = ( "Symbol","Name","Last","Trade Date","Trade Time","Change","% Change",
"Volume","Avg. Daily Volume","Bid","Ask","Prev. Close","Open",
"Day's Range","52-Week Range","EPS","P/E Ratio","Div. Pay Rate",
"Div/Share","Div. Yield","Mkt. Cap","Exchange" );
$Finance::YahooQuote::QURL = "http://fr.finance.yahoo.com/d?f=snl1d1t1c1p2va2bapomwerr1dyj1x&s=";
$Finance::YahooQuote::TIMEOUT = 30;
@q = getquote(@ARGV);
foreach $a (@q) {
foreach (0..$#h) {
$$a[$_] =~ s/<.*?>//g;
print "$h[$_]: $$a[$_]\n";
}
print "\n";
}Pour consuler la bourse francaise (ça marche beaucoup moins bien : il n'y a pas d'informations historiques...).
use Finance::YahooQuote;
die "Usage: $0 symbol [symbol ...]" if $#ARGV == -1;
@h = ( "Symbol","Name","Last","Trade Date","Trade Time","Change","% Change",
"Volume","Avg. Daily Volume","Bid","Ask","Prev. Close","Open",
"Day's Range","52-Week Range","EPS","P/E Ratio","Div. Pay Rate",
"Div/Share","Div. Yield","Mkt. Cap","Exchange" );
$Finance::YahooQuote::QURL = "http://fr.finance.yahoo.com/d?f=snl1d1t1c1p2va2bapomwerr1dyj1x&s=";
$Finance::YahooQuote::TIMEOUT = 30;
@q = getquote(@ARGV);
foreach $a (@q) {
foreach (0..$#h) {
$$a[$_] =~ s/<.*?>//g;
print "$h[$_]: $$a[$_]\n";
}
print "\n";
}Mais les URLs changent de temps à autre, certains symboles (en particulier le symbole Euro) sont écrits de manière étrange, le point décimal est parfois remplacé par une virgule, etc. Il est donc souvent plus rapide d'utiliser directement LWP.
Permet de « valider » les paramètres d'une fonction, i.e., de vérifier qu'ils ont bien le type et les valeurs voulus.
Permet de lancer et d'attrapper des exceptions comme dans la plupart des langages orientés objet.
# non testé
use Error qw(:try);
throw Error::Simple( "A simple error");
sub xyz {
...
record Error::Simple("A simple error")
and return;
}
unlink($file) or throw Error::Simple("$file: $!",$!);
try {
do_some_stuff();
die "error!" if $condition;
throw Error::Simple -text => "Oops!" if $other_condition;
}
catch Error::IO with {
my $E = shift;
print STDERR "File ", $E->{'-file'}, " had a problem\n";
}
except {
my $E = shift;
my $general_handler=sub {send_message $E->{-description}};
return {
UserException1 => $general_handler,
UserException2 => $general_handler
};
}
otherwise {
print STDERR "Well I don't know what to say\n";
}
finally {
close_the_garage_door_already(); # Should be reliable
}; # Don't forget the trailing ; or you might be surprised
Comme je n'ai pas WinDaube, je n'utilise pas ces modules, mais il semblerait que l'on puisse interacir très facilement avec les usines à gaz de Redmond.
(to automate GUI programs ?)
Pour créer des fichiers Exccel.
use Spreadsheet::WriteExcel; # Create a new Excel workbook
my $workbook = Spreadsheet::WriteExcel->new("perl.xls"); # Add a worksheet
$worksheet = $workbook->addworksheet(); # Add and define a format
$format = $workbook->addformat(); # Add a format
$format->set_bold();
$format->set_color('red');
$format->set_align('center'); # Write a formatted and unformatted string, row and column notation.
$col = $row = 0;
$worksheet->write($row, $col, "Hi Excel!", $format);
$worksheet->write(1, $col, "Hi Excel!"); # Write a number and a formula using A1 notation
$worksheet->write('A3', 1.2345);
$worksheet->write('A4', '=SIN(PI()/4)');
POE permet de programmer à l'aide d'évènements, exactement comme Tk/Gtk/Qt, mais dans des cadres autres que la programmation graphique.
#!/usr/bin/perl -w
use strict;
# Use POE!
use POE;
# Every session must handle a special event, _start. It's used to
# tell the session that it has been successfully instantiated.
# $_[KERNEL] is a reference to the program's global POE::Kernel
# instance; $_[HEAP] is the session's local storage; $_[SESSION] is
# a reference to the session itself.
sub handler_start {
my ($kernel, $heap, $session) = @_[KERNEL, HEAP, SESSION];
print "Session ", $session->ID, " has started.\n";
$heap->{count} = 0;
$kernel->yield('increment');
} sub handler_increment {
my ($kernel, $heap, $session) = @_[KERNEL, HEAP, SESSION];
print "Session ", $session->ID, " counted to ", ++$heap->{count}, ".\n";
$kernel->yield('increment') if $heap->{count} < 10;
}
# The _stop event is special but, handling it is not required. It's
# used to tell a session that it's about to be destroyed. _stop
# handlers perform shutdown things like resource cleanup or
# termination logging.
sub handler_stop {
print "Session ", $_[SESSION]->ID, " has stopped.\n";
}
# Start ten sessions. POE::Session constructors map event names to
# the code that handles them.
for (0..9) {
POE::Session->create(
inline_states =>
{ _start => \&handler_start,
increment => \&handler_increment,
_stop => \&handler_stop,
}
);
}
# Start the kernel, which will run as long as there are sessions.
$poe_kernel->run();
exit;On peut par exemple l'utiliser pour paralléliser des requètes HTTP (il faudra que je regarde : j'ai déjà fait des choses comparables).
use POE qw(Component::Client::HTTP);
POE::Component::Client::HTTP->spawn(
Agent => 'SpiffCrawler/0.90', # defaults to something long
Alias => 'ua', # defaults to 'weeble'
From => 'spiffster@perl.org', # defaults to undef (no header)
Protocol => 'HTTP/0.9', # defaults to 'HTTP/1.0'
Timeout => 60, # defaults to 180 seconds
);
$kernel->post( 'ua', # posts to the 'ua' alias
'request', # posts to ua's 'request' state
'response', # which of our states will receive the response
$request, # an HTTP::Request object
);
# This is the sub which is called when the session receives a
# 'response' event.
sub response_handler {
my ($request_packet, $response_packet) = @_[ARG0, ARG1];
my $request_object = $request_packet->[0]; # HTTP::Request
my $response_object = $response_packet->[0]; # HTTP::Response
print "*" x 78, "\n";
print "*** my request:\n";
print "-' x 78, "\n";
print $request_object->as_string();
print "*" x 78, "\n"; print "*" x 78, "\n";
print "*** their response:\n";
print "-' x 78, "\n";
print $response_object->as_string();
print "*" x 78, "\n";
}
Le répertoire t/ lorsque l'on écrit un module.
use Test::More tests => $Num_Tests;
# or
use Test::More qw(no_plan);
# or
use Test::More skip_all => $reason;
BEGIN { use_ok( 'Some::Module' ); }
require_ok( 'Some::Module' );
# Various ways to say "ok"
ok($this eq $that, $test_name);
is ($this, $that, $test_name);
isnt($this, $that, $test_name);
like($this, qr/that/, $test_name);
is_deeply($complex_structure1, $complex_structure2, $test_name);
SKIP: {
skip $why, $how_many unless $have_some_feature;
ok( foo(), $test_name );
is( foo(42), 23, $test_name );
};
TODO: {
local $TODO = $why;
ok( foo(), $test_name );
is( foo(42), 23, $test_name );
};
can_ok($module, @methods);
isa_ok($object, $class);
pass($test_name);
fail($test_name);
# Utility comparison functions.
eq_array(\@this, \@that);
eq_hash(\%this, \%that);
eq_set(\@this, \@that);
# UNIMPLEMENTED!!!
my @status = Test::More::status;
# UNIMPLEMENTED!!!
BAIL_OUT($why);
POO (pour créer automatiquement des méthodes $a->foo(), $a->foo("abc"), etc.)
use Class::MethodMaker new_with_init => 'new', get_set => [ qw /foo bar baz / ];
Ça fait plus d'un an que ce fichier traine sur mon disque dur, toujours plus gros, mais toujours incomplet. Voici la liste des modules que je n'ai pas traités.
use IO::Socket; # new in 5.004
$handle = IO::Socket::INET->new('www.perl.com:80')
|| die "can't connect to port 80 on www.perl.com: $!";
$handle->autoflush(1);
if (fork()) { # XXX: undef means failure
select($handle);
print while <STDIN>; # everything from stdin to socket
} else {
print while <$handle>; # everything from socket to stdout
}
close $handle;
exit;
How do I fetch a news article or the active newsgroups?
Use the Net::NNTP or News::NNTPClient modules, both
available from CPAN. This can make tasks like fetching
the newsgroup list as simple as
perl -MNews::NNTPClient
-e 'print News::NNTPClient->new->list("newsgroups")'
Permet de saisir les caractères frappés au clavier un par un, de manière non bloquante.
On peut aussi contrôler le terminal, en fixant le comportement de certaines touches (comme avec stty), en regardant ou en modifiant sa taille,
For an OO version of gethostbyaddr
Traduction en Perl de log4j, une bibliothèque Java de Apache/Jakarta voir un article sur Perl.com
New in Perl 5.8.0 See the article "Going up?" on perl.com
use threads; use threads::shared; our %data : shared; our $more_data : shared; our $more_and_more_data; # nor shared
interface to /dev/random
To automate the management of Cisco routers+switches
To automate queries against network devices
insertion-order retrieval of hash elements
Un modèle de conception...
Un autre (poids-plume).
Se débarasser des zombies
$SIG{CHLD} = 'IGNORE';Lire un fichier à l'envers
my @lines = <FILE>;
foreach my $line ( reverse 0..$#lines ) {
...
}
# Voir aussi DB_FILE et DB_RECNODébuggueur
x @foo pretty print a variable V all variables in main::* X all variables in current package b 19 set a break point on line 19 d remove a break point s single step n single step, do not debug function bodies
Vincent Zoonekynd
<zoonek@math.jussieu.fr>
latest modification on jeu nov 14 08:44:31 CET 2002