[web] [script] surveillance forum developpez.

Version imprimable

10/07/2004, 11h39
Choupi

[web] [script] surveillance forum developpez.

Bonjour à tous perliennes & perliens.

Sous phpbb on peut surveiller un topic, à chaque nouvelle réponse on recoit un mail disant "blabla" a répondu à votre message.

Dans le même genre d'idèe je souhaite ecrire un petit script qui à interval régulier irait voir si il y a de nouveau topic dans une sous partie du forum.

Par exemple, surveiller la creation des topics de la section perl.

Auriez vous une méthodologie à me proposer pour le faire ? Faut donc prendre en compte le critere date du topic sujet ... envoi d'un mail ... ce genre de chose....

j'attend vos remarques et vos idees.

Si c'est pas clair je completerais.

Choupi.

Voici une solution simple et facile à mettre en oeuvre (je n'ai même pas utilisé de parseur HTML) :

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
 
#! /usr/bin/perl
use strict;
use warnings;
 
use LWP::UserAgent;
use locale;
 
my $ua = LWP::UserAgent->new;
#ua de IE6
$ua->agent("Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.1)" . $ua->agent);
 
my $req = HTTP::Request->new(GET => "http://<a href="http://www.developpez.net/forums/");" target="_blank">www.developpez.net/forums/");</a>
$req->header('Accept' => 'text/html');
 
my $forum;
my $messages = 0;
my $topics = 0;
 
while(1) {
    print scalar localtime(), "\n";
    print "Send request\n";
    my $res = $ua->request($req);
 
    if ($res->is_success) {
        $forum =$res->content;
        print "Success of the request\n";
        print "Success of the regex\n" if $forum =~ m|PERL .+?
                    <td [^>]*> \s* <span [^>]*> \s* (\d+) \s* </span> \s* </td> \s*
                    <td [^>]*> \s* <span [^>]*> \s* (\d+) \s* </span> \s* </td> \s*
                    |ixms;
        print "Nouveaux messages sur le forum Perl !!\n" if $2 > $messages;
        print "Nouveaux topics !!\n" if $1 > $topics;
        ($topics, $messages) = ($1,$2);
    }
    else {
        print "Error: " . $res->status_line . "\n";
    }    
 
    sleep 300;
}

[EDIT] Je confirme que ça marche, par exemple là il vient de m'informer du fait qu'il y avait un nouveau message (le mien :wink: )
:D

--
Jedaï

10/07/2004, 14h51
Jedai
En tant qu'amélioration très pratique au concept, on peut juste rajouter un son à émettre lorsque la vérification révèle l'arrivée de nouveaux messages, évitant ainsi d'avoir à reconsulter sa console régulièrement :
Code:

1 2 print "\aNouveaux messages sur le forum Perl !!\n" if $2 > $messages;
Ici j'utilise la cloche système, c'est un son bien reconnaissable donc assez adapté, mais on peut envisager de signaler visuellement l'arrivée d'un nouveau message avec PerlTk par exemple. :D

--
Jedaï

Excuse moi, peux tu expliquer un peu plus en detail la partie regex... Quelle info cherches tu ?

Code:

1
2
3
4
        print "Success of the regex\n" if $forum =~ m|PERL .+?
                    <td [^>]*> \s* <span [^>]*> \s* (\d+) \s* </span> \s* </td> \s*
                    <td [^>]*> \s* <span [^>]*> \s* (\d+) \s* </span> \s* </td> \s*
                    |ixms;

Cette partie là je la comprend pas trop...

10/07/2004, 15h53
Jedai

Si tu regardes le source de la page d'accueil du forum, tu constateras que cette regex me permet de récupérer le nombre de message dans le forum Perl, ainsi que le nombre de topics. D'où la solution ! :-) (Tu pourrais aussi regarder la date du dernier message mais les manipulations de date m'ont toujours horripilé... ) :D
(nouveau message repéré grâce à ce script !!)
--
Jedaï
10/07/2004, 15h56
Choupi

haaa je mate la source de ma page ! je comprenais pas...

Ok c'est trop cool. Je vais faire la partie qui envoi un mail et qui indique les nouveaux sujets ... :D

Y a t'il moyen de lancer un script perl dans la taskbar de windows ? (là je suis feignant ... rapide recherche ....2 s Non je trouve rien :( )...

Au pire vais me faire une tite interface graphique mais bon... déjà ca marche :wink: Merci beaucoup donc...
10/07/2004, 19h22
nyal

Bonjour,

Ce genre de script sont tres bien. Cependant, il ne faut pas en abuser en faisant des verifications trop souvent. ;) (c'est toujours mieux que d'utiliser la fonction mail du forum)

Oui bien sûr, mais demander une fois la page d'accueil toutes les 4 minutes ne risque pas de surcharger le serveur, non ?
Par ailleurs j'ai essayé de faire un truc un peu plus complexe, je vais corriger la synchronisation et il y a quelques problèmes encore, mais les bases sont en places :

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
 
#! /usr/bin/perl
use strict;
#~ use warnings;
 
 
 
# MODULES OBLIGATOIRES
 
use Tk;
use LWP::UserAgent;
use Getopt::Std;
use threads;
use threads::shared;
use locale;
 
 
 
# THREADS
 
sub maj (); # principal
sub text (); # mode texte -t
sub graph (); # mode graphique -g
 
 
 
# FONCTION PRINCIPALE
 
sub numbers ($);
 
 
 
# FONCTION AUXILIAIRE
 
sub HELP_MESSAGE;
 
 
 
# CODE PRINCIPAL
 
# options, traitement
$Getopt::Std::STANDARD_HELP_VERSION = 1;
our $VERSION = "0.1";
my %opts; getopts('vgtf:i:', \%opts);
die "Vous devez choisir le mode texte ou graphique avec -t/-v ou -g !\n"  if not ($opts{t} or $opts{g} or $opts{v});
die "-v et -t sont incompatibles !\n" if $opts{t} and $opts{v};
$opts{i} = 600 if not $opts{i};
$opts{f} = "PERL" if not $opts{f};
 
# variables, déclaration et initialisation
$| = 1;
my $ua = LWP::UserAgent->new;
$ua->agent("Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.1)" . $ua->agent); # ua de IE6
 
my $req = HTTP::Request->new(GET => "http://<a href="http://www.developpez.net/forums/");" target="_blank">www.developpez.net/forums/");</a>
$req->header('Accept' => 'text/html');
 
my $messages :shared = 0;
my $topics : shared = 0;
($topics, $messages) = numbers $req;
 
my $ipt : shared = 0;
 
# mise en place de la surveillance :
print "Taper 'q' pour quitter.\n";
my $mainthread = threads->create( "maj" );
 
my ($graphthread, $textthread);
$graphthread = threads->create( "graph" ) if $opts{g};
$textthread = threads->create( "text" ) if $opts{t};
 
if( not $opts{g} ) { 
    while( <STDIN> ){
        lock $ipt;
        #~ $ipt = -1, last if /^q/;
        exit if /^q/;
        $ipt = 1;
    }
}
 
$graphthread->join() if $opts{g};
$textthread->join() if $opts{t};
$mainthread->join();
 
 
 
# DEFINITION DES THREADS
 
sub maj () {
    while(1) {
        last if $ipt == -1;
        my ($nt, $nm) = numbers $req;
        print "\a\a" if $nm > $messages;
        print (($nm - $messages). " nouveaux messages sur le forum Perl !!\n") if $nm > $messages and $opts{v};
        print (($nt - $topics). " nouveaux topics !!\n") if $nt > $topics and $opts{v};
        ($topics, $messages) = ($nt,$nm);
 
        sleep $opts{i};
    }
    return;
}
 
sub graph () {
    my ($gmess, $gtop) = ($messages, $topics);
}
 
sub text () {
    my ($tmess, $ttop, $time) = ($messages, $topics, scalar localtime());
    my ($lm, $lt) = (1, 1);
    print (($messages - $tmess) . " nouveaux messages depuis $time, ".
                ($topics - $ttop). " nouveaux topics.");
    while (1) {
        {
            lock $ipt;
            last if $ipt == -1;
            if ($ipt == 1) {
                ($tmess, $ttop, $time) = ($messages, $topics, scalar localtime()) ;
                my ($lm, $lt) = (1, 1);
                print (($messages - $tmess) . " nouveaux messages depuis $time, ".
                    ($topics - $ttop). " nouveaux topics.");
            }
            print "\b" x ($lm + 28 + length($time) +
                $lt + 17); 
            print (($messages - $tmess) . " nouveaux messages depuis $time, ".
                ($topics - $ttop). " nouveaux topics.");
                ($lm, $lt) = (length($messages - $tmess), length($topics - $ttop));
            $ipt = 0;
        }
        sleep int( $opts{i} / 3 );
    }
    return;
}
 
 
 
# DEFINITION DES FONCTIONS
 
sub numbers ($) {
    print scalar localtime(), "\n" if $opts{v};
    print "Send request\n" if $opts{v};
    my $res = $ua->request($_[0]);
    my $forum;
 
    if ($res->is_success) {
        $forum =$res->content;
        print "Success of the request\n" if $opts{v};
        print "Success of the regex\n" if $forum =~ m|\Q$opts{f}\E .+?
                    <td [^>]*> \s* <span [^>]*> \s* (\d+) \s* </span> \s* </td> \s*
                    <td [^>]*> \s* <span [^>]*> \s* (\d+) \s* </span> \s* </td> \s*
                    |ixms and $opts{v};
        return ($1, $2);
    }
    else {
        print "Error: " . $res->status_line . "\n";
        return ($topics, $messages);
    }    
}
 
sub HELP_MESSAGE { 
    my $output = shift;
    print $output "usage : program [-vg|-tg|-g] (-f forum -i intervalle\n)";
}

Je suis ouvert à toute suggestion. :D
(surtout dans le domaine de la synchronisation, je n'ai pas tellement l'habitude des threads)

--
Jedaï

10/07/2004, 19h34
Jedai

Ca marche pas mal (enfin le mode "texte", parce que j'ai rien fait d'autre pour l'instant, le mode bavard aussi, mais il n'est pas des plus intéressants...), par contre si quelqu'un voulait faire la partie graphique sur le même principe que la partie textuelle (autrement dit avec un bouton pour remettre à 0 les compteurs et un pour quitter, ainsi qu'un pour fermer juste la fenètre). :D

--
Jedaï
10/07/2004, 20h28
Choupi

J'ai (sous windows) un drole de phenomene, la ligne nouveau message est atteinte de tremblements .... Et je peux pas quitter en tapant 'q'...

Peux tu annoter ton code s'il te plait ? Quand on est pas dans l'move c'est dur de suivre :wink: Je crois que j'ai eu une excellente idée avec ce sujet :D et j'ai trouvé un excellent codeur...

(stu veux j'ai des projets l'année prochaine :wink:)

Demain je vais m'occuper de l'interface graphique si tu veux. Sinon toujours la question sous windows, on peut avoir le programme en barre des taches avec perl ?

Amicalement, Choupi.

En fait le "Taper 'q' pour quitter." est un peu faux : il faut valider après. Et la fermeture ne s'effectue pas toujours instantanément, vu que la synchronisation est toujours assez boiteuse...
Par ailleurs, ce n'est pas indiqué, mais si tu tapes juste sur enter, tu réinitialise le compteur.
Voilà un code un peu corrigé :

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
 
#! /usr/bin/perl
use strict;
#~ use warnings;
 
 
 
# MODULES OBLIGATOIRES
 
use Tk;
use LWP::UserAgent;
use Getopt::Std;
use threads;
use threads::shared;
use locale;
 
 
 
# THREADS
 
sub maj (); # principal
sub text (); # mode texte -t
sub graph (); # mode graphique -g
 
 
 
# FONCTION PRINCIPALE
 
sub numbers ($);
 
 
 
# FONCTION AUXILIAIRE
 
sub HELP_MESSAGE;
 
 
 
# CODE PRINCIPAL
 
# options, traitement
$Getopt::Std::STANDARD_HELP_VERSION = 1;
our $VERSION = "0.1";
my %opts; getopts('vgtf:i:', \%opts);
die "Vous devez choisir le mode texte ou graphique avec -t/-v ou -g !\n"  if not ($opts{t} or $opts{g} or $opts{v});
die "-v et -t sont incompatibles !\n" if $opts{t} and $opts{v};
$opts{i} = 600 if not $opts{i};
$opts{f} = "PERL" if not $opts{f};
 
# variables, déclaration et initialisation
$| = 1;
my $ua = LWP::UserAgent->new;
$ua->agent("Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.1)" . $ua->agent); # ua de IE6
 
my $req = HTTP::Request->new(GET => "http://<a href="http://www.developpez.net/forums/");" target="_blank">www.developpez.net/forums/");</a>
$req->header('Accept' => 'text/html');
 
my $messages :shared = 0;
my $topics : shared = 0;
($topics, $messages) = numbers $req;
 
my $ipt : shared = 0;
 
# mise en place de la surveillance :
print "Taper 'q' et valider pour quitter.\n";
my $mainthread = threads->create( "maj" );
 
my ($graphthread, $textthread);
$graphthread = threads->create( "graph" ) if $opts{g};
$textthread = threads->create( "text" ) if $opts{t};
 
if( not $opts{g} ) { 
    while( <STDIN> ){
        lock $ipt;
        $ipt = -1, last if /^q/;        
        #~ exit if /^q/;
        $ipt = 1;
    }
}
 
$mainthread->join();
$graphthread->join() if $opts{g};
$textthread->join() if $opts{t};
 
 
 
 
# DEFINITION DES THREADS
 
sub maj () {
    MAJ : while(1) {
        last if $ipt == -1;
        my ($nt, $nm) = numbers $req;
        print "\a\a" if $nm > $messages;
        print (($nm - $messages). " nouveaux messages sur le forum Perl !!\n") if $nm > $messages and $opts{v};
        print (($nt - $topics). " nouveaux topics !!\n") if $nt > $topics and $opts{v};
        ($topics, $messages) = ($nt,$nm);
 
        for (my $i = 0; $i < $opts{i}; $i += 10) {
            sleep 10; last MAJ if $ipt == -1;
        }
    }
    return;
}
 
sub graph () {
    my ($gmess, $gtop) = ($messages, $topics);
}
 
sub text () {
    my ($tmess, $ttop, $time) = ($messages, $topics, scalar localtime());
    my ($lm, $lt) = (1, 1);
    print (($messages - $tmess) . " nouveaux messages depuis $time, ".
                ($topics - $ttop). " nouveaux topics.");
    TEXT : while (1) {
        {
            lock $ipt;
            last TEXT if $ipt == -1;
            if ($ipt == 1) {
                ($tmess, $ttop, $time) = ($messages, $topics, scalar localtime()) ;
                my ($lm, $lt) = (1, 1);
                print (($messages - $tmess) . " nouveaux messages depuis $time, ".
                    ($topics - $ttop). " nouveaux topics.");
            }
            print "\b" x ($lm + 28 + length($time) +
                $lt + 17); 
            print (($messages - $tmess) . " nouveaux messages depuis $time, ".
                ($topics - $ttop). " nouveaux topics.");
                ($lm, $lt) = (length($messages - $tmess), length($topics - $ttop));
            $ipt = 0;
        }
        sleep 10;
    }
    return;
}
 
 
 
# DEFINITION DES FONCTIONS
 
sub numbers ($) {
    print scalar localtime(), "\n" if $opts{v};
    print "Send request\n" if $opts{v};
    my $res = $ua->request($_[0]);
    my $forum;
 
    if ($res->is_success) {
        $forum =$res->content;
        print "Success of the request\n" if $opts{v};
        print "Success of the regex\n" if $forum =~ m|\Q$opts{f}\E .+?
                    <td [^>]*> \s* <span [^>]*> \s* (\d+) \s* </span> \s* </td> \s*
                    <td [^>]*> \s* <span [^>]*> \s* (\d+) \s* </span> \s* </td> \s*
                    |ixms and $opts{v};
        return ($1, $2);
    }
    else {
        print "Error: " . $res->status_line . "\n";
        return ($topics, $messages);
    }    
}
 
sub HELP_MESSAGE { 
    my $output = shift;
    print $output "usage : program [-vg|-tg|-g] (-f forum -i intervalle\n)";
}

Maintenant le programme quitte "proprement", autrement dit il récupère les threads qui traînent avant d'expirer. En contrepartie, il se ferme en 10 secondes maximum, pas instantanément comme avant, mais bon... Va falloir que je planche sur la synchro, sérieusement !! :D

--
Jedaï

10/07/2004, 21h14
Choupi

C'est deja beaucoup mieux, et meme si la fermeture n'est pas immediate ca marche d'enfer ! (voir tes MP au passage).

J'ai une question pour l'envoi des mails, j'utilise le module smtp (classique) mais il n'y a pas d'identification au niveau des serveurs smtp ? (je suis chez wanadoo ... peut etre accepte t'il mes envois car je me connecte de chez moi ... ? mais si je me connecte d'ailleurs, ca marchera aussi ?).

Donc interface :

¤ choix du forum
¤ frequence de renouvellement (avec limite pour pas abuser)
¤ ajout fonction mail ....
¤ affichage joli :D
¤ icone dans la barre des taches ? (en perl j'ai pas encore vu ca).

D'autres idees ?

Ok, les deux premiers points sont déjà faits (sans limite pour l'instant, mais je compte sur l'intelligence des gens, de toutes façon les vilains pirates ont beaucoup mieux pour faire joujou), et j'ai maintenant une synchro dix fois meilleure, avec terminaison du programme dans les trois secondes et mise à zéro immédiate, enfin le système est beaucoup mieux conçu ! :D

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
 
#! /usr/bin/perl
use strict;
#~ use warnings;
 
 
 
# MODULES OBLIGATOIRES
 
use Tk;
use LWP::UserAgent;
use Getopt::Std;
use threads;
use threads::shared;
use Thread::Queue;
use locale;
 
 
 
# THREADS
 
sub maj (); # principal
sub text (); # mode texte -t
sub graph (); # mode graphique -g
sub clock (); # synchronisateur
 
 
 
# FONCTION PRINCIPALE
 
sub numbers ($);
 
 
 
# FONCTION AUXILIAIRE
 
sub HELP_MESSAGE;
 
 
 
# CODE PRINCIPAL
 
# options, traitement
$Getopt::Std::STANDARD_HELP_VERSION = 1;
our $VERSION = "0.1";
my %opts; getopts('vgtf:i:', \%opts);
die "Vous devez choisir le mode texte ou graphique avec -t/-v ou -g !\n"  if not ($opts{t} or $opts{g} or $opts{v});
die "-v et -t sont incompatibles !\n" if $opts{t} and $opts{v};
$opts{i} = 600 if not $opts{i};
$opts{f} = "PERL" if not $opts{f};
 
# variables, déclaration et initialisation
$| = 1;
my $ua = LWP::UserAgent->new;
$ua->agent("Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.1)" . $ua->agent); # ua de IE6
 
my $req = HTTP::Request->new(GET => "http://<a href="http://www.developpez.net/forums/");" target="_blank">www.developpez.net/forums/");</a>
$req->header('Accept' => 'text/html');
 
my $messages :shared = 0;
my $topics : shared = 0;
($topics, $messages) = numbers $req;
 
my $ipt : shared = 0;
 
# mise en place de la surveillance :
print "Taper 'q' et valider pour quitter.\n";
 
my $mqueue : shared = Thread::Queue->new;
 
my $gqueue : shared;my $tqueue : shared;
$gqueue = Thread::Queue->new if $opts{g};
$tqueue = Thread::Queue->new if $opts{t};
 
my $mainthread = threads->create( "maj" );
 
 
my ($graphthread, $textthread);
$graphthread = threads->create( "graph" ) if $opts{g};
$textthread = threads->create( "text" ) if $opts{t};
 
 
my $clockthread = threads->create( "clock" );
 
if( not $opts{g} ) { 
    while( <STDIN> ){
        if(/^q$/) {
            $ipt = 1;
            $gqueue->enqueue( 0 ) if $opts{g};
            $tqueue->enqueue( 0 ) if $opts{t};
            $mqueue->enqueue( 0 );
            last;
        }
        $gqueue->enqueue( 2 ) if $opts{g};
        $tqueue->enqueue( 2 ) if $opts{t};
    }
}
 
$mainthread->join();
$graphthread->join() if $opts{g};
$textthread->join() if $opts{t};
$clockthread->join();
 
 
 
# DEFINITION DES THREADS
 
sub maj () {
    my $mclock;
    MAJ : while(1) {
        my $sleeptime = 0;
        my ($nt, $nm) = numbers $req;
        print "\a\a" if $nm > $messages;
        print (($nm - $messages). " nouveaux messages sur le forum Perl !!\n") if $nm > $messages and $opts{v};
        print (($nt - $topics). " nouveaux topics !!\n") if $nt > $topics and $opts{v};
        ($topics, $messages) = ($nt,$nm);
 
 
 
        while(1) {
            $mclock = $mqueue->dequeue();
            last MAJ if not $mclock;
            $sleeptime += 10;
            last if $sleeptime >= $opts{i};
        }
    }
    return;
}
 
sub graph () {
    my ($gmess, $gtop) = ($messages, $topics);
}
 
sub text () {
    my $tclock;
    my ($tmess, $ttop, $time) = ($messages, $topics, scalar localtime());
    my ($lm, $lt) = (1, 1);
    TEXT : while (1) {
        {
            print "\b" x ($lm + 28 + length($time) +
                $lt + 17); 
            print (($messages - $tmess) . " nouveaux messages depuis $time, ".
                ($topics - $ttop). " nouveaux topics.");
                ($lm, $lt) = (length($messages - $tmess), length($topics - $ttop));
            $ipt = 0;
        }
        $tclock = $tqueue->dequeue();
        last TEXT if( not $tclock );
        if( $tclock == 2 ) {
            ($tmess, $ttop, $time) = ($messages, $topics, scalar localtime()) ;
            ($lm, $lt) = (1, 1);
            print (($messages - $tmess) . " nouveaux messages depuis $time, ".
                ($topics - $ttop). " nouveaux topics.");        
        }
    }
    return;
}
 
sub clock () {
    while (1){
        last if $ipt;
        $mqueue->enqueue( 1 );
        sleep 3;
        last if $ipt;
        $gqueue->enqueue( 1 ) if $opts{g};
        sleep 2;
        last if $ipt;
        $tqueue->enqueue( 1 ) if $opts{t};
        sleep 2;
    }
}
 
 
 
# DEFINITION DES FONCTIONS
 
sub numbers ($) {
    print scalar localtime(), "\n" if $opts{v};
    print "Send request\n" if $opts{v};
    my $res = $ua->request($_[0]);
    my $forum;
 
    if ($res->is_success) {
        $forum =$res->content;
        print "Success of the request\n" if $opts{v};
        print "Success of the regex\n" if $forum =~ m|\Q$opts{f}\E .+?
                    <td [^>]*> \s* <span [^>]*> \s* (\d+) \s* </span> \s* </td> \s*
                    <td [^>]*> \s* <span [^>]*> \s* (\d+) \s* </span> \s* </td> \s*
                    |ixms and $opts{v};
        return ($1, $2);
    }
    else {
        print "Error: " . $res->status_line . "\n";
        return ($topics, $messages);
    }    
}
 
sub HELP_MESSAGE { 
    my $output = shift;
    print $output "usage : program [-vg|-tg|-g] (-f forum -i intervalle\n)";
}

Je vais regarder les autres points, mais je ne sais pas trop comment gérer cette histoire d'email : les envoyer dès qu'il y a un nouveau message ? Ca risque de devenir catastrophique en cas de folie du forum comme il y a peu, non ?

--
Jedaï

11/07/2004, 10h04
Choupi

Fonction mail je vais la faire ... Je pense mail lorsque 5 nouveaux messages ? ou un truc du genre... Et ca sera optionnel vu que l'affichage suffit.

Je vais me concentrer sur l'interface... Je vais aussi tester et dissequer ton code. :wink: A tout :)
11/07/2004, 11h09
nyal

Citation:

Envoyé par Jedai

Oui bien sûr, mais demander une fois la page d'accueil toutes les 4 minutes ne risque pas de surcharger le serveur, non ?

Oui ca risque pas la. Puis ca evite toujours d'aller sur un topic, revenir sur l'ancienne, aller sur un autre topic,... Ca peut faire gagner du temps.
Je pense qul'il y a moyen de faire quelque chose de bien en le couplant avec un module gtk.
11/07/2004, 11h17
Choupi

Citation:

Envoyé par nyal

Ca peut faire gagner du temps.
Je pense qul'il y a moyen de faire quelque chose de bien en le couplant avec un module gtk.

Je suis lancé sur l'api win (win32::Gui) :roll: :( ... J'utilise preferentiellement active perl donc pour moi c'est plus facile. Si je parviens à coupler de manière efficace le code de Jedai à une interface tk / win32Gui dans ce cas je ferais en sorte de produire une version 100% portable.

Promis on aura un tit script portable !
11/07/2004, 13h11
nyal

Citation:

Envoyé par Choupi

Citation:

Envoyé par nyal

Ca peut faire gagner du temps.
Je pense qul'il y a moyen de faire quelque chose de bien en le couplant avec un module gtk.

Je suis lancé sur l'api win (win32::Gui) :roll: :( ... J'utilise preferentiellement active perl donc pour moi c'est plus facile. Si je parviens à coupler de manière efficace le code de Jedai à une interface tk / win32Gui dans ce cas je ferais en sorte de produire une version 100% portable.

Promis on aura un tit script portable !

Un interet de perl est de rendre le truc portable. Alors si oon se met a utiliser des modules non portables... alors qu'il existe tk (que je trouve tres moyen), gtk (beaucoup mieux), wxwidgets (pas essayé),...

;)
11/07/2004, 13h20
Jedai

Le petit problème de Gtk, c'est qu'il faut quand même installer Gtk, ce qui n'est pas le cas par défaut sous Windows... Alors que Perl::Tk est disponible par défaut avec ActivePerl et très facilement accessible sous Linux.
Je peux m'occuper de la partie graphique avec Perl::Tk si vous voulez (de toute façon, il faut que je réorganise un peu le programme, le clock devrait être le thread principal et la gestion de STDIN déporté sur un autre thread). :D

(D'un autre côté si tu proposes une version Perl::Gtk, c'est pas moi qui m'en plaindrai !)
--
Jedaï
11/07/2004, 13h36
Choupi

Yep ben moi j'ai une version sous win ... helas trop de diff avec tk. Petite capture :

Alors liste des forums... classique:

http://perso.wanadoo.fr/cirius/capture1.png

Intégration à la barre des taches (admirez la petite icone developpez :) )

http://perso.wanadoo.fr/cirius/capture2.png

Ajout sous peu du decompte avant prochaine verification...
Ajout sous peu des preferences (mais, affichage, frequence verification, petit son ?)....

Jedai, je n'arrive pas à recuperer la liste des forums avec ta regex... Je trouve pas d'erreur... (je veux les recuperer sous forme de tableau au passage).
11/07/2004, 13h41
nyal

Citation:

Envoyé par Jedai

Le petit problème de Gtk, c'est qu'il faut quand même installer Gtk, ce qui n'est pas le cas par défaut sous Windows... Alors que Perl::Tk est disponible par défaut avec ActivePerl et très facilement accessible sous Linux.
Je peux m'occuper de la partie graphique avec Perl::Tk si vous voulez (de toute façon, il faut que je réorganise un peu le programme, le clock devrait être le thread principal et la gestion de STDIN déporté sur un autre thread). :D

(D'un autre côté si tu proposes une version Perl::Gtk, c'est pas moi qui m'en plaindrai !)

Je n'aime pas specialement tk (car j'ai toujours eu des problemes avec) mais c'est toujours mieux que un module non portable .
11/07/2004, 13h47
Choupi

Citation:

Envoyé par nyal

Je n'aime pas specialement tk (car j'ai toujours eu des problemes avec) mais c'est toujours mieux que un module non portable .

Ben faut pas me faire complexer :oops: :wink: Version tk aussi en route de mon coté... faut juste s'assurer de laisser un maximum de modularité au code de Jedai.

[Ajout 14h52]

Bon je repasse donc en tk (nyal) étant adepte de linux (avait pas vu)

http://perso.wanadoo.fr/cirius/capture3.png

Arf... Tk semble avoir de gros problème avec les threads !! Je vais faire une version graphique et alléger ma version textuelle :

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
 
#! /usr/bin/perl
use strict;
#~ use warnings;
 
 
 
# MODULES OBLIGATOIRES
 
use LWP::UserAgent;
use Getopt::Std;
use threads;
use threads::shared;
use Thread::Queue;
use locale;
 
 
 
# THREADS
 
sub maj (); # principal
sub text (); # mode texte -t
sub reader (); # synchronisateur
 
 
 
# FONCTION PRINCIPALE
 
sub numbers ($);
 
 
 
# FONCTION AUXILIAIRE
 
sub HELP_MESSAGE;
 
 
 
# CODE PRINCIPAL
 
# options, traitement
$Getopt::Std::STANDARD_HELP_VERSION = 1;
our $VERSION = "0.1";
my %opts; getopts('mvtf:i:', \%opts);
die "Vous devez choisir le mode texte avec -t ou -v !\n"  if not ($opts{t} or $opts{g});
die "Les modes -v et -t sont incompatibles !\n" if $opts{t} and $opts{v};
$opts{i} = 600 if not $opts{i};
$opts{f} = "PERL" if not $opts{f};
 
# variables, déclaration et initialisation
$| = 1;
my $ua = LWP::UserAgent->new;
$ua->agent("Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.1)" . $ua->agent); # ua de IE6
 
my $req = HTTP::Request->new(GET => "http://<a href="http://www.developpez.net/forums/");" target="_blank">www.developpez.net/forums/");</a>
$req->header('Accept' => 'text/html');
 
my $messages :shared = 0;
my $topics : shared = 0;
($topics, $messages) = numbers $req;
 
my $ipt : shared = 0;
my $time : shared = localtime;
 
# mise en place de la surveillance :
print "Taper 'q' et valider pour quitter.\n";
 
# gestion des threads et synchro
my $mqueue : shared = Thread::Queue->new;
my $tqueue : shared = Thread::Queue->new if $opts{t};
 
my $mainthread = threads->create( "maj" );
 
my ($textthread, $readerthread);
$textthread = threads->create( "text" ) if $opts{t};
$readerthread = threads->create( "reader" );
 
CLOCK : while (1){
    last if $ipt;
    $mqueue->enqueue( 1 );
    sleep 2;
    last if $ipt;
    sleep 2;
    last if $ipt;
    sleep 2;
    last if $ipt;
    sleep 2;
    last if $ipt;
    sleep 2;
}
 
 
$mainthread->join();
$textthread->join() if $opts{t};
$readerthread->join();
 
 
 
# DEFINITION DES THREADS
 
sub maj () {
    my $mclock;
    MAJ : while(1) {
        my $sleeptime = 0;
        my ($nt, $nm) = numbers $req;
        print "\a\a" if $nm > $messages and (not $opts{m});
        print (($nm - $messages). " nouveaux messages sur le forum Perl !!\n") if $nm > $messages and $opts{v};
        print (($nt - $topics). " nouveaux topics !!\n") if $nt > $topics and $opts{v};
        ($topics, $messages) = ($nt,$nm);
        $tqueue->enqueue( 1 );
 
 
        while(1) {
            $mclock = $mqueue->dequeue();
            last MAJ if not $mclock;
            $sleeptime += 10;
            last if $sleeptime >= $opts{i};
        }
    }
    return;
}
 
sub text () {
    my $tclock;
    my ($tmess, $ttop) = ($messages, $topics);
    my ($lm, $lt) = (1, 1);
    TEXT : while (1) {
 
        print "\b" x ($lm + 28 + length($time) + $lt + 17); 
        print (($messages - $tmess) . " nouveaux messages depuis $time, ".
            ($topics - $ttop). " nouveaux topics.");
            ($lm, $lt) = (length($messages - $tmess), length($topics - $ttop));
 
        $tclock = $tqueue->dequeue();
        last TEXT if( not $tclock );
        if( $tclock == 2 ) {
            ($tmess, $ttop, $time) = ($messages, $topics, scalar localtime()) ;
            ($lm, $lt) = (1, 1);
            print (($messages - $tmess) . " nouveaux messages depuis $time, ".
                ($topics - $ttop). " nouveaux topics.");        
        }
    }
    return;
}
 
sub reader () {
    while( <STDIN> ){
        if(/^q$/) {
            $ipt = 1;
            $tqueue->enqueue( 0 ) if $opts{t};
            $mqueue->enqueue( 0 );
            last;
        }
        $tqueue->enqueue( 2 ) if $opts{t};
    }
    return;
}
 
 
 
# DEFINITION DES FONCTIONS
 
sub numbers ($) {
    print scalar localtime(), "\n" if $opts{v};
    print "Send request\n" if $opts{v};
    my $res = $ua->request($_[0]);
    my $forum;
 
    if ($res->is_success) {
        $forum =$res->content;
        print "Success of the request\n" if $opts{v};
        print "Success of the regex\n" if $forum =~ m|\Q$opts{f}\E .+?
                    <td [^>]*> \s* <span [^>]*> \s* (\d+) \s* </span> \s* </td> \s*
                    <td [^>]*> \s* <span [^>]*> \s* (\d+) \s* </span> \s* </td> \s*
                    |ixms and $opts{v};
        return ($1, $2);
    }
    else {
        print "Error: " . $res->status_line . "\n";
        return ($topics, $messages);
    }    
}
 
sub HELP_MESSAGE { 
    my $output = shift;
    print $output <<'HELP';
usage : program [options]
 
> Options :
Modes (incompatibles): 
-v  : active le mode bavard
-t  : active le mode textuel classique, <enter> réinitialise le compteur dans ce mode
Arguments :
-f forum    : donne le nom du forum que vous voulez surveiller
-i intervalle   : le nombre de seconde entre chaque vérification
-m  : muet, désactive l'émission d'un son lorsqu'un nouveau message est repéré
HELP
}

C'est ainsi plus clair, non ? :D

--
Jedaï

12/07/2004, 00h24
Jedai

Juste par curiosité (et aussi pour tester mon script je l'avoue), qu'est ce qui rend PerlGtk supérieur à Tk pour toi Nyal ? Et as-tu une grande expérience avec le premier ? Sais-tu si on peut l'installer sous windows (sans trifouiller le source ...) ? :D

--
Jedaï

J'ai une première version de mon script avec Tk, il lui manque les trois quarts des fonctionnalités, c'est affreusement laid, mais ça marche (plus ou moins). Donc si vous avez des suggestions sur la structure, elles seront les bienvenues, merci. :D

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
#! /usr/bin/perl
use strict;
use warnings;
 
# MODULES
use Tk; use Tk::Table;
use LWP::UserAgent;
 
 
# INITIALISATION
 
my $ua = LWP::UserAgent->new;
$ua->agent("Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.1)" . $ua->agent); # ua de IE6
 
my $req = HTTP::Request->new(GET => "http://<a href="http://www.developpez.net/forums/");" target="_blank">www.developpez.net/forums/");</a>
$req->header('Accept' => 'text/html');
 
my $accueil = get_page() or die "Impossible de contacter developpez.net\n";
 
# liste des forums de developpez.net
my @forums = ($accueil =~ m|<span \s* class="forumlink"> \s* <a [^>]*> \s* ([^<]+) \s* </a> \s* <br \s* />|ixg);
 
# chaque entrée de ce tableau contient les informations suivantes : 
# 0 nom du forum, 1 nombre de nouveaux messages, 2 nombres de nouveaux topics, 
# 3 nombre de messages, 4 nombre de topics, 5 forum surveillé ou non, 6 nouveau message muet ou non,
# 7 pop-up sur nouveau message ou non, 8 mail sur nouveau message ou non, 9 limite pour l'envoi d'un mail 
my @main_info; 
for (0..$#forums) {
    $accueil =~ m|\Q$forums[$_]\E .+?
                    <td [^>]*> \s* <span [^>]*> \s* (\d+) \s* </span> \s* </td> \s*
                    <td [^>]*> \s* <span [^>]*> \s* (\d+) \s* </span> \s* </td> \s*
                    |ixms;
    $main_info[$_] = [ $forums[$_], 0, 0, $2, $1, 0, 0, 0, 0, 1 ];
}
 
# intervalle en seconde entre deux mises à jour
my $intervalle = 30;
 
# MISE EN PLACE DE LA FENETRE
 
my $mw = MainWindow->new( -title => 'Surveillance des forums de Développez.net');
my $clock = $mw->repeat( $intervalle * 1000, \&maj ); 
 
my(@pl) = qw/-side top -expand yes -padx 10 -pady 10 -fill both/;
my $hight = $mw->Frame->pack(@pl);
my $low = $mw->Frame->pack(@pl);
@pl = qw/-side left -expand yes -padx 10 -pady 10 -fill both/;
my $hleft = $hight->Frame->pack( @pl);
my $hright = $hight->Frame->pack( @pl);
 
$hleft->Button( -text => 'Réinitialiser',
                -command => \&reset_count )->pack( qw/-side top -pady 10/ );
$hleft->Button( -text => 'Options',
                -command => \&prefs )->pack( qw/-side top -pady 10/ );
 
$hright->Button( -text => 'Quitter',
                -command => [ $mw => 'destroy' ] )->pack( qw/-side top -expand yes/ );
my $date = $low->Label( -text => 'Décompte depuis ' . localtime() );
$date->pack();
 
my $table_f = $low->Table(-rows => (scalar(@forums) + 1),
                          -columns => 4,
                          -scrollbars => 'e',
                          -fixedrows => 1,
                          -takefocus => 1);
 
$table_f->pack( -side => 'bottom' );;
$table_f->put( 0, 0, $table_f->Label( -text => " Surveillé ? ", -relief => 'raise' ));
$table_f->put( 0, 1, $table_f->Label( -text => "Forums", -relief => 'raise' ));
$table_f->put( 0, 2, $table_f->Label( -text => "  Nouveaux messages  ", -relief => 'raise' ));
$table_f->put( 0, 3, $table_f->Label( -text => "  Nouveaux topics  ", -relief => 'raise'  ));  
 
create_table();
 
 
$mw->maxsize( 1024, 600 );
 
MainLoop();
 
# CALLBACKS
 
 
sub create_table {
    for (0..$#main_info) {
        my $widget = $table_f->Checkbutton( -text => "", 
                                            -variable => \$main_info[$_][5] );
        $table_f->put( $_ + 1, 0, $widget );
        $widget = $table_f->Label( -text => $main_info[$_][0] );
        $table_f->put( $_ + 1, 1, $widget );
        $widget = $table_f->Label( -text => $main_info[$_][1] );
        $table_f->put( $_ + 1, 2, $widget );
        $widget = $table_f->Label( -text => $main_info[$_][2] );
        $table_f->put( $_ + 1, 3, $widget );
    }
}
 
sub refresh {
    for (0..$#main_info) {
        my $widget = $table_f->get( $_ + 1, 2);
        $widget->configure( -text => $main_info[$_][1] );
        $widget = $table_f->get( $_ + 1, 3);
        $widget->configure( -text => $main_info[$_][2] );
    }
}
 
sub reset_count {
    $date->configure( -text => 'Décompte depuis ' . localtime() );
    for (0..$#main_info) {
        $main_info[$_][1] = 0;$main_info[$_][2] = 0;
    }
    refresh();
}
 
sub get_page {
    my $res = $ua->request($req);
 
    if ($res->is_success) {
        return $res->content;
    }
    else {
        print "Error: " . $res->status_line . "\n";
        return $accueil;
    }
}
 
sub maj {
    $accueil = get_page();
    for (0..$#main_info) {
        if( $main_info[$_][5] ) {
            my $forum = $main_info[$_][0];
            $accueil =~ m|\Q$forum\E .+?
                        <td [^>]*> \s* <span [^>]*> \s* (\d+) \s* </span> \s* </td> \s*
                        <td [^>]*> \s* <span [^>]*> \s* (\d+) \s* </span> \s* </td> \s*
                        |ixms;
            print "\a\a" if (not $main_info[$_][6]) and $2 > $main_info[$_][3];
            $main_info[$_][1] += ($2 - $main_info[$_][3]);$main_info[$_][2] += ($1 - $main_info[$_][4]);
            $main_info[$_][3] = $2;$main_info[$_][4] = $1;
            popup( $_ ) if $main_info[$_][7] ;
            mail( $_ ) if $main_info[$_][8] and $main_info[$_][1] > $main_info[$_][9];
        }
    }
    refresh();
}
 
sub popup {
 
}

--
Jedaï

12/07/2004, 09h16
nyal

Citation:

Envoyé par Jedai

Juste par curiosité (et aussi pour tester mon script je l'avoue), qu'est ce qui rend PerlGtk supérieur à Tk pour toi Nyal ? Et as-tu une grande expérience avec le premier ? Sais-tu si on peut l'installer sous windows (sans trifouiller le source ...) ? :D

Ca fait un bout de temps que j'ai developpe des interfaces graphiques en gtk que ce soit en C ou perl. Et je trouve que cette librairie est tres bien. Elle est bien pensée (orienté objet), plutot rapide, facile a developper, les nombreuses widgets presentes (ya meme une widget mplayer :) ), agreable graphiquement (contrairement a tk que je trouve un peu vieillot), les themes nombreux,....

Je pense qu'elle est installable sous windows sans gros probleme.
12/07/2004, 10h17
Choupi

Citation:

Envoyé par Jedai

c'est affreusement laid, mais ça marche (plus ou moins). Donc si vous avez des suggestions sur la structure, elles seront les bienvenues, merci. :D

Ben laid, c'est tk :wink: Comme moi tu n'utilises plus de threads... Par contre j'utilise Hlist et du coup la remise à jour est compliquee !! C'est bcp mieux Table.

Pour Gtk, sous windows c'est lourd... et faut mieux utiliser l'api win32, on conserve la charte graphique (gtk c'est parfois beau aussi)...
12/07/2004, 12h03
Jeh

Citation:

Envoyé par Choupi

Sinon toujours la question sous windows, on peut avoir le programme en barre des taches avec perl ?

Une solution : créer un raccourci vers cmd du type :

Code:

C:\WINNT\system32\CMD.EXE /k "C:\Perl\bin\perl.exe C:\verif_topic_dev.pl"

Citation:

Envoyé par Jeh

Une solution : créer un raccourci vers cmd du type :

Code:

C:\WINNT\system32\CMD.EXE /k "C:\Perl\bin\perl.exe C:\verif_topic_dev.pl"

Je connaissais pas ... Une solution simple avec l'api win32::Gui :
Code:

1 2 3 4 5 my $icon = new Win32::GUI::Icon('logo.ico'); my $main = Win32::GUI::Window->new(); my $ni = $main->AddNotifyIcon(-name => "NI", -id => 1,-icon => $icon, -tip => "Forum Developpez !");
On peut gere les baloon tips... J'ai vraiment apprécier!

J'ai un peu remanié le code (un peu), et les popups marchent maintenant, ce qui est bien pratique !

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
 
#! /usr/bin/perl
use strict;
use warnings;
 
# MODULES
use Tk; use Tk::Table;
use LWP::UserAgent;
 
 
# INITIALISATION
 
my $ua = LWP::UserAgent->new;
$ua->agent("Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.1)" . $ua->agent); # ua de IE6
 
my $req = HTTP::Request->new(GET => "http://<a href="http://www.developpez.net/forums/");" target="_blank">www.developpez.net/forums/");</a>
$req->header('Accept' => 'text/html');
 
my $accueil = get_page() or die "Impossible de contacter developpez.net\n";
 
# liste des forums de developpez.net
my @forums = ($accueil =~ m|<span \s* class="forumlink"> \s* <a [^>]*> \s* ([^<]+) \s* </a> \s* <br \s* />|ixg);
 
# chaque entrée de ce tableau contient les informations suivantes : 
# 0 nom du forum, 1 nombre de nouveaux messages, 2 nombres de nouveaux topics, 
# 3 nombre de messages, 4 nombre de topics, 5 forum surveillé ou non, 6 son pour nouveau message ou non,
# 7 pop-up sur nouveau message ou non, 8 mail sur nouveau message ou non, 9 limite pour l'envoi d'un mail 
my @main_info; 
for (0..$#forums) {
    $accueil =~ m|\Q$forums[$_]\E .+?
                    <td [^>]*> \s* <span [^>]*> \s* (\d+) \s* </span> \s* </td> \s*
                    <td [^>]*> \s* <span [^>]*> \s* (\d+) \s* </span> \s* </td> \s*
                    |ixms;
    $main_info[$_] = [ $forums[$_], 0, 0, $2, $1, 0, 1, 1, 0, 1 ];
}
 
# intervalle en seconde entre deux mises à jour
my $intervalle = 120;
 
# MISE EN PLACE DE LA FENETRE
 
my $mw = MainWindow->new( -title => 'Surveillance des forums de Développez.net');
my $clock = $mw->repeat( $intervalle * 1000, \&maj ); 
 
my(@pl) = qw/-side top -expand yes -padx 10 -pady 10 -fill both/;
my $hight = $mw->Frame;
$hight->pack(qw/-side top -padx 10 -pady 5 -fill x/);
my $low = $mw->Frame;
$low->pack(@pl);
@pl = qw/-side left -padx 10 -expand yes -fill x/;
my $hleft = $hight->Frame;
$hleft->pack( @pl);
my $hright = $hight->Frame;
$hright->pack( @pl);
 
$hleft->Button( -text => 'Réinitialiser',
                -command => \&reset_count )->pack( qw/-anchor w -side top -pady 1/ );
$hleft->Button( -text => 'Options',
                -command => \&prefs )->pack( qw/-anchor w -side top -pady 1/ );
 
$hright->Button( -text => 'Quitter',
                -command => [ $mw => 'destroy' ] )->pack( qw/-anchor e -side top -expand yes/ );
my $date = $low->Label( -text => 'Décompte depuis ' . localtime() );
$date->pack();
 
my $table_f = $low->Table(-rows => (scalar(@forums) + 1),
                          -columns => 4,
                          -scrollbars => 'e',
                          -fixedrows => 1,
                          -takefocus => 1);
 
$table_f->pack( -side => 'bottom' );;
$table_f->put( 0, 0, $table_f->Label( -text => " Surveillé ? ", -relief => 'raise' ));
$table_f->put( 0, 1, $table_f->Label( -text => "Forums", -relief => 'raise' ));
$table_f->put( 0, 2, $table_f->Label( -text => "  Nouveaux messages  ", -relief => 'raise' ));
$table_f->put( 0, 3, $table_f->Label( -text => "  Nouveaux topics  ", -relief => 'raise'  ));  
 
create_table();
 
$mw->maxsize( 1024, 600 );
 
MainLoop();
 
# CALLBACKS
 
 
sub create_table {
    for (0..$#main_info) {
        my $widget = $table_f->Checkbutton( -text => "", 
                                            -variable => \$main_info[$_][5],
                                            -command => [\&change_surv_state => $_]);
        $table_f->put( $_ + 1, 0, $widget );
        $widget = $table_f->Label( -text => $main_info[$_][0] );
        $table_f->put( $_ + 1, 1, $widget );
        $widget = $table_f->Label( -text => $main_info[$_][1] );
        $table_f->put( $_ + 1, 2, $widget );
        $widget = $table_f->Label( -text => $main_info[$_][2] );
        $table_f->put( $_ + 1, 3, $widget );
    }
}
 
sub change_surv_state {
    my $forum = shift;
    if( not $main_info[$forum][5] ) {
        $main_info[$forum][1] = 0;$main_info[$forum][2] = 0;
        refresh( 1, $forum );
    }
}
 
sub refresh {
    my $only = shift;
    if ( $only ) {
        if( @_ ) {
            my $widget = $table_f->get( $_[0] + 1, 2);
            $widget->configure( -text => $main_info[$_][1] );
            $widget = $table_f->get( $_[0] + 1, 3);
            $widget->configure( -text => $main_info[$_][2] );
        }
        else {
            for (0..$#main_info) {
                if( $main_info[$_][5] ) {
                    my $widget = $table_f->get( $_ + 1, 2);
                    $widget->configure( -text => $main_info[$_][1] );
                    $widget = $table_f->get( $_ + 1, 3);
                    $widget->configure( -text => $main_info[$_][2] );
                }
            }
        }
    }
    else {
        for (0..$#main_info) {
            my $widget = $table_f->get( $_ + 1, 2);
            $widget->configure( -text => $main_info[$_][1] );
            $widget = $table_f->get( $_ + 1, 3);
            $widget->configure( -text => $main_info[$_][2] );
        }
 
    }
}
 
sub reset_count {
    $date->configure( -text => 'Décompte depuis ' . localtime() );
    for (0..$#main_info) {
        $main_info[$_][1] = 0;$main_info[$_][2] = 0;
    }
    refresh( 0 );
}
 
sub get_page {
    my $res = $ua->request($req);
 
    if ($res->is_success) {
        return $res->content;
    }
    else {
        print "Error: " . $res->status_line . "\n";
        return undef;
    }
}
 
sub maj {
    $accueil = get_page() or return;
    for (0..$#main_info) {
        if( $main_info[$_][5] ) {
            my $forum = $main_info[$_][0];
            if( $accueil =~ m|\Q$forum\E .+?
                        <td [^>]*> \s* <span [^>]*> \s* (\d+) \s* </span> \s* </td> \s*
                        <td [^>]*> \s* <span [^>]*> \s* (\d+) \s* </span> \s* </td> \s*
                        |ixms ) {
                if( $2 > $main_info[$_][3] ) {
                    print "\a\a" if ($main_info[$_][6]);
                    popup( $_ ) if $main_info[$_][7] ;
                    mail( $_ ) if $main_info[$_][8] and $main_info[$_][1] > $main_info[$_][9];
                }
                $main_info[$_][1] += ($2 - $main_info[$_][3]);$main_info[$_][2] += ($1 - $main_info[$_][4]);
                $main_info[$_][3] = $2;$main_info[$_][4] = $1;
            }
        }
    }
    refresh( 1 );
}
 
sub popup {
    $mw->messageBox( -default => 'Ok',
                      -message => 'Nouveau message sur le forum '.$main_info[$_[0]][0],
                      -title => 'Nouveau message',
                      -icon => 'info',
                      -type => 'Ok')
}

:D

[EDIT] Petites amélioration cosmétiques
--
Jedaï