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',' |
||||||
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', ' |
||||||
284 | $c->bind('all', ' |
||||||
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',' |
||||||
289 | addkeyhelp('Click Ctrl-Button 3','To let slide evole one step back'); | ||||||
290 | $m->Tk::bind('Tk::SlideShow',' |
||||||
291 | addkeyhelp('Press Space bar','to go to the next slide'); | ||||||
292 | $m->Tk::bind('Tk::SlideShow',' |
||||||
293 | addkeyhelp('Press BackSpace','to go to the previous slide'); | ||||||
294 | $m->Tk::bind('Tk::SlideShow',' |
||||||
295 | $m->Tk::bind('Tk::SlideShow',' |
||||||
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',' |
||||||
301 | $m->Tk::bind('Tk::SlideShow',' |
||||||
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 " |
||||||
649 | ![]() |
||||||
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__ |