root/gsdl/trunk/perllib/cgiactions/imageaction.pm @ 19293

Revision 19293, 4.6 KB (checked in by davidb, 10 years ago)

Introduction of Perl-based CGI 'actions' plus supporting modules

Line 
1###########################################################################
2#
3# imageaction.pm --
4# A component of the Greenstone digital library software
5# from the New Zealand Digital Library Project at the
6# University of Waikato, New Zealand.
7#
8# Copyright (C) 2009 New Zealand Digital Library Project
9#
10# This program is free software; you can redistr   te it and/or modify
11# it under the terms of the GNU General Public License as published by
12# the Free Software Foundation; either version 2 of the License, or
13# (at your option) any later version.
14#
15# This program is distributed in the hope that it will be useful,
16# but WITHOUT ANY WARRANTY; without even the implied warranty of
17# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
18# GNU General Public License for more details.
19#
20# You should have received a copy of the GNU General Public License
21# along with this program; if not, write to the Free Software
22# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
23#
24###########################################################################
25
26package imageaction;
27
28use strict;
29
30use cgiactions::baseaction;
31
32@imageaction::ISA = ('baseaction');
33
34
35my $action_table =
36{
37    "fit-screen" => { 'compulsory-args' => [ "pageWidth", "pageHeight",
38                         "assocDir", "assocFile" ],
39              'optional-args'   => [] },
40
41};
42
43
44sub new
45{
46    my $class = shift (@_);
47    my ($gsdl_cgi,$iis6_mode) = @_;
48
49    my $self = new baseaction($action_table,$gsdl_cgi,$iis6_mode);
50
51    return bless $self, $class;
52}
53
54
55
56sub get_mime_type
57{
58    my $self = shift @_;
59
60    my ($file) = @_;
61
62    my %image_mime_re =
63    (
64    "gif"   => "image/gif",
65    "jpe?g" => "image/jpeg",
66    "png"   => "image/png",
67    "tiff?" => "image/tiff",
68    "bmp"   => "image/bmp"
69    );
70
71    my ($ext) = ($file =~ m/^.*\.(.*)?$/);
72
73    foreach my $re (keys %image_mime_re) {
74    if ($ext =~ m/^$re$/i) {
75        return $image_mime_re{$re};
76    }
77    }
78
79    return undef;
80}
81
82
83
84
85sub fit_screen
86{
87    my $self = shift @_;
88
89    my $username  = $self->{'username'};
90    my $collect   = $self->{'collect'};
91    my $gsdl_cgi  = $self->{'gsdl_cgi'};
92    my $gsdlhome  = $self->{'gsdlhome'};
93
94
95    # don't user authenticate for now
96    if ($baseaction::authentication_enabled) {
97    # Ensure the user is allowed to edit this collection
98    &authenticate_user($gsdl_cgi, $username, $collect);
99    }
100
101    my $collect_directory = &util::filename_cat($gsdlhome, "collect");
102#    $gsdl_cgi->checked_chdir($collect_directory);
103
104
105#    # Make sure the collection isn't locked by someone else
106#
107    &serverutil::lock_collection($gsdl_cgi, $username, $collect);
108
109    # look up additional args
110
111    my $pageWidth  = $self->{'pageWidth'};
112    my $pageHeight = $self->{'pageHeight'};
113    my $assocDir   = $self->{'assocDir'};
114    my $assocFile  = $self->{'assocFile'};
115
116    my $toplevel_assoc_dir
117    = &util::filename_cat($collect_directory,$collect,"index","assoc");
118    my $src_full_assoc_filename
119    = &util::filename_cat($toplevel_assoc_dir,$assocDir,$assocFile);
120
121    my $dst_width = $pageWidth;
122    my $dst_height = $pageHeight;
123
124    my $dst_file = $dst_width."x".$dst_height."-".$assocFile;
125
126    my $dst_full_assoc_filename
127    = &util::filename_cat($toplevel_assoc_dir,$assocDir,$dst_file);
128
129    # **** What if assoc folder is on read-only medium such as CD-ROM?
130    # Should really switch to using some collection specific tmp area
131    # => test if top_level assoc dir has write permission?
132
133    if (!-w $toplevel_assoc_dir) {
134    $gsdl_cgi->generate_error("Cannot write out resized image $dst_full_assoc_filename.");
135    }
136
137    # For now will assume it is writable
138
139    if (!-e $dst_full_assoc_filename) {
140    # generate resized image
141
142    # Better to make sure ImageMagick is installed
143   
144        my $resize = "-filter Lanczos -resize $dst_width"."x"."$dst_height!";
145    # use of "!" forces convert to produce exactly these dimensions, rather
146    # than preserving aspect ratio.  In actual fact, it is intended that
147    # the width and height values passed in *do* preserve the aspect ratio
148    # Doing it this way makes it easier for the web browser to know (ahead of time) the
149    # width and height of the image that will be generated (useful for putting into
150    # <img> and <div> tags
151
152
153    my $cmd = "convert \"$src_full_assoc_filename\" $resize \"$dst_full_assoc_filename\"";
154    `$cmd`;
155
156    # generate resized image in assoc file area (if writable)
157    # otherwise in (collection's??) tmp directory
158    }
159
160    my $mime_type = $self->get_mime_type($dst_file);
161   
162    if (defined $mime_type) {
163    # now output it with suitable mime header
164    print STDOUT "Content-type:$mime_type\n\n";
165    system("cat \"$dst_full_assoc_filename\"");
166    }
167    else {
168    $gsdl_cgi->generate_error("Unrecognised image mime-type for $dst_file");
169    }
170
171}
172
173
1741;
Note: See TracBrowser for help on using the browser.