line
stmt
bran
cond
sub
pod
time
code
1
=head1 NAME
2
3
Image::Shoehorn::Gallery - generate "smart" HTML slideshows from a directory of image files.
4
5
=head1 SYNOPSIS
6
7
use Image::Shoehorn::Gallery;
8
9
Image::Shoehorn::Gallery->create({
10
source => "~/my-images",
11
directory => "/htdocs/images",
12
url => "http://mysite.com/images",
13
static => 1,
14
scales => [
15
[ "thumb","75x50" ],
16
[ "default", "50%" ],
17
[ "small","25%" ],
18
[ "medium","50%" ],
19
],
20
scale_if => { x => 400 , y => 300 },
21
iptc => ["headline","caption/abstract"],
22
set_lang => "en-ca",
23
set_styles => {
24
image => [
25
{title=>"my css",href=>"/styles.css"},
26
],
27
},
28
set_index_images => { default => 1 },
29
});
30
31
=head1 DESCRIPTION
32
33
Image::Shoehorn::Gallery generates HTML slideshows from a directory of image files. But wait, there's more!
34
35
Image::Shoehorn uses I, I and a small army of I packages allowing you to :
36
37
=over 4
38
39
=item *
40
41
Create one, or more, scaled versions of an image, and their associate HTML pages. Scaled version may also be defined but left to be created at a later date by I.
42
43
Associate HTML are always "baked", rather than "fried" (see also : http://www.aaronsw.com/weblog/000404 )
44
45
=item *
46
47
Read a user-defined list of IPTC and EXIF metadata fields from each image and include the data in the HTML pages.
48
49
=item *
50
51
Generate named indices and next/previous links by reading IPTC "headline" data.
52
53
=item *
54
55
Define one, or more, SAX filters to be applied to "index" and individual "image" documents before they are passed the final I filter for output.
56
57
The default look and feel of the gallery pages is pretty plain, but you could easily define a "foofy design" XSL stylesheet to be applied with the I SAX filter:
58
59
60
version = "1.0" >
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
=item *
78
79
Generates valid XHTML (strict) and CSS!
80
81
=back
82
83
=cut
84
85
1
1
35769
use strict;
1
2
1
47
86
package Image::Shoehorn::Gallery;
87
88
$Image::Shoehorn::Gallery::VERSION = '0.22';
89
90
1
1
6
use Carp;
1
1
1
53
91
1
1
897
use Carp::Heavy;
1
129
1
28
92
1
1
5
use Digest::MD5 qw (md5_hex);
1
2
1
50
93
94
1
1
848
use DirHandle;
1
2130
1
21
95
96
1
1
6
use File::Basename;
1
1
1
92
97
1
1
729
use File::Copy;
1
2401
1
62
98
1
1
7
use File::Path;
1
2
1
58
99
100
1
1
1554
use Image::Shoehorn;
0
0
101
use Image::Size qw (imgsize);
102
103
use IO::File;
104
use XML::SAX::Writer;
105
use XML::Filter::XML_Directory_2XHTML;
106
use XML::Directory::SAX;
107
108
use XML::SAX::Machines qw (Pipeline);
109
$XML::SAX::ParserPackage = "XML::SAX::Expat";
110
111
#
112
113
my $directory = undef;
114
my $source = undef;
115
my $dest = undef;
116
117
my $url = undef;
118
119
my $static = undef;
120
my $scales = {};
121
my $scaleif = {};
122
123
my $views = [];
124
my $iptc = [];
125
my $exif = [];
126
127
my $maxdepth = undef;
128
my $encoding = undef;
129
my $lang = undef;
130
131
my $styles = {};
132
my $filters = {};
133
my $images = {};
134
135
my $verbose = 0;
136
my $force = 0;
137
138
my $conf = undef;
139
140
#
141
142
my $cur_source = undef;
143
my $cur_dest = undef;
144
145
my $visit = 0;
146
147
=head1 PACKAGE METHODS
148
149
=head2 __PACKAGE__->create(\%args)
150
151
This is the magic spell that will create your galleries.
152
153
Valid arguments are :
154
155
=over 4
156
157
=item *
158
159
B
160
161
String.
162
163
This is the path to the directory that you want to read images from.
164
165
=item *
166
167
B
168
169
String.
170
171
This is the path to directory that you want to write images, and HTML files, to. If undefined, then the value of I will be used.
172
173
=item *
174
175
B
176
177
String.
178
179
Deprecated in favour of I and I. If present, it will be used as *both* the source and destination directories.
180
181
=item *
182
183
B
184
185
String.
186
187
The URL that maps to I on your webserver.
188
189
=item *
190
191
B
192
193
Int.
194
195
The maximum number of sub directories to munge and render.
196
197
=item *
198
199
B
200
201
Boolean.
202
203
Used in conjunction with the I option for generating scaled versions of an image and their URLs.
204
205
If false, or not defined, the package will assume that you have configured I to generate scaled versions of an image.
206
207
If true, then the package will output image URLs that map to static images on the filesystem and ask I to create the new files, or update existing ones.
208
209
Note, however, that the "thumb" (thumbnail) image will be generated regardless of whether or not you are using I. This is actually a feature since you would peg your machine having to create all those thumbnails the first time you loaded an especially large index page.
210
211
=item *
212
213
B
214
215
Array reference containing one, or more, array referece.
216
217
Each of the child arrays should contain (2) elements :
218
219
=over 4
220
221
=item *
222
223
I
224
225
A name like "small" or "medium". This name is used as part of the naming scheme for images that have been scaled and their associate HTML pages.
226
227
Names can be pretty much anything you'd like, with the exception of "thumb" and "default" which are discussed below.
228
229
=item *
230
231
I
232
233
These are required whether or not you are going to be generate static images. Even if you are going to render your images on the fly using I, the HTML spec (hi Karl) mandates that you provide height and widgth attributes for your img elements. So...
234
235
Takes arguments in the same form as I which are, briefly :
236
237
=over 4
238
239
=item *
240
241
B%
242
243
=item *
244
245
BxB
246
247
=item *
248
249
xB
250
251
=item *
252
253
Bx
254
255
=back
256
257
There are two special scale names :
258
259
=over 4
260
261
=item *
262
263
I
264
265
You must define a thumb scale. It is used to generate thumbnails for the index page which are, in turn, used when generating the individual HTML pages for each image.
266
267
=item *
268
269
I
270
271
I.
272
273
Suppose your source images are very large and you would like to use a scaled version as the default image in your gallery. You may want to do this because you are concerned about people doing bad things with your high quality images or you don't want to pay the additional charges that your web-hosting service will charge you for all those 2-3 MB files. Or both.
274
275
The default image is the default view and its dimensions are what all other scales are keyed off of.
276
277
For example, your source image is 1200x840 and you define two scales (not including the 'thumb' scale.) The first is called 'small' and the second 'default'; both have a value of '50%'.
278
279
I
280
281
Since you have defined a default image, it will be created in your source directory with the same basename as the source image itself. It will be half the size of the original, 600x420. The 'small' version will be created and will be half the size of the 'default' image, rather than the source, or 300x210.
282
283
B You could easily overwrite all your source images with newer default "sources".
284
285
=back
286
287
=back
288
289
=item *
290
291
B
292
293
Hash reference.
294
295
Define height and width values that will be used to determine whether or not an image should actually be scaled.
296
297
For example, it is unlikely that you will need to create a small version (say 25% the size of the original) if your source file is 100 by 150 pixels. You might - that's your business - but atleast this way you can opt out.
298
299
Images will only be scaled if their height or width is greater than the height and/or width listed in this argument.
300
301
You may define one or both of the following :
302
303
=over 4
304
305
=item *
306
307
I
308
309
Int.
310
311
The minimum width that an image must have to be scaled.
312
313
=item *
314
315
I
316
317
Int.
318
319
The minimum height that an image must have to be scaled.
320
321
=back
322
323
Note that although multiple image files may not be created, if the source image is smaller than the dimensions passed in this argument, their associate HTML files will be generated. Don't worry, they'll point to the same unscaled image.
324
325
Think of it as the glass being half full.
326
327
=item *
328
329
B
330
331
Array reference.
332
333
A list of IPTC fields to read from an image. Fields are presented in the order they are defined.
334
335
For a complete list of IPTC fields, please consult the L.
336
337
=item *
338
339
B
340
341
Array reference.
342
343
A list of EXIF fields to read from an image. Fields are presented in the order they are defined.
344
345
For a complete list of EXIF fields, please consult http://www.ba.wakwak.com/~tsuruzoh/Computer/Digicams/exif-e.html
346
347
=item *
348
349
B
350
351
String.
352
353
Set the language code for your HTML documents.
354
355
=item *
356
357
B
358
359
Hash reference.
360
361
Used to override the default CSS for either and "index" page or an individual "image" page.
362
363
Valid hash keys are :
364
365
=over 4
366
367
=item *
368
369
B
370
371
=item *
372
373
B
374
375
=back
376
377
Where each key expects an array ref of hash refs whose keys are :
378
379
=over 4
380
381
=item *
382
383
I
384
385
=item *
386
387
I
388
389
Default is ""
390
391
=item *
392
393
I
394
395
Default is "stylesheet"
396
397
=item *
398
399
I
400
401
Default is "all".
402
403
=back
404
405
Styles will be added in the order that they are defined in the array ref.
406
407
The default CSS styles are outlined below.
408
409
=item *
410
411
B
412
413
Hash reference
414
415
Define one or more additional filters to be applied to either an "index" or individual "image" page.
416
417
Valid hash keys are :
418
419
=over 4
420
421
=item *
422
423
B
424
425
=item *
426
427
B
428
429
=back
430
431
Filters are applied last, before events are finally handed off to I and in the order that they are defined.
432
433
Example:
434
435
package MySAX;
436
use base qw (XML::SAX::Base);
437
438
sub start_element {
439
my $self = shift;
440
my $data = shift;
441
442
$self->SUPER::start_element($data);
443
444
if ($data->{Name} eq "body") {
445
$self->SUPER::start_element({Name=>"h1"});
446
$self->SUPER::characters({Data=>"hello world"});
447
$self->SUPER::end_element({Name=>"h1"});
448
}
449
}
450
451
package main;
452
453
# The following will add hello world
454
# at the top of all your 'image' pages. Woot!
455
456
use Image::Shoehorn::Gallery;
457
Image::Shoehorn::Gallery->create({
458
# ...
459
460
set_filters => { image => [ MySAX->new() ]},
461
});
462
463
=item *
464
465
B
466
467
Hash reference.
468
469
Define images to associate with files in a directory listing. Valid keys are :
470
471
=over 4
472
473
=item *
474
475
I
476
477
Image to associate with a file whose media type is "image"
478
479
Default is to generate and include a thumbnail, as defined by the "thumb" scale option (see above.)
480
481
=item *
482
483
I
484
485
Image to associate with a directory.
486
487
=item *
488
489
I
490
491
Image to associate with a file whose media type is not "image"
492
493
Example :
494
495
# Use the default Apache icons
496
497
my %images = (
498
directory => {
499
src => "/icons/dir.gif",
500
height => "20",
501
width => "20",
502
alt => "ceci n'est pas un dossier",
503
},
504
file => {
505
src => "/icons/unknown.gif",
506
height => "20",
507
width => "20",
508
alt => "ceci n'est pas un fichier",
509
},
510
);
511
512
Image::Shoehorn::Gallery->create({
513
# ...
514
set_index_images => \%images,
515
});
516
517
=item *
518
519
I
520
521
Boolean.
522
523
This is just a shortcut to use the default I handler and the handlers for I and I example described above.
524
525
If you are not using Apache for your web server and/or have not aliased the Apache icons folder to /icons, it won't do you much good.
526
527
=back
528
529
Valid keys arguments are either :
530
531
=over 4
532
533
=item *
534
535
B
536
537
Containing key/value pairs for the following image attributes :
538
539
=over 4
540
541
=item *
542
543
I
544
545
=item *
546
547
I
548
549
=item *
550
551
I
552
553
=item *
554
555
I
556
557
=back
558
559
=item *
560
561
B
562
563
The code reference will be passed the absolute path of the current image and is expected to return a hash reference similar to the one described above.
564
565
=back
566
567
This is an I-ism. Please consult docs for further details.
568
569
=item *
570
571
B
572
573
String.
574
575
Default is "UTF-8"
576
577
=item *
578
579
B
580
581
Int.
582
583
By default neither the scaled version of an image, nor the associate HTML files, will be created unless the source image has a more recent modification date.
584
585
You can use this option to override this check.
586
587
If the value is greater than zero, HTML files will be regenerated.
588
589
If the value is greater than one, images and HTML files will be regenerated.
590
591
=item *
592
593
B
594
595
Boolean.
596
597
=back
598
599
=cut
600
601
sub create {
602
my $pkg = shift;
603
my $args = shift;
604
605
#
606
607
%IPTC::iptc = ();
608
%IPTC::views = ();
609
610
%EXIF::exif = ();
611
%EXIF::views = ();
612
613
$source = undef;
614
$dest = undef;
615
616
$cur_source = undef;
617
$cur_dest = undef;
618
619
$url = undef;
620
$static = undef;
621
622
$scales = {};
623
$scaleif = {};
624
625
$views = [];
626
$iptc = [];
627
$exif = [];
628
$conf = undef;
629
$maxdepth = undef;
630
631
$styles = {index=>[],image=>[]};
632
$filters = {index=>[],image=>[]};
633
$images = {};
634
635
$encoding = undef;
636
$lang = undef;
637
$verbose = 0;
638
$force = 0;
639
640
#
641
642
if ($args->{conf}) {
643
return &read_conf($conf);
644
}
645
646
#
647
648
if ($args->{directory}) {
649
$source = $args->{'directory'};
650
$dest = $args->{'directory'};
651
}
652
653
$source ||= $args->{source};
654
655
if (! -d $source) {
656
carp "Source ($source) is not a directory\n";
657
return undef;
658
}
659
660
$dest ||= $args->{'destination'} || $source;
661
662
#
663
664
if (ref($args->{scales}) ne "ARRAY") {
665
carp "Scales must be passes as an array reference of array references.\n";
666
return 0;
667
}
668
669
#
670
671
foreach ("iptc","exif") {
672
if ((exists($args->{$_})) && (ref($args->{$_}) ne "ARRAY")) {
673
carp "$_ must be passed as an array reference. Ignoring.\n";
674
}
675
}
676
677
#
678
679
foreach (@{$args->{scales}}) {
680
if (ref($_) ne "ARRAY") {
681
carp "Arguments for 'scales' must be passed as an array ref of array refs. Ignoring\n";
682
next;
683
}
684
685
unless ($_->[0] =~ /^(thumb|default)$/) {
686
push @{$views},$_->[0];
687
}
688
689
if ($_->[1]) {
690
$scales->{$_->[0]} = $_->[1];
691
}
692
}
693
694
#
695
696
if ($args->{scaleif}) {
697
if (ref($args->{scaleif}) eq "HASH") {
698
map {
699
$scaleif->{$_} = $args->{scaleif}->{$_} if (defined($args->{scaleif}->{$_}));
700
} qw (x y);
701
702
} else {
703
carp "Argument 'scaleif' must be passed as a hash reference. Ignoring.\n";
704
}
705
}
706
707
#
708
709
if ($args->{set_index_images}) {
710
if (ref($args->{set_index_images}) eq "HASH") {
711
712
if (exists($args->{set_index_images}->{default})) {
713
$images->{default} = 1;
714
}
715
716
else {
717
foreach ("image","file","directory") {
718
next unless (exists $args->{set_index_images}->{$_});
719
720
if (ref($args->{set_index_images}->{$_}) =~ /^(HASH|CODE)$/) {
721
$images->{$_} = $args->{set_index_images}->{$_};
722
}
723
724
else {
725
carp "The $_ field must be passed as a hash ref or a code ref. Ignoring.\n";
726
}
727
}
728
}
729
}
730
731
else {
732
carp "Argument 'set_index_images' must be passed as hash reference. Ignoring.\n";
733
}
734
}
735
736
#
737
738
if ($args->{set_styles}) {
739
if (ref($args->{set_styles}) eq "HASH") {
740
741
foreach my $type ("image","index") {
742
next if (! exists($args->{set_styles}->{$type}));
743
744
if (ref($args->{set_styles}->{$type}) ne "ARRAY") {
745
carp "Styles for $type must be passed as an array ref. Ignoring.\n";
746
next;
747
}
748
749
$styles->{$type} = $args->{set_styles}->{$type};
750
}
751
}
752
753
else {
754
carp "The argument 'set_styles' must be passed as a hash reference. Ignoring.\n";
755
}
756
}
757
758
#
759
760
if ($args->{set_filters}) {
761
if (ref($args->{set_filters}) eq "HASH") {
762
763
foreach my $type ("image","index") {
764
next if (! exists($args->{set_filters}->{$type}));
765
766
if (ref($args->{set_filters}->{$type}) ne "ARRAY") {
767
carp "Filters for $type must be passed as an array ref. Ignoring.\n";
768
next;
769
}
770
771
$filters->{$type} = $args->{set_filters}->{$type};
772
}
773
}
774
775
else {
776
carp "You argument 'set_filters' must be passed as a hash reference. Ignoring.\n";
777
}
778
}
779
780
#
781
782
if (! $scales->{'thumb'}) {
783
carp;
784
return 0;
785
}
786
787
#
788
789
if (defined($args->{'maxdepth'})) {
790
$maxdepth = $args->{'maxdepth'};
791
}
792
793
#
794
795
$url = $args->{'url'};
796
$static = $args->{'static'};
797
798
$iptc = $args->{'iptc'} if ($args->{'iptc'});
799
$exif = $args->{'exif'} if ($args->{'exif'});
800
801
$encoding = $args->{'set_encoding'} if ($args->{'set_encoding'});
802
$lang = $args->{'set_lang'} if ($args->{'set_lang'});
803
804
$verbose = $args->{verbose};
805
$force = $args->{force};
806
807
#
808
809
&visit($source);
810
&make_index($source);
811
812
#
813
814
return 1;
815
}
816
817
sub read_conf {
818
carp "I don't know how to read conf files yet.\n";
819
return 0;
820
}
821
822
sub visit {
823
my $path = shift;
824
825
print STDERR "Visiting $path\n"
826
if ($verbose);
827
828
$visit ++;
829
830
if ((defined($maxdepth)) && ($visit > $maxdepth)) {
831
return;
832
}
833
834
my $dh = DirHandle->new($path);
835
836
foreach ($dh->read()) {
837
next if $_ =~ /^\./;
838
my $loc = "$path/$_";
839
840
if (-d $loc) {
841
if (&make_index($loc)) {
842
&visit($loc);
843
}
844
}
845
}
846
847
$visit --;
848
}
849
850
sub make_index {
851
my $path = shift;
852
853
print STDERR "[make-index] Making $path\n"
854
if ($verbose);
855
856
$cur_source = $path;
857
$cur_dest = __PACKAGE__->source_to_dest($path);
858
859
#
860
861
my $src = __PACKAGE__->source_to_dest($path);
862
863
print STDERR "Making '$cur_dest'..."
864
if ($verbose);
865
866
if ((! -d $cur_dest) && (! mkpath($cur_dest,0,0755))) {
867
print STDERR "Failed to make '$cur_dest', $!\n";
868
return 0;
869
}
870
871
print STDERR "ok\n"
872
if ($verbose);
873
874
#
875
876
my $html = $cur_dest."/index.html";
877
my $tmp = $html.".tmp";
878
879
#
880
881
my $output = IO::File->new(">$tmp");
882
883
if (! $output) {
884
carp "Failed to open '$tmp' for writing, $!\n";
885
return 0;
886
}
887
888
#
889
890
my $writer = XML::SAX::Writer->new(Output=>$output);
891
892
my $filters = __PACKAGE__->filters("index");
893
894
my $machine = Pipeline(
895
"LocalSAX_FloatingThumbs",
896
"LocalSAX_Breadcrumbs",
897
((scalar(@{$filters})) ? @{$filters} : ()),
898
$writer);
899
900
#
901
902
# This is broken, I know.
903
# There appears to be some degree of funkiness going
904
# on with the inheritance chain for 2XHTML that is
905
# preventing the SAX::Machine from getting the output
906
# of 2XHTML and passing it on to $writer. I think, anyway.
907
908
my $xhtml = XML::Filter::XML_Directory_2XHTML->new(Handler=>$machine);
909
910
$xhtml->debug(0);
911
912
if ($encoding) {
913
$xhtml->set_encoding($encoding);
914
}
915
916
if ($lang) {
917
$xhtml->set_lang($lang);
918
}
919
920
$xhtml->exclude_root(1);
921
$xhtml->exclude(
922
starting => ["\\."],
923
ending => ["html","tmp","~"],
924
matching => ["^(.*)-(".join("|","thumb",@{$views}).")\.([^\.]+)\$"],
925
);
926
927
#
928
929
my $css = __PACKAGE__->styles("index");
930
931
if (scalar(@$css)) {
932
$xhtml->set_styles($css);
933
}
934
935
else {
936
$xhtml->set_style(\qq(
937
body {
938
background-color: #ffffff;
939
margin:0;
940
}
941
942
.breadcrumbs {
943
display:block;
944
background-color: #f5f5dc;
945
padding:5px;
946
margin-bottom:5px;
947
border-bottom: solid thin;
948
}
949
950
.breadcrumbs-spacer {
951
952
}
953
954
.directory { margin:10px;float:left; padding: 5px;}
955
956
.file { margin:10px;float:left;padding: 5px;}
957
958
.spacer { clear:both; }
959
960
.thumbnail { display:block;width:100px;float:left;}
961
962
.file ul { float:left;}
963
964
));
965
}
966
967
#
968
969
if ($images->{default}) {
970
$xhtml->set_images({
971
image => \&define_thumbnail,
972
directory => {
973
src => "/icons/dir.gif",
974
height => "20",
975
width => "20",
976
alt => "directory",
977
},
978
file => {
979
src => "/icons/unknown.gif",
980
height => "20",
981
width => "20",
982
alt => "unknown file",
983
}
984
});
985
}
986
987
else {
988
my $args = { image => ($images->{'image'} || \&define_thumbnail) };
989
990
foreach ("file","directory") {
991
if ($images->{$_}) { $args->{$_} = $images->{$_} };
992
}
993
994
$xhtml->set_images($args);
995
}
996
997
#
998
999
$xhtml->set_callbacks({
1000
linktext => \&format_linktext,
1001
link => sub {
1002
return (-d $_[0]) ?
1003
__PACKAGE__->format_link($_[0]) :
1004
__PACKAGE__->page_for_image([__PACKAGE__->format_link($_[0])]);
1005
},
1006
});
1007
1008
#
1009
1010
$xhtml->set_handlers({file=>LocalSAX_Scaled->new(Handler=>$writer)});
1011
1012
#
1013
1014
my $directory = XML::Directory::SAX->new(Handler=>$xhtml);
1015
1016
$directory->set_maxdepth(0);
1017
$directory->set_details(2);
1018
$directory->order_by("a");
1019
1020
$directory->parse_dir($path);
1021
1022
#
1023
1024
$output->close();
1025
move $tmp,$html;
1026
1027
#
1028
1029
&make_slides($html);
1030
return 1;
1031
}
1032
1033
sub make_slides {
1034
my $index = shift;
1035
1036
if (! scalar(@{&LocalSAX_Scaled::files()})) {
1037
return 1;
1038
}
1039
1040
foreach my $img (@{&LocalSAX_Scaled::files()}) {
1041
1042
# This is a bug, not a feature
1043
next if ($img =~ /^(.*)\.html$/);
1044
1045
print STDERR "[make-slide] image is '$img'\n"
1046
if ($verbose);
1047
1048
my $sid = "ID".&md5_hex("/".&basename($img));
1049
1050
foreach my $scale ("",@{$views}) {
1051
1052
my $html = __PACKAGE__->source_to_dest(__PACKAGE__->page_for_image([$img,$scale]));
1053
1054
#
1055
1056
if (! $force) {
1057
(my $source = $img) =~ s/^(.*)-($scale)\.([^\.]+)$/$1\.$3/;
1058
1059
unless ((stat($source))[9] > (stat($html))[9]) {
1060
next;
1061
}
1062
}
1063
1064
#
1065
1066
my $output = IO::File->new(">$html");
1067
my $writer = XML::SAX::Writer->new(Output=>$output);
1068
1069
my $xsl = MyXSLT->new();
1070
$xsl->set_stylesheet_string(STYLESHEET->data());
1071
1072
# This is really what I'd like to do but
1073
# I can't get it to work :-(
1074
# open(STYLESHEET,"<&=STYLESHEET::DATA");
1075
# $xsl->set_stylesheet_fh(\*STYLESHEET);
1076
1077
my $do_scale = __PACKAGE__->do_scale($img,$scales->{default});
1078
1079
$xsl->set_stylesheet_parameters(
1080
id => $sid,
1081
doscale => $do_scale,
1082
scale => $scale,
1083
scales => ($do_scale) ? join(",",@{&views()}) : "",
1084
static => ($static) ? (scalar(keys %$scales) > 1) ? 2 : $static : 0,
1085
);
1086
1087
my $filters = __PACKAGE__->filters("image");
1088
1089
my $machine = Pipeline(
1090
$xsl,
1091
"LocalSAX_Image",
1092
"LocalSAX_Breadcrumbs",
1093
((scalar(@{$filters})) ? @{$filters} : ()),
1094
$writer,
1095
);
1096
1097
print STDERR "[make-slide] Making $html..."
1098
if ($verbose);
1099
1100
eval { $machine->parse_uri($index); };
1101
1102
if ($@) {
1103
carp "Ack! Failed to parse $index, $@\n";
1104
1105
$output->close();
1106
next;
1107
}
1108
1109
$output->close();
1110
1111
print STDERR "OK\n"
1112
if ($verbose);
1113
}
1114
}
1115
1116
return 1;
1117
}
1118
1119
sub format_link {
1120
my $pkg = shift;
1121
1122
(my $link = $_[0]) =~ s/$source/$url/;
1123
return $link;
1124
}
1125
1126
sub unformat_link {
1127
my $pkg = shift;
1128
1129
(my $path = $_[0]) =~ s/$url/$source/;
1130
return $path;
1131
}
1132
1133
sub page_for_image {
1134
my $pkg = shift;
1135
1136
my $suffix = ($_[0]->[1]) ? "-".$_[0]->[1].".html" : ".html";
1137
(my $output = $_[0]->[0]) =~ s/(.*)\.([^\.]+)$/$1$suffix/;
1138
1139
return $output;
1140
}
1141
1142
sub source_to_dest {
1143
my $pkg = shift;
1144
$_[0] =~ /^($source)(\/(.*))?$/;
1145
return $dest.$2;
1146
}
1147
1148
sub define_thumbnail {
1149
my $path = shift;
1150
1151
my ($x,$y);
1152
1153
($x,$y) = imgsize($path);
1154
($x,$y) = Image::Shoehorn->scaled_dimensions([$x,$y,undef,50]);
1155
1156
my $title = &basename($path);
1157
1158
if (my $iptc = IPTC->get($path)) {
1159
$title = $iptc->Attribute("headline") || $iptc->Attribute("caption/abstract") || $title;
1160
}
1161
1162
my $src = __PACKAGE__->format_link($path);
1163
1164
if ($static) {
1165
$src =~ s/^(.*)\.([^\.]+)$/$1-thumb\.$2/;
1166
} else {
1167
$src .= "?scale=thumb";
1168
}
1169
1170
return {
1171
src => $src,
1172
height => $y,
1173
width => $x,
1174
alt => $title,
1175
};
1176
}
1177
1178
sub format_linktext {
1179
1180
if (-d $_[0]) {
1181
return $_[1];
1182
}
1183
1184
if (XML::Filter::XML_Directory_Pruner->mtype($_[0]) ne "image") {
1185
return $_[1];
1186
}
1187
1188
if (my $iptc = IPTC->get($_[0])) {
1189
return $iptc->Attribute("headline");
1190
}
1191
1192
return $_[1];
1193
}
1194
1195
sub do_scale {
1196
my $pkg = shift;
1197
my $uri = shift;
1198
my $def = shift;
1199
1200
if (! keys %$scaleif) {
1201
return 1;
1202
}
1203
1204
my ($x,$y) = Image::Size::imgsize($uri);
1205
1206
if ($def) {
1207
($x,$y) = Image::Shoehorn->dimensions_for_scale($x,$y,$def);
1208
}
1209
1210
if (defined($scaleif->{'x'}) && defined($scaleif->{'y'})) {
1211
if (($x <= $scaleif->{'x'}) && ($y <= $scaleif->{'y'})) {
1212
return 0;
1213
}
1214
}
1215
1216
elsif (defined($scaleif->{'x'})) {
1217
if ($x <= $scaleif->{'x'}) {
1218
return 0;
1219
}
1220
}
1221
1222
elsif (defined($scaleif->{'y'})) {
1223
if ($y <= $scaleif->{'y'}) {
1224
return 0;
1225
}
1226
}
1227
1228
else {
1229
return 1;
1230
}
1231
1232
return 1;
1233
}
1234
1235
sub source {
1236
return $source;
1237
}
1238
1239
sub destination {
1240
return $dest;
1241
}
1242
1243
sub url {
1244
return $url;
1245
}
1246
1247
sub cur_source {
1248
return $cur_source;
1249
}
1250
1251
sub cur_destination {
1252
return $cur_dest;
1253
}
1254
1255
sub scales {
1256
return $scales;
1257
}
1258
1259
sub views {
1260
return $views;
1261
}
1262
1263
sub iptc {
1264
return $iptc;
1265
}
1266
1267
sub exif {
1268
return $exif;
1269
}
1270
1271
sub styles {
1272
return $styles->{$_[1]};
1273
}
1274
1275
sub filters {
1276
return $filters->{$_[1]};
1277
}
1278
1279
sub encoding {
1280
return $encoding;
1281
}
1282
1283
sub lang {
1284
return $lang;
1285
}
1286
1287
sub force {
1288
return $force;
1289
}
1290
1291
sub verbose {
1292
return $verbose;
1293
}
1294
1295
sub scale_if {
1296
return $scaleif;
1297
}
1298
1299
=head1 NAMING CONVENTIONS
1300
1301
Let's say you've got an image named :
1302
1303
20020603-my-new-toy.jpg
1304
1305
You've defined two "views" to be generated : small and medium. The following files will be created :
1306
1307
20020603-my-new-toy.html
1308
20020603-my-new-toy-thumb.jpg **
1309
20020603-my-new-toy-small.jpg *
1310
20020603-my-new-toy-small.html
1311
20020603-my-new-toy-medium.jpg *
1312
20020603-my-new-toy-medium.html
1313
1314
* If you are rendering scaled images on the fly, with I,
1315
these files not be created until such a time as they are actually viewed
1316
1317
** Thumbnails are always generated, regardless of the I flag. As mentioned
1318
earlier, this is a feature. If you have a directory with many images, you will peg
1319
your web server the first time you have to render all those images for the index
1320
listing.
1321
1322
The package uses I which, a few steps up the inheritance tree, uses I to exclude certain specific files from the directory (index) listing. The exact rule set currently used it :
1323
1324
$xhtml->exclude(
1325
starting => ["\\."],
1326
ending => ["html","tmp","~"],
1327
# e.g. ending with "-thumb.jpg","-small.jpg" or "-medium.jpg"
1328
matching => ["^(.*)-(".join("|","thumb",@{$views}).")\.([^\.]+)\$"],
1329
);
1330
1331
The plan is to, eventually, teach I to include and exclude widgets based on media type, at which point we could simply do :
1332
1333
$xhtml->include( media => "image" );
1334
1335
But until then, it is recommended that you make sure your source images don't match the "matching" pattern describe above. Or if you just think I'm an idiot and have a better rule-set, send my a note and I'll probably include it.
1336
1337
=head1 CSS
1338
1339
The following CSS classes are defined for the HTML generated by the package.
1340
1341
They are provided as a reference in case you want to specify your own CSS stylesheet.
1342
1343
=head2 "index" page
1344
1345
body {
1346
background-color: #ffffff;
1347
margin:0;
1348
}
1349
1350
.breadcrumbs {
1351
display:block;
1352
background-color: #f5f5dc;
1353
padding:5px;
1354
margin-bottom:5px;
1355
border-bottom: solid thin;
1356
}
1357
1358
.breadcrumbs-spacer {}
1359
1360
.directory { margin-bottom:5px;clear:left; padding: 5px;}
1361
1362
.file { margin-bottom:5px;clear:left;padding: 5px;}
1363
1364
.thumbnail { display:block;width:100px;float:left;}
1365
1366
.file ul { float:left;}
1367
1368
=head2 "image" page
1369
1370
1371
body {
1372
background-color: #ffffff;
1373
margin:0;
1374
}
1375
1376
.breadcrumbs {
1377
display:block;
1378
background-color: #f5f5dc;
1379
padding:5px;
1380
margin-bottom:5px;
1381
border-bottom: solid thin;
1382
}
1383
1384
.breadcrumbs-spacer {}
1385
1386
.directory {
1387
padding: 5px;
1388
}
1389
1390
.file {
1391
padding: 5px;
1392
}
1393
1394
.menu {
1395
margin-bottom:5px;
1396
padding:5px;
1397
}
1398
1399
.menu-link-previous {
1400
padding-right : 10px;
1401
}
1402
1403
.menu-link-previous img {
1404
margin-right:15px;
1405
}
1406
1407
.menu-link-index {
1408
font-weight:600;
1409
}
1410
1411
.menu-link-next {
1412
padding-left : 10px;
1413
}
1414
1415
.menu-link-next img {
1416
margin-left:15px;
1417
}
1418
1419
.content {
1420
padding-top:20px;
1421
}
1422
1423
.image {
1424
position:absolute;
1425
top:auto;
1426
right:auto;
1427
left:170px;
1428
bottom:auto;
1429
}
1430
1431
.meta {
1432
min-width:150px;
1433
max-width:150px;
1434
margin:5px;
1435
}
1436
1437
.links {
1438
border: solid thin;
1439
margin-bottom: 5px;
1440
}
1441
1442
.links span {
1443
display:block;
1444
padding:3px;
1445
}
1446
1447
.iptc {
1448
background-color : #fffff0;
1449
border-top: solid thin;
1450
border-left: solid thin;
1451
border-right: solid thin;
1452
margin-bottom : 5px;
1453
}
1454
1455
.iptc span {
1456
display:block;
1457
padding:3px;
1458
border-bottom:solid thin;
1459
}
1460
1461
.iptc-field {
1462
background-color : #f5f5dc;
1463
color:#a52a2a;
1464
border-bottom:solid thin #000;
1465
}
1466
1467
.exif {
1468
background-color : #f5f5dc;
1469
border-top: solid thin;
1470
border-left: solid thin;
1471
border-right: solid thin;
1472
margin-bottom : 5px;
1473
}
1474
1475
.exif span {
1476
display:block;
1477
padding:3px;
1478
border-bottom:solid thin;
1479
}
1480
1481
.exif-field {
1482
color:#a52a2a;
1483
background-color:#cccc99;
1484
border-bottom:solid thin #000;
1485
}
1486
1487
1488
=head1 VERSION
1489
1490
0.22
1491
1492
=head1 AUTHOR
1493
1494
Aaron Straup Cope
1495
1496
=head1 DATE
1497
1498
September 02, 2002
1499
1500
=head1 TO DO
1501
1502
=over 4
1503
1504
=item *
1505
1506
Teach I how to deal with 'default' images, as described above.
1507
1508
=item *
1509
1510
Add an "import_styles" method, to take advantage of @import hack for hiding CSS from old browsers. Might just add {import=>1} option to "set_styles".
1511
1512
=item *
1513
1514
Figure out why I keep getting errors when I try passing STYLESHEET::DATA (or copies of it) to the XSLT munger.
1515
1516
=item *
1517
1518
Set/get config options using closures.
1519
1520
=item *
1521
1522
Add hooks to read a conf file - this allow involves hacking I so that it can also read the same conf file
1523
1524
=item *
1525
1526
Add hooks for generating slides from a "virtual" directory; specifically a list of disparate files.
1527
1528
=item *
1529
1530
Add hooks for supporting I
1531
1532
=item *
1533
1534
Consider I option that would prompt user for IPTC data as files are being processed.
1535
1536
=item *
1537
1538
Design and implement nightmarish XPath to generate XSLT stylesheet from a user-defined template. I promised Karl I would do this for v 0.3 but we'll see...
1539
1540
=back
1541
1542
=head1 BACKGROUND
1543
1544
http://aaronland.net/weblog/archive/3940
1545
1546
http://aaronland.net/weblog/archive/4474
1547
1548
http://www.la-grange.net/2002/07/22.html
1549
1550
=head1 EXAMPLE
1551
1552
http://perl.aaronland.info/image/shoehorn/gallery/www/example/index.html
1553
1554
=head1 REQUIREMENTS
1555
1556
I
1557
1558
I
1559
1560
I
1561
1562
I
1563
1564
I
1565
1566
I
1567
1568
I
1569
1570
I
1571
1572
=head1 BUGS
1573
1574
Undoubtedly. So far, it works for me.
1575
1576
=head1 LICENSE
1577
1578
Copyright (c) 2002, Aaron Straup Cope. All Rights Reserved.
1579
1580
This is free software, you may use it and distribute it under the same terms as Perl itself.
1581
1582
=cut
1583
1584
package MyXSLT;
1585
use base qw (XML::Filter::XSLT::LibXSLT);
1586
1587
sub set_stylesheet_parameters {
1588
my $self = shift;
1589
my %params = @_;
1590
1591
if (keys %params) {
1592
map { push @{$self->{'__params'}},&XML::LibXSLT::xpath_to_string($_=>$params{$_}) } keys %params;
1593
}
1594
}
1595
1596
sub set_stylesheet_string {
1597
my $self = shift;
1598
$self->{Source}{String} = $_[0];
1599
}
1600
1601
# No point until I figure out how
1602
# to pass the filehandles :-(
1603
1604
#sub set_stylesheet_fh {
1605
# my $self = shift;
1606
# $self->{Source}{ByteStream} = $_[0];
1607
#}
1608
1609
sub end_document {
1610
my $self = shift;
1611
1612
my $dom = $self->XML::LibXML::SAX::Builder::end_document(@_);
1613
1614
# This is so fucking stupid, but there are bugs
1615
# somewhere in all the magic that handles XHTML
1616
# and XSLT so...
1617
1618
my $parser = XML::LibXML->new;
1619
$dom = $parser->parse_html_string($dom->toString());
1620
1621
my $xslt = XML::LibXSLT->new;
1622
my $stylesheet = $xslt->parse_stylesheet($self->{StylesheetDOM});
1623
1624
my $results = $stylesheet->transform($dom,((ref($self->{'__params'}) eq "ARRAY") ? @{$self->{'__params'}} : ()));
1625
1626
my $parser = XML::LibXML::SAX::Parser->new(%$self);
1627
$parser->generate($results);
1628
}
1629
1630
package LocalSAX_Image;
1631
use base qw (XML::SAX::Base);
1632
1633
use File::Basename;
1634
use Image::Size qw (imgsize);
1635
use Image::Info;
1636
1637
my $possible_views;
1638
1639
use constant DTD_HTML_ROOT => "html";
1640
use constant DTD_HTML_PUBLICID => "-//W3C//DTD XHTML 1.0 Strict//EN";
1641
use constant DTD_HTML_SYSTEMID => "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd";
1642
1643
sub xml_decl {
1644
my $self = shift;
1645
$self->SUPER::xml_decl({
1646
Version => "1.0",
1647
Encoding => (Image::Shoehorn::Gallery->encoding() || "UTF-8")
1648
});
1649
1650
# If you're wondering what is going on here,
1651
# see the note in the STYLESHEET package.
1652
1653
$self->SUPER::start_dtd({Name=>DTD_HTML_ROOT,
1654
PublicId=>DTD_HTML_PUBLICID,
1655
SystemId=>DTD_HTML_SYSTEMID});
1656
$self->SUPER::end_dtd();
1657
}
1658
1659
sub start_document {
1660
my $self = shift;
1661
1662
$self->{'__styles'} = scalar(@{Image::Shoehorn::Gallery->styles("image")});
1663
$possible_views = join("|",@{Image::Shoehorn::Gallery->views()});
1664
1665
$self->SUPER::start_document(@_);
1666
}
1667
1668
sub start_element {
1669
my $self = shift;
1670
my $data = shift;
1671
1672
$self->{'__last'} = $data->{Name};
1673
1674
#
1675
1676
if (($data->{Name} eq "html") && (Image::Shoehorn::Gallery->lang())) {
1677
1678
$self->SUPER::start_prefix_mapping({Prefix=>"",NamespaceURI=>"http://www.w3.org/1999/xhtml"});
1679
1680
$self->SUPER::start_element({Name=>"html",Attributes=>{
1681
"{}lang" => {Name => "lang",
1682
Value => Image::Shoehorn::Gallery->lang(),
1683
Prefix => "",
1684
LocalName => "lang",
1685
NamespaceURI => "",
1686
},
1687
"{}xml:lang" => {
1688
Name => "xml:lang",
1689
Value => Image::Shoehorn::Gallery->lang(),
1690
Prefix => "xml",
1691
LocalName => "xml:lang",
1692
NamespaceURI => "http://www.w3.org/1999/xhtml",
1693
},
1694
}});
1695
return 1;
1696
}
1697
1698
if (($data->{Name} eq "style") && ($self->{'__styles'})){
1699
1700
foreach my $style (@{Image::Shoehorn::Gallery->styles("image")}) {
1701
$self->SUPER::start_element({Name=>"link",Attributes=>{
1702
"{}href" => {Name=>"href",
1703
Value=>$style->{'href'},
1704
Prefix=>"",
1705
LocalName=>"href",
1706
NameSpaceURI=>""},
1707
"{}type" => {Name=>"type",
1708
Value=>"text/css",
1709
LocalName=>"type",
1710
NameSpaceURI=>""},
1711
"{}rel" => {Name=>"rel",
1712
Value=>($style->{'rel'} || "stylesheet"),
1713
Prefix=>"",
1714
LocalName=>"rel",
1715
NameSpaceURI=>""},
1716
"{}media" => {Name=>"media",
1717
Value=>($style->{'media'} || "all"),
1718
Prefix=>"",
1719
LocalName=>"media",
1720
NameSpaceURI=>""},
1721
"{}title" => {Name=>"title",
1722
Value=>($style->{'title'} || ""),
1723
Prefix=>"",
1724
LocalName=>"title",
1725
NameSpaceURI=>""},
1726
}});
1727
$self->SUPER::end_element({Name=>"link"});
1728
}
1729
1730
return 1;
1731
}
1732
1733
#
1734
1735
if (($data->{Name} eq "img") &&
1736
($data->{Attributes}->{'{}id'}->{'Value'} eq "main")) {
1737
1738
my $src = Image::Shoehorn::Gallery->unformat_link($data->{Attributes}->{'{}src'}->{'Value'});
1739
$src = Image::Shoehorn::Gallery->source_to_dest($src);
1740
1741
my ($x,$y);
1742
1743
#
1744
1745
if ($src =~ /^(.*)\?scale=(.*)$/) {
1746
1747
# This matters because we also need
1748
# to look up IPTC and EXIF data with
1749
# $src.
1750
1751
$src = $1;
1752
1753
# Call to imgsize needs to be memoized
1754
($x,$y) = Image::Shoehorn->dimensions_for_scale((imgsize($src))[0,1],Image::Shoehorn::Gallery->scales()->{$2});
1755
}
1756
1757
else {
1758
($x,$y) = imgsize($src);
1759
}
1760
1761
#
1762
1763
my $alt = &basename($data->{Attributes}->{'{}src'}->{'Value'});
1764
if (my $iptc = IPTC->get($src)) { $alt = $iptc->Attribute("caption/abstract") || $iptc->Attribute("headline") || $alt; }
1765
1766
$data->{'Attributes'}->{'{}height'} = {
1767
Name => "height",
1768
LocalName => "height",
1769
Prefix => "",
1770
NamespaceURI => "",
1771
Value => $y,
1772
};
1773
$data->{'Attributes'}->{'{}width'} = {
1774
Name => "width",
1775
LocalName => "width",
1776
Prefix => "",
1777
NamespaceURI => "",
1778
Value => $x,
1779
};
1780
$data->{'Attributes'}->{'{}alt'} = {
1781
Name => "alt",
1782
LocalName => "alt",
1783
Prefix => "",
1784
NamespaceURI => "",
1785
Value => $alt,
1786
};
1787
1788
$self->SUPER::start_element($data);
1789
1790
$self->{'__src'} = $src;
1791
return 1;
1792
}
1793
1794
if (($data->{Name} eq "div") &&
1795
($data->{Attributes}->{'{}class'}->{'Value'} eq "links")) {
1796
$self->{'__meta'} = 1;
1797
}
1798
1799
$self->SUPER::start_element($data);
1800
return 1;
1801
}
1802
1803
sub end_element {
1804
my $self = shift;
1805
my $data = shift;
1806
1807
if (($data->{Name} eq "style") && ($self->{'__styles'})){
1808
return;
1809
}
1810
1811
$self->SUPER::end_element($data);
1812
1813
if ($self->{Name} eq "html") {
1814
$self->SUPER::end_prefix_mapping({Prefix=>""});
1815
}
1816
1817
if (($data->{Name} eq "div") && (exists($self->{'__meta'}))) {
1818
$self->add_metadata();
1819
delete $self->{'__meta'};
1820
}
1821
1822
return 1;
1823
}
1824
1825
sub characters {
1826
my $self = shift;
1827
my $data = shift;
1828
1829
if (($self->{'__last'} eq "style") && ($self->{'__styles'})){
1830
return;
1831
}
1832
1833
$self->SUPER::characters($data);
1834
}
1835
1836
sub add_metadata {
1837
my $self = shift;
1838
1839
my $iptc_props = Image::Shoehorn::Gallery->iptc();
1840
my $exif_props = Image::Shoehorn::Gallery->exif();
1841
1842
$self->{'__src'} =~ s/^(.*)-($possible_views)\.([^\.]+)$/$1\.$3/;
1843
1844
if (scalar(@$iptc_props) > 0) {
1845
my $iptc = IPTC->get($self->{'__src'});
1846
1847
if (($iptc) && (IPTC->test($self->{'__src'}))) {
1848
$self->SUPER::start_element({Name=>"div",Attributes => {
1849
"{}class" => {
1850
"Name" => "class",
1851
"LocalName" => "class",
1852
"Prefix" => "",
1853
"NamespaceURI" => "",
1854
"Value" => "iptc",
1855
},
1856
}});
1857
1858
foreach my $prop (@{$iptc_props}) {
1859
$self->SUPER::start_element({Name=>"span",Attributes =>{
1860
"{}class" => {
1861
"Name" => "class",
1862
"LocalName" => "class",
1863
"Prefix" => "",
1864
"NamespaceURI" => "",
1865
"Value" => "iptc-field",
1866
},
1867
}});
1868
$self->SUPER::characters({Data=>$prop});
1869
$self->SUPER::end_element({Name=>"span"});
1870
1871
$self->SUPER::start_element({Name=>"span",Attributes =>{
1872
"{}class" => {
1873
"Name" => "class",
1874
"LocalName" => "class",
1875
"Prefix" => "",
1876
"NamespaceURI" => "",
1877
"Value" => $prop,
1878
},
1879
}});
1880
$self->SUPER::characters({Data=>($iptc->Attribute($prop) || "-")});
1881
$self->SUPER::end_element({Name=>"span"});
1882
}
1883
1884
$self->SUPER::end_element({Name=>"div"});
1885
}
1886
}
1887
1888
#
1889
1890
if (scalar(@$exif_props) > 0) {
1891
my $exif = EXIF->get($self->{'__src'});
1892
if (($exif) && (EXIF->test($self->{'__src'}))) {
1893
$self->SUPER::start_element({Name=>"div",Attributes => {
1894
"{}class" => {
1895
"Name" => "class",
1896
"LocalName" => "class",
1897
"Prefix" => "",
1898
"NamespaceURI" => "",
1899
"Value" => "exif",
1900
},
1901
}});
1902
1903
foreach my $prop (@{$exif_props}) {
1904
$self->SUPER::start_element({Name=>"span",Attributes =>{
1905
"{}class" => {
1906
"Name" => "class",
1907
"LocalName" => "class",
1908
"Prefix" => "",
1909
"NamespaceURI" => "",
1910
"Value" => "exif-field",
1911
},
1912
}});
1913
$self->SUPER::characters({Data=>$prop});
1914
$self->SUPER::end_element({Name=>"span"});
1915
1916
$self->SUPER::start_element({Name=>"span",Attributes =>{
1917
"{}class" => {
1918
"Name" => "class",
1919
"LocalName" => "class",
1920
"Prefix" => "",
1921
"NamespaceURI" => "",
1922
"Value" => $prop,
1923
},
1924
}});
1925
1926
my $exif_value = $exif->{$prop} || "-";
1927
if (ref($exif_value) eq "ARRAY") {
1928
$exif_value = join(",",@$exif_value);
1929
}
1930
1931
$self->SUPER::characters({Data=>$exif_value});
1932
$self->SUPER::end_element({Name=>"span"});
1933
}
1934
1935
$self->SUPER::end_element({Name=>"div"});
1936
}
1937
}
1938
1939
delete $self->{'__src'};
1940
return 1;
1941
}
1942
1943
1944
package LocalSAX_FloatingThumbs;
1945
use base qw (XML::SAX::Base);
1946
1947
sub start_element {
1948
my $self = shift;
1949
my $data = shift;
1950
1951
$self->SUPER::start_element($data);
1952
1953
if ($data->{Name} eq "body") {
1954
$self->_spacer();
1955
}
1956
}
1957
1958
sub end_element {
1959
my $self = shift;
1960
my $data = shift;
1961
1962
if ($data->{Name} eq "body") {
1963
$self->_spacer();
1964
}
1965
1966
$self->SUPER::end_element($data);
1967
}
1968
1969
sub _spacer {
1970
my $self = shift;
1971
$self->SUPER::start_element({Name=>"div",Attributes=>{
1972
"{}class" => {
1973
Name => "class",
1974
LocalName => "class",
1975
Prefix => "",
1976
NamespaceURI => "",
1977
Value => "spacer",
1978
}
1979
}});
1980
$self->SUPER::characters({Data=>" "});
1981
$self->SUPER::end_element({Name=>"div"});
1982
return 1;
1983
}
1984
1985
package LocalSAX_Breadcrumbs;
1986
use base qw (XML::SAX::Base);
1987
1988
use File::Basename;
1989
1990
sub start_element {
1991
my $self = shift;
1992
my $data = shift;
1993
1994
$self->SUPER::start_element($data);
1995
1996
if ($data->{Name} ne "body") {
1997
return 1;
1998
}
1999
2000
my $cur = Image::Shoehorn::Gallery->cur_destination();
2001
2002
if ($cur eq Image::Shoehorn::Gallery->destination()) {
2003
return 1;
2004
}
2005
2006
$cur = &dirname($cur);
2007
2008
my $dest = Image::Shoehorn::Gallery->destination();
2009
2010
$cur =~ s/^($dest)(.*)/$2/;
2011
2012
my ($parts,$count) = Breadcrumbs->get($cur);
2013
2014
$self->SUPER::start_element({Name=>"span",Attributes=>{
2015
"{}class" => {
2016
Name => "class",
2017
LocalName => "class",
2018
Prefix => "",
2019
NamespaceURI => "",
2020
Value => "breadcrumbs",
2021
}
2022
}});
2023
2024
$self->SUPER::characters({Data=>" "});
2025
2026
#
2027
2028
for (my $i = 0; $i < $count; $i++) {
2029
$self->SUPER::start_element({Name=>"a",Attributes=>{
2030
"{}href" => {
2031
Name=>"href",
2032
LocalName=>"href",
2033
Prefix=>"",
2034
NamespaceURI=>"",
2035
Value=>Image::Shoehorn::Gallery->url().join("/",@{$parts}[0..$i]),
2036
},
2037
}});
2038
$self->SUPER::characters({Data=>($parts->[$i] || "top")});
2039
$self->SUPER::end_element({Name=>"a"});
2040
2041
unless ($i +1 == $count) {
2042
$self->SUPER::start_element({Name=>"span",Attributes=>{
2043
"{}class" => {
2044
Name => "class",
2045
LocalName => "class",
2046
Prefix => "",
2047
NamespaceURI => "",
2048
Value => "breadcrumbs-spacer",
2049
},
2050
}});
2051
2052
$self->SUPER::characters({Data=>" || "});
2053
$self->SUPER::end_element({Name=>"span"});
2054
}
2055
2056
# print STDERR "$i [$count] $parts->[$i] ... ".Image::Shoehorn::Gallery->url().join("/",@{$parts}[0..$i])."\n";
2057
}
2058
2059
$self->SUPER::end_element({Name=>"span"});
2060
return 1;
2061
}
2062
2063
package LocalSAX_Scaled;
2064
use base qw (XML::SAX::Base);
2065
2066
use Image::Shoehorn;
2067
use Image::Size qw (imgsize);
2068
2069
my $files = [];
2070
2071
sub files { return $files; }
2072
2073
sub new {
2074
my $pkg = shift;
2075
my $self = {};
2076
2077
bless $self,$pkg;
2078
2079
$files = [];
2080
return $self->SUPER::new(@_);
2081
}
2082
2083
sub parse_uri {
2084
my $self = shift;
2085
my $uri = shift;
2086
2087
if (! -f $uri) {
2088
return;
2089
}
2090
2091
push @$files,$uri;
2092
2093
print STDERR "[parse-uri] Adding $uri\n"
2094
if (Image::Shoehorn::Gallery->verbose());
2095
2096
#
2097
2098
my $scales = Image::Shoehorn::Gallery->scales();
2099
my $default = $scales->{default};
2100
2101
my $scale = Image::Shoehorn::Gallery->do_scale($uri,$default);
2102
2103
#
2104
2105
my %to_scale = ();
2106
2107
foreach my $sname (keys %{$scales}) {
2108
2109
# unless ($sname =~ /^(thumb)$/) {
2110
unless ($sname eq "thumb") {
2111
if (! $scale) {
2112
next;
2113
}
2114
}
2115
2116
if (! $scales->{$sname}) {
2117
next;
2118
}
2119
2120
my $sfile = join("/",Image::Shoehorn::Gallery->cur_destination(),Image::Shoehorn->scaled_name([$uri,$sname]));
2121
2122
2123
if ($sfile =~ /^(.*)(-default)(\.[^\.]+)$/) {
2124
$sfile = $1.$3;
2125
}
2126
2127
# print STDERR "COMPARING '$uri' w/ '$sfile' \n";
2128
# print STDERR (stat($uri))[9]." ... ".(stat($sfile))[9]."\n";
2129
2130
if (Image::Shoehorn::Gallery->force() >= 2) {
2131
$to_scale{$sname} = $scales->{$sname};
2132
}
2133
2134
elsif ((stat($uri))[9] > (stat($sfile))[9]) {
2135
$to_scale{$sname} = $scales->{$sname};
2136
}
2137
2138
else {}
2139
2140
}
2141
2142
#
2143
2144
if (((! $scale) && (! $default)) ||
2145
(Image::Shoehorn::Gallery->destination() ne Image::Shoehorn::Gallery->source())) {
2146
2147
my $copy = Image::Shoehorn::Gallery->source_to_dest($uri);
2148
2149
unless ($copy eq $uri) {
2150
require File::Copy;
2151
&File::Copy::copy ($uri,$copy);
2152
}
2153
}
2154
2155
#
2156
2157
if (keys %to_scale) {
2158
if ($default) {
2159
2160
# print STDERR "ORIGINAL ".join(",",(imgsize($uri))[0,1])."\n";
2161
my ($dx,$dy) = Image::Shoehorn->dimensions_for_scale((imgsize($uri))[0,1],$default);
2162
2163
# print STDERR "$uri $dx, $dy\n";
2164
foreach (keys %to_scale) {
2165
next if ($_ =~ /^(thumb|default)$/);
2166
2167
my ($nx,$ny) = Image::Shoehorn->dimensions_for_scale($dx,$dy,$to_scale{$_});
2168
# print STDERR "N $nx, $ny\n";
2169
$to_scale{$_} = join("x",$nx,$ny);
2170
}
2171
2172
# use Data::Dumper;
2173
# die &Dumper(\%to_scale);
2174
}
2175
2176
#
2177
2178
# We do this because otherwise the image
2179
# scaling widgets start gobbling up all the
2180
# available swap space and eventually the OS
2181
# kills the program :-(
2182
2183
my $cmd = "/usr/local/bin/perl -e \'use Image::Shoehorn;";
2184
2185
$cmd .= "my \$image = Image::Shoehorn->new({";
2186
$cmd .= "tmpdir => \"".Image::Shoehorn::Gallery->cur_destination()."\",cleanup => sub {";
2187
2188
# subroutine to rename 'default' :
2189
$cmd .= "my \$imgs = shift; return unless \$imgs->{default};";
2190
$cmd .= "(my \$new = \$imgs->{default}->{path}) =~ s/(.*)-default\\.([^\\.]+)\$/\$1\\.\$2/;";
2191
$cmd .= "rename \$imgs->{default}->{path},\$new";
2192
$cmd .= " || warn $!;";
2193
# end subroutine
2194
2195
$cmd .= "},}) ";
2196
$cmd .= "|| die Image::Shoehorn->last_error();";
2197
$cmd .= "print STDERR \"Scaling $uri...\"; ";
2198
$cmd .= "\$image->import({";
2199
$cmd .= "source => \"$uri\",";
2200
$cmd .= "scale => {";
2201
map { $cmd .= "\"$_\" => \"$to_scale{$_}\","; } keys %to_scale;
2202
$cmd .= "}}) || die Image::Shoehorn->last_error();";
2203
$cmd .= "print STDERR \"OK\\n\";";
2204
$cmd .= "'";
2205
2206
print STDERR $cmd,"\n"
2207
if (Image::Shoehorn::Gallery->verbose() > 1);
2208
2209
system($cmd);
2210
}
2211
2212
#
2213
2214
return unless ($scale);
2215
2216
#
2217
2218
$self->SUPER::start_element({Name=>"ul"});
2219
2220
foreach my $scale (@{Image::Shoehorn::Gallery->views}) {
2221
2222
my $path = Image::Shoehorn::Gallery->page_for_image([Image::Shoehorn::Gallery->format_link($uri),$scale]);
2223
2224
$self->SUPER::start_element({Name=>"li"});
2225
$self->SUPER::start_element({Name=>"a",Attributes=>{
2226
'{}href' => {
2227
Name => "href",
2228
LocalName => "href",
2229
Prefix => "",
2230
NamespaceURI => "",
2231
Value => $path,
2232
},
2233
}});
2234
$self->SUPER::characters({Data=>$scale});
2235
$self->SUPER::end_element({Name=>"a"});
2236
$self->SUPER::end_element({Name=>"li"});
2237
}
2238
2239
$self->SUPER::end_element({Name=>"ul"});
2240
return;
2241
}
2242
2243
package IPTC;
2244
use Image::IPTCInfo;
2245
2246
my %iptc = ();
2247
my %views = ();
2248
2249
sub get {
2250
my $pkg = shift;
2251
my $path = shift;
2252
2253
if (exists $iptc{$path}) {
2254
return $iptc{$path};
2255
}
2256
2257
$iptc{$path} = Image::IPTCInfo->new($path);
2258
2259
if (! ref($iptc{$path})) {
2260
$iptc{$path} = undef;
2261
}
2262
2263
return $iptc{$path};
2264
}
2265
2266
sub test {
2267
my $pkg = shift;
2268
my $path = shift;
2269
2270
if (exists($views{$path})) {
2271
return $views{$path};
2272
}
2273
2274
if (! $iptc{$path}) {
2275
return 0;
2276
}
2277
2278
foreach my $view (@{Image::Shoehorn::Gallery->iptc()}) {
2279
if ($iptc{$path}->Attribute($view)) {
2280
$views{$path} = 1;
2281
return 1;
2282
}
2283
}
2284
2285
$views{$path} = 0;
2286
return 0;
2287
}
2288
2289
package EXIF;
2290
use Image::Info qw (image_info);
2291
2292
my %exif = ();
2293
my %views = ();
2294
2295
sub get {
2296
my $pkg = shift;
2297
my $path = shift;
2298
2299
if (exists $exif{$path}) {
2300
return $exif{$path};
2301
}
2302
2303
$exif{$path} = image_info($path);
2304
2305
if ($exif{'error'}) {
2306
$exif{$path} = undef;
2307
}
2308
2309
return $exif{$path};
2310
}
2311
2312
sub test {
2313
my $pkg = shift;
2314
my $path = shift;
2315
2316
if (exists($views{$path})) {
2317
return $views{$path};
2318
}
2319
2320
foreach my $view (@{Image::Shoehorn::Gallery->exif()}) {
2321
if ($exif{$path}->{$view}) {
2322
$views{$path} = 1;
2323
return 1;
2324
}
2325
}
2326
2327
$views{$path} = 0;
2328
return 0;
2329
}
2330
2331
package Breadcrumbs;
2332
2333
my %crumbs = ();
2334
my %count = ();
2335
2336
sub get {
2337
my $pkg = shift;
2338
2339
if (! $_[0]) {
2340
return ([],1);
2341
}
2342
2343
if (exists $crumbs{$_[0]}) {
2344
return ($crumbs{$_[0]},$count{$_[0]});
2345
}
2346
2347
@{$crumbs{$_[0]}} = split("/",$_[0]);
2348
$count{$_[0]} = scalar(@{$crumbs{$_[0]}});
2349
2350
return ($crumbs{$_[0]},$count{$_[0]});
2351
}
2352
2353
package STYLESHEET;
2354
my $data = undef;
2355
2356
sub data {
2357
if ($data) { return $data; }
2358
while () { $data .= $_; }
2359
return $data;
2360
}
2361
2362
return 1;
2363
2364
# NOTE : we are not setting the public and system doctypes here
2365
# because they cause even more weirdness with XML::LibXML and it's
2366
# seeming inability to deal with XHTML files. I really don't get
2367
# what's going on so we play a little game and set them event the
2368
# xml_decl event in the LocalSAX_Image filter is called next. Gah!
2369
2370
# NOTE ALSO : that this is also where we happen to set the encoding
2371
2372
__DATA__