File Coverage

blib/lib/Tk/SlideShow.pm
Criterion Covered Total %
statement 4 6 66.6
branch n/a
condition n/a
subroutine 2 2 100.0
pod n/a
total 6 8 75.0


line stmt bran cond sub pod time code
1 6     6   4046 use strict;
  6         11  
  6         192  
2              
3 6     6   27699 use Tk;
  0            
  0            
4             use Tk::Xlib;
5             use Tk::After;
6             use Tk::Animation;
7             use Tk::Font;
8              
9             use Tk::SlideShow::Dict;
10             use Tk::SlideShow::Placeable;
11             use Tk::SlideShow::Diapo;
12             use Tk::SlideShow::Sprite;
13             use Tk::SlideShow::Oval;
14             use Tk::SlideShow::Link;
15             use Tk::SlideShow::Arrow;
16             use Tk::SlideShow::DblArrow;
17             use Tk::SlideShow::Org;
18              
19              
20             $SIG{__DIE__} = sub { print &pile;};
21              
22             sub pile {
23             my $i=0;
24             my $str;
25             while(my ($p,$f,$l) = caller($i)) {
26             $str .= "\t$f:$l ($p) \n";
27             $i++;
28             }
29             return $str;
30             }
31              
32             #------------------------------------------------
33             package Tk::SlideShow;
34             require Exporter;
35             use vars qw($VERSION @EXPORT @ISA);
36             @ISA=qw(Exporter);
37             @EXPORT=qw(template);
38             $VERSION='0.07';
39              
40             my ($can,$H,$W,$xprot,$present);
41             my $mainwindow;
42             my $mode = 'X11';
43             my $family = "charter";
44             use vars qw($inMainLoop $nextslide $jumpslide);
45             $nextslide = 0;
46              
47             sub var_getset{
48             my ($s,$k,$v) = @_;
49             if (defined $v) {$s->{$k} = $v; return $s;}
50             else { return $s->{$k} ;}
51             };
52              
53             sub family {
54             my ($class,$newfamily) = @_;
55             if (defined $newfamily) {$family = $newfamily;}
56             return $family;
57             }
58             sub f {return $can->Font('family' => $family, point => int(150*(shift || 1)));}
59             sub ff {return $can->Font('family' => 'courier', point => int(250*(shift || 1)));}
60             sub f0_5 {return $can->Font('family' => $family, point => 200);}
61             sub f1 {return $can->Font('family' => $family, point => 250);}
62             sub f1_5 {return $can->Font('family' => $family, point => 375);}
63             sub ff0_5 {return $can->Font('family' => "courier", point => 200);}
64             sub ff1 {return $can->Font('family' => "courier", point => 250);}
65             sub ff2 {return $can->Font('family' => "courier", point => 350);}
66             sub ff3 {return $can->Font('family' => "courier", point => 550);}
67             sub f2 {return $can->Font('family' => $family, point => 500);}
68             sub f3 {return $can->Font('family' => $family, point => 750);}
69             sub f4 {return $can->Font('family' => $family, point => 1000);}
70             sub f5 {return $can->Font('family' => $family, point => 1250);}
71              
72              
73             sub mw { return $mainwindow;}
74             sub canvas {return $can }
75             sub h { return $H}
76             sub w { return $W}
77              
78             sub present_start { var_getset((shift),'present_start',@_)};
79             sub diapo_start { var_getset((shift),'diapo_start',@_)};
80             my $steps = 50;
81             sub steps { my ($s,$v) = @_;
82             return $steps unless defined $v;
83             $steps = $v;
84             return $s}
85              
86              
87             sub title_ne {
88             my ($s,$texte) = @_;
89             $can->createText($W,0,'-text',$texte,
90             -anchor => 'ne', -font => $s->f1, -fill => 'red');
91             }
92             sub title_se {
93             my ($s,$texte) = @_;
94             $can->createText($W,$H,'-text', $texte,
95             -anchor => 'se', -font => $s->f1, -fill => 'red');
96             }
97              
98             # internal function for internals needs
99             my $current_item = "";
100              
101             sub enter {
102             $current_item = ($can->gettags('current'))[0];
103             # my $s = Tk::SlideShow::Dict->Get($current_item);
104             # print "entering $current_item\n";
105             # $can->configure(-cursor, 'hand2');
106             }
107             sub leave {
108             # print "leaving $current_item\n";
109             $current_item = "";
110             # $can->configure(-cursor, 'xterm');
111             }
112              
113             sub current_item {
114             return $current_item;
115             }
116              
117              
118             sub exec_if_current {
119             my ($c,$tag,$fct,@ARGS) = @_;
120             # print join('_',@_)."\n";
121             if ($current_item eq $tag) {\&$fct(@ARGS);}
122             }
123              
124             sub init {
125             my ($class,$w,$h) = @_;
126             my $m = new MainWindow;
127             my $c = $m->Canvas;
128             $can = $c;
129             $mainwindow = $m;
130             $present = bless { 'current' => 0, 'mw' => $m, 'fond'=>'ivory',
131             'slides_names' => {}};
132             # This following part is there to force pointer to move
133             # It is used for placing anchor of arrows.
134             eval q{
135             use X11::Protocol;
136             $xprot = X11::Protocol->new();
137             };
138             warn $@ if $@;
139             $H = $h || $m->Display->ScreenOfDisplay->HeightOfScreen;
140             $W = $w || $m->Display->ScreenOfDisplay->WidthOfScreen;
141             print ("H=$H, W=$W\n");
142             $m->geometry('-0-20');
143             $c->configure(-height,$H,-width,$W);
144             $c->pack;
145             $present->init_bindings;
146             $present->init_choosers;
147             return $present;
148             }
149              
150             my $sens = 1;
151             my $setnextslide = sub { $nextslide = 1;$sens = 1;};
152             my $setprevslide = sub { $nextslide = 1;$sens = -1};
153              
154             sub current {
155             my ($class,$val) = @_;
156             if (defined $val) {
157             my $c;
158             if ($val =~ /^\d+$/) {
159             $c = $val;
160             } else {
161             $c = $present->{'slides_names'}{$val} || 0;
162             }
163             $present->{'current'} = $c;
164             } else {
165             return $present->{'current'};
166             }
167             }
168              
169             sub warp {
170             my ($class,$id,$event,$dest) = @_;
171             $can->bind($id,$event, sub {$present->current($dest); $Tk::SlideShow::jumpslide = 1; })
172             }
173              
174             sub save {
175             Tk::SlideShow->addkeyhelp('Press s',
176             'To save sprite positions');
177              
178             $mainwindow->Tk::bind('Tk::SlideShow','', [\&Tk::SlideShow::Placeable::save,$present]);
179             }
180              
181             sub init_choosers {
182             Tk::SlideShow::Sprite->initFontChooser;
183             Tk::SlideShow::Sprite->initColorChooser;
184             }
185              
186             sub load {
187             shift;
188             my $numero = $present->currentName;
189             my $filename = shift || "slide-$numero.pl";
190             print "Loading $filename ...";
191             if (-e $filename) {
192             do "./$filename";
193             warn $@ if $@;
194             }
195             print "done\n";
196             }
197              
198             sub currentName {
199             my $c = $present->current;
200             my %hn = %{$present->{'slides_names'}};
201             while (my ($k,$v) = each %hn) {
202             return $k if $v eq $c;
203             }
204             return $c+1;
205             }
206              
207             #internals
208             sub nbslides {shift; return scalar(@{$present->{'slides'}})}
209              
210             sub bg {
211             my ($class,$v) = @_;
212             if (defined $v) {$present->{'fond'} = $v;} else {return $present->{'fond'};}
213             }
214              
215             # internals
216             sub postscript {
217             shift;
218             my $nu = $present->current;
219             $can->postscript(-file => "slide$nu.ps",
220             -pageheight => "29.7c",
221             -pagewidth => "21.0c",
222             -rotate => 1);
223             }
224             sub photos {
225             my $title = $mainwindow->title;
226             print "title $title\n";
227             my $nu = (lc $title).".00";
228             $nu++ while -f "$nu.gif";
229             my $cmd = "xwd -name $title| xwdtopnm | ppmtogif > $nu.gif";
230             print "command : $cmd\n";
231             system $cmd;
232              
233             }
234              
235             #internals
236             sub warppointer {
237             my ($x,$y) = @_;
238             $xprot->WarpPointer(0, hex($can->id), 0, 0, 0, 0, $x, $y)
239             if $xprot;
240             }
241              
242             # this sub create a popup window with key binding help
243             {
244             my %help;
245             my $helpmenu;
246             use Tk::DialogBox;
247             sub addkeyhelp {
248             shift if $_[0] eq 'Tk::SlideShow';
249             my ($key,$texthelp) = @_;
250             $help{$key} = $texthelp;
251             }
252             sub inithelpmenu {
253             print "Initialising help menu\n";
254             my $m = $mainwindow;
255             $helpmenu = $m->DialogBox(-title,'Help',-buttons,['OK']);
256             my $f = $helpmenu->add('Frame')->pack;
257             my $t = $f->Scrolled('Text')->pack->Subwidget('text');
258             $t->configure(-font,f0_5(),-height,20,-width,60);
259             $t->tagConfigure('key',-foreground,'red');
260             $t->tagConfigure('desc',-foreground,'blue');
261              
262             for (sort keys %help) {
263             $t->insert('end',$_,'key',"\t$help{$_}",'desc',"\n");
264             }
265             }
266            
267             sub posthelp {
268             print "posting menu\n";
269             my $c = Tk::SlideShow->canvas;
270             my $e = $c->XEvent;
271             inithelpmenu unless defined $helpmenu;
272             $helpmenu->Show;
273             print "menu posted\n";
274             }
275            
276             }
277              
278             sub init_bindings {
279             shift;
280             my ($m,$c) = ($mainwindow,$can);
281             $m->bindtags(['Tk::SlideShow',$m,ref($m),$m->toplevel,'all']);
282             $c->bindtags(['Tk::SlideShow']);#,$c,ref($c),$c->toplevel,'all']);
283             $c->bind('all', '' => \&enter);
284             $c->bind('all', '' => \&leave);
285             $c->CanvasFocus;
286             $m->Tk::bind('Tk::SlideShow','<3>', \&shiftaction);
287             addkeyhelp('Click Button 3','To let slide evole one step');
288             $m->Tk::bind('Tk::SlideShow','', \&unshiftaction);
289             addkeyhelp('Click Ctrl-Button 3','To let slide evole one step back');
290             $m->Tk::bind('Tk::SlideShow','', $setnextslide);
291             addkeyhelp('Press Space bar','to go to the next slide');
292             $m->Tk::bind('Tk::SlideShow','', $setprevslide);
293             addkeyhelp('Press BackSpace','to go to the previous slide');
294             $m->Tk::bind('Tk::SlideShow','', sub {$m->destroy; exit});
295             $m->Tk::bind('Tk::SlideShow','', sub {$m->destroy; exit});
296             $m->Tk::bind('Tk::SlideShow','', sub {$m->destroy; exit});
297             addkeyhelp('Press q','to quit');
298             $m->Tk::bind('Tk::SlideShow','

', \&postscript);

299             $m->Tk::bind('Tk::SlideShow','

', \&photos);

300             $m->Tk::bind('Tk::SlideShow','', sub { print "curitem=$current_item"});
301             $m->Tk::bind('Tk::SlideShow','', \&posthelp);
302             addkeyhelp('Press h','to get this help');
303             }
304              
305              
306             #internals
307             { my $repeat_id;
308             sub trace_fond {
309             shift;
310             my $m = $mainwindow;
311             if (ref($present->bg) eq 'CODE') {
312             &{$present->bg};
313             } else {
314             $can->configure(-background, $present->bg);
315             }
316             $repeat_id->cancel if defined $repeat_id;
317             default_footer();
318             $repeat_id = $m->repeat(5000,\&default_footer);
319             }
320             }
321             #internals
322             sub wait {
323             shift;
324             while (Tk::MainWindow->Count)
325             {
326             Tk::DoOneEvent(0);
327             last if $nextslide || $jumpslide;
328             }
329             # print "Je débloque\n";
330             $nextslide = 0;
331             }
332              
333             sub clean {
334             my $class = shift;
335             $can->delete('all');
336             # print "Afters : ".join(' ',$can->after('info'))."\n";
337             for ($can->after('info')) { $can->Tk::after('cancel',$_);}
338             $present->{'action'}= [];
339             $present->{'save_action'}= [];
340             Tk::SlideShow::Placeable->Clean;
341             return $class;
342             }
343              
344             sub a_warp {(shift)->arrive('direct',0,$H,@_); }
345             sub l_warp {(shift)->arrive('direct',0,-$H,@_); }
346             sub a_top {(shift)->arrive('smooth',0,$H,@_); }
347             sub l_top {(shift)->arrive('smooth',0,-$H,@_); }
348             sub a_bottom{(shift)->arrive('smooth',0,-$H,@_);}
349             sub l_bottom{(shift)->arrive('smooth',0,$H,@_);}
350             sub a_left{(shift)->arrive('smooth',$W,0,@_);}
351             sub l_left{(shift)->arrive('smooth',-$W,0,@_);}
352             sub a_right{(shift)->arrive('smooth',-$W,0,@_);}
353             sub l_right{(shift)->arrive('smooth',$W,0,@_);}
354              
355             sub visible {
356             my ($can,$tag) = @_;
357             my ($b0,$b1,$b2,$b3) = $can->bbox($tag);
358             return ($b2 < 0 or $b3 < 0 or $b0 > $W or $b1 > $H ) ?
359             0 : 1 ;
360             }
361              
362             sub arrive {
363             my ($class,$maniere,$dx,$dy,@tags) = @_;
364             return unless $mode eq 'X11';
365             for my $tag (@tags) {
366             if (ref($tag) eq 'ARRAY') {
367             for (@$tag) {
368             $can->move($_,-$dx,-$dy) if visible($can,$_);
369             my $spri = Tk::SlideShow::Dict->Get($_);
370             for my $l ($spri->links) {$l->hide;}
371             }
372             } else {
373             $can->move($tag,-$dx,-$dy) if visible($can,$tag);
374             my $spri = Tk::SlideShow::Dict->Get($tag);
375             for my $l ($spri->links) {$l->hide;}
376              
377             }
378             push @{$present->{'action'}},[$tag,$maniere,$dx,$dy];
379             }
380             return $class;
381             }
382              
383             sub a_multipos {
384             my ($class,$tag,$nbpos,@options) = @_;
385             for my $i (1..$nbpos) {
386             push @{$present->{'action'}},[$tag,'a_chpos',$i,@options];
387             }
388             }
389              
390             sub shiftaction {
391             my $a = shift @{$present->{'action'}};
392             my $c = $can;
393             return unless $a;
394             push @{$present->{'save_action'}},$a;
395             @_ = (@$a);
396             my $tag = shift;
397             my $maniere = shift;
398             my $step = Tk::SlideShow->steps;
399             $maniere eq 'smooth' and
400             do {
401             my ($dx,$dy) = @_;
402             for(my $i=0;$i<$step;$i++){
403             if (ref($tag) eq 'ARRAY') {
404             for (@$tag) {
405             $c->move($_,$dx/$step,$dy/$step);
406             my $spri = Tk::SlideShow::Dict->Get($_);
407             for my $l ($spri->links) {$l->show;}
408             }
409             } else {
410             $c->move($tag,$dx/$step,$dy/$step);
411             my $spri = Tk::SlideShow::Dict->Get($tag);
412             for my $l ($spri->links) {$l->show;}
413             }
414             $c->update;
415             }
416              
417             };
418             $maniere eq 'direct' and
419             do {
420             my ($dx,$dy) = @_;
421             if (ref($tag) eq 'ARRAY') {
422             for (@$tag) {
423             $c->move($_,$dx,$dy);
424             my $spri = Tk::SlideShow::Dict->Get($_);
425             for my $l ($spri->links) {$l->show;}
426             }
427             } else {
428             $c->move($tag,$dx,$dy);
429             my $spri = Tk::SlideShow::Dict->Get($tag);
430             for my $l ($spri->links) {$l->show;}
431             }
432             $c->update;
433             };
434             $maniere eq 'a_chpos' and
435             do {
436             my ($i,@options) = @_;
437             #print "doing $m on tag $tag i=$i\n";
438             my $sprite;
439             if (ref($tag) eq 'ARRAY') {
440             for (@$tag) {
441             $sprite = Tk::SlideShow::Sprite->Get($_);
442             $sprite->chpos($i,@options);
443             }
444             } else {
445             $sprite = Tk::SlideShow::Sprite->Get($tag);
446             $sprite->chpos($i,@options);
447             }
448             };
449             }
450             sub unshiftaction {
451             my $a = pop @{$present->{'save_action'}};
452             my $c = $can;
453             return unless $a;
454             unshift @{$present->{'action'}},$a;
455             @_ = (@$a);
456             my $tag = shift;
457             my $maniere = shift;
458             my $step = Tk::SlideShow->steps;
459             $maniere eq 'smooth' and
460             do {
461             my ($dx,$dy) = @_;
462             for(my $i=0;$i<$step;$i++){
463             if (ref($tag) eq 'ARRAY') {
464             for (@$tag) {
465             $c->move($_,-$dx/$step,-$dy/$step);
466             my $spri = Tk::SlideShow::Dict->Get($_);
467             for my $l ($spri->links) {$l->show;}
468             }
469             } else {
470             $c->move($tag,-$dx/$step,-$dy/$step);
471             my $spri = Tk::SlideShow::Dict->Get($tag);
472             for my $l ($spri->links) {$l->show;}
473             }
474             $c->update;
475             }
476             };
477             $maniere eq 'direct' and
478             do {
479             my ($dx,$dy) = @_;
480             if (ref($tag) eq 'ARRAY') {
481             for (@$tag) {$c->move($_,-$dx,-$dy);}
482             } else { $c->move($tag,-$dx,-$dy);}
483             $c->update;
484             };
485             $maniere eq 'a_chpos' and
486             do {
487             my ($i,@options) = @_;
488             #print "doing $m on tag $tag i=$i\n";
489             my $sprite;
490             if (ref($tag) eq 'ARRAY') {
491             for (@$tag) {
492             $sprite = Tk::SlideShow::Sprite->Get($_);
493             $sprite->chpos($i,@options);
494             }
495             } else {
496             $sprite = Tk::SlideShow::Sprite->Get($tag);
497             $sprite->chpos($i,@options);
498             }
499             };
500             }
501              
502             sub start_slide { $present->clean->trace_fond; }
503              
504             sub fin {
505             $present->add(sub {
506             my $c = $can;
507             $present->start_slide;
508             $can->createText($W/2,$H/2, '-text',"FIN", -font, Tk::SlideShow->f5);
509             });
510             }
511              
512             sub add {
513             my ($class,$name,$sub) = @_;
514             if (@_ == 2) {
515             $sub = $name;
516             $name = @{$present->{'slides'}};
517             }
518            
519             my $diapo = Tk::SlideShow::Diapo->New($name,$sub);
520             push @{$present->{'slides'}},$diapo;
521              
522             if (@_ == 3) {
523             $present->{'slides_names'}{$name} = @{$present->{'slides'}} - 1 ;
524             }
525              
526             return $diapo;
527             }
528              
529              
530             sub play {
531             my ($class,$timetowait) = @_;
532             my $current = $present->current;
533             $present->present_start(time);
534             my $nbslides = @{$present->{'slides'}};
535             while(1) {
536             $jumpslide = 0;
537             $current = $present->current;
538             my $diapo = $present->{'slides'}[$current];
539             print "Executing slide number $current\n";
540             $present->diapo_start(time);
541             $present->start_slide;
542             &{$diapo->code};
543             if (defined $timetowait) {
544             print "Sleeping $timetowait second\n";
545             $mainwindow->update;
546             sleep $timetowait;
547             last if $current == $nbslides-1 ;
548             print "Next one;\n";
549             } else {
550             $present->wait;
551             }
552             # print "jumpslide = $jumpslide\n";
553             next if $jumpslide;
554             $current += $sens;
555             $current %= $nbslides;
556             $present->current($current);
557             }
558             }
559              
560             sub latexheader {
561             my ($p,$value) = @_;
562              
563             return ($p->{'latexheader'} ||
564             "\\documentclass{article}
565             \\usepackage{graphicx}
566             \\begin{document}
567             ")
568             unless defined $value;
569              
570             $p->{'latexheader'} = $value;
571             return $p;
572             }
573              
574             sub latexfooter {
575             my ($p,$value) = @_;
576              
577             return ($p->{'latexfooter'} ||
578             "\\end{document}")
579             unless defined $value;
580              
581             $p->{'latexfooter'} = $value;
582             return $p;
583             }
584              
585             # saving diapo in a single latex file
586             sub latex {
587             my ($s,$latexfname) = @_;
588             $mode ='latex';
589             my $nbdiapo = @{$present->{'slides'}};
590              
591             open(OUT,">$latexfname") or die "$!";
592             print OUT latexheader();
593             for (my $i=0; $i<$nbdiapo; $i++) {
594             $present->current($i);
595             print "Loading slide : ".$s->currentName."\n";
596             $s->start_slide;
597             my $diapo = $present->{'slides'}[$i];
598             &{$diapo->code};
599             $mainwindow->update;
600             my $file = 'slide'.$diapo->name.'.ps';
601             $can->postscript(-file => $file);
602             print OUT "\\includegraphics[width=\\textwidth]{$file}\n";
603             print OUT "".$diapo->latex;
604             print OUT "\n\\newpage";
605             }
606             print OUT latexfooter();
607             close OUT;
608            
609             }
610              
611             # building an html index and gif snapshots
612             sub htmlheader {return ""}
613             sub htmlfooter {return ""}
614             sub html {
615             my ($s,$dirname) = @_;
616             $mode = 'html';
617             my $nbdiapo = @{$present->{'slides'}};
618              
619             if(not -d "$dirname") {
620             mkdir $dirname,0750 or die "$!";
621             }
622             open(INDEX,">$dirname/index.html") or die "$!";
623             print INDEX $s->htmlheader;
624             for (my $i=0; $i<$nbdiapo; $i++) {
625             $present->current($i);
626             my $name = $s->currentName;
627             print "Loading slide $name\n";
628             $s->start_slide;
629             my $diapo = $present->{'slides'}[$i];
630             &{$diapo->code};
631             $mainwindow->update;
632             my $fxwd_name = "/tmp/tkss.$$.xwd";
633             my $f_name = "$dirname/$name.gif";
634             my $fm_name = "$dirname/m.$name.gif";
635             my $fs_name = "$dirname/s.$name.gif";
636             my $title = $mainwindow->title;
637             print "Snapshooting it (xwd -name $title -out $fxwd_name)\n";
638             system("xwd -name $title -out $fxwd_name");
639             print "Converting to gif\n";
640             system("convert $fxwd_name $f_name");
641             my ($w,$h) = ($s->w,$s->h);
642             my ($mw,$mh) = (int($w/2),int($h/2));
643             print "Rescaling it for medium gif (${mw}x${mh}) access\n";
644             system("convert -sample ${mw}x${mh} $f_name $fm_name");
645             my ($sw,$sh) = (int($w/4),int($h/4));
646             print "Rescaling it for small gif (${sw}x${sh}) access\n";
647             system("convert -sample ${sw}x${sh} $f_name $fs_name");
648             print INDEX "
  • $name

  • 649             \n";
    650             open(HTML,">$dirname/$name.html") or die "$!";
    651             print HTML "
    \n";
    652             print HTML $diapo->html;
    653             close HTML;
    654             }
    655             }
    656              
    657             # make an abstract of slides
    658             sub latexabstract {
    659             my ($s,$latexfname) = @_;
    660             $mode ='latex';
    661             my $nbdiapo = @{$present->{'slides'}};
    662              
    663             open(OUT,">$latexfname") or die "$!";
    664             print OUT latexheader();
    665             for (my $i=0; $i<$nbdiapo; $i++) {
    666             $present->current($i);
    667             print "Chargement de la diapo : ".$s->currentName."\n";
    668             $s->start_slide;
    669             my $diapo = $present->{'slides'}[$i];
    670             &{$diapo->code};
    671             $mainwindow->update;
    672             my $file = 'slide'.$diapo->name.'.ps';
    673             $can->postscript(-file => $file);
    674             print OUT "\\noindent\\includegraphics[width=.5\\textwidth]{$file}\n";
    675             print OUT "";
    676             }
    677             print OUT latexfooter();
    678             close OUT;
    679             }
    680              
    681             sub default_footer {
    682             my $now = time;
    683             # print "default footer displaying\n";
    684             # my $td = $now - $present->diapo_start;
    685             # my $tp = $now - $present->present_start;
    686             my $num = $present->current+1;
    687             my $nbs = $present->nbslides;
    688             my $name = $present->currentName;
    689             # $td = $td>60 ? sprintf("%s'%ss",int($td/60),$td%60) : "${td}s";
    690             # $tp = $tp>60 ? sprintf("%s'%ss",int($tp/60),$tp%60) : "${tp}s";
    691            
    692             # my $t = "$name($num($td))/$nbs($tp))";
    693             my $t = "$name($num/$nbs)";
    694             $can->delete('footer');
    695             $can->createText(10,$H - 10,'-text',$t,-anchor,'sw',
    696             -tags,'footer');
    697             }
    698              
    699             sub template {
    700             print qµ#!/usr/local/bin/perl5
    701              
    702             use Tk::SlideShow;
    703             use strict;
    704              
    705             my $p = Tk::SlideShow->init(1024,768) or die;
    706              
    707             $p->save;
    708              
    709             my ($mw,$c,$h,$w) = ($p->mw, $p->canvas, $p->h, $p->w);
    710             my $d;
    711              
    712             #--------------------------------------------
    713             $d = $p->add('summary',
    714             sub {
    715             title('First title');
    716             my @ids = items('a0',"item1 \n item2 \n item3",
    717             -font => $p->f2,-fill, 'red');
    718             $p->load;
    719             $p->a_top(@ids);
    720             });
    721              
    722             $d->html(" ");
    723              
    724             #--------------------------------------------
    725              
    726             sub title { $p->Text('title',shift,-font,$p->f3); }
    727              
    728             sub items {
    729             my ($id,$items,@options) = @_; my @ids;
    730             for (split (/\n/,$items)) {
    731             s/^\s*//; s/\s*$//;
    732             $p->Text($id,$_,@options);
    733             push @ids,$id; $id++;
    734             }
    735             return @ids;
    736             }
    737             sub example {
    738             my ($id,$t,@options) = @_;
    739             $t =~ s/^\s+//; $t =~ s/\s+$//;
    740             my $s = $p->newSprite($id);
    741             my $f = $c->Font('family' => "courier", point => 250, -weight => 'bold');
    742             $c->createText(0,0,-text,'Example',
    743             -font => $f, -tags => $id,
    744             -fill,'red',
    745             -anchor => 'sw');
    746             my $idw = $c->createText(0,0,-text,$t,@options, -tags => $id,
    747             -fill,'yellow', -font => $f,
    748             -anchor => 'nw');
    749             $c->createRectangle($c->bbox($idw), -fill,'black',-tags => $id);
    750             $c->raise($idw);
    751             $s->pan(1);
    752             return $s;
    753             }
    754              
    755              
    756             if (grep (/-html/,@ARGV)) {
    757             $p->html("doc");
    758             exit 0;
    759             }
    760              
    761             $p->current(shift || 0);
    762             $p->play;
    763             µ;
    764             }
    765              
    766             # wrappers
    767              
    768             sub newSprite {shift; return Tk::SlideShow::Sprite->New(@_);}
    769             sub newLink {shift; return Tk::SlideShow::Link->New(@_); }
    770             sub newArrow {shift; return Tk::SlideShow::Arrow->New(@_); }
    771             sub newDblArrow {shift; return Tk::SlideShow::DblArrow->New(@_); }
    772             sub newOrg {shift; return Tk::SlideShow::Org->New(@_); }
    773              
    774              
    775             sub Text {return Tk::SlideShow::Sprite::text(@_);}
    776             sub Framed {return Tk::SlideShow::Sprite::framed(@_);}
    777             sub Image {return Tk::SlideShow::Sprite::image(@_);}
    778             sub Anim {return Tk::SlideShow::Sprite::anim(@_);}
    779             sub Oval {return Tk::SlideShow::Oval::New(@_);}
    780              
    781             sub TickerTape {return Tk::SlideShow::Sprite::tickertape(@_);}
    782             sub Compuman {return Tk::SlideShow::Sprite::compuman(@_);}
    783              
    784             1;
    785              
    786             # Local Variables: ***
    787             # mode: perl ***
    788             # End: ***
    789              
    790              
    791             __END__