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

Revision 19499, 4.8 KB (checked in by davidb, 10 years ago)

Additional work on supporting Greenstone CGI-based API

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'   => [ "orientation" ] },
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    if ($baseaction::authentication_enabled) {
96    # Ensure the user is allowed to edit this collection
97    &authenticate_user($gsdl_cgi, $username, $collect);
98    }
99
100    my $collect_directory = &util::filename_cat($gsdlhome, "collect");
101#    $gsdl_cgi->checked_chdir($collect_directory);
102
103
104#    # Make sure the collection isn't locked by someone else
105#
106
107    $self->lock_collection($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 $orientation = $self->{'orientation'};
117    $orientation = "portrait" if (!defined $orientation);
118
119    my $toplevel_assoc_dir
120    = &util::filename_cat($collect_directory,$collect,"index","assoc");
121    my $src_full_assoc_filename
122    = &util::filename_cat($toplevel_assoc_dir,$assocDir,$assocFile);
123
124    my $dst_width = $pageWidth;
125    my $dst_height = $pageHeight;
126
127    my $opt_ls = ($orientation eq "landscape") ? "-r" : "";
128   
129    my $dst_file = $dst_width."x".$dst_height."$opt_ls-$assocFile";
130
131    my $dst_full_assoc_filename
132    = &util::filename_cat($toplevel_assoc_dir,$assocDir,$dst_file);
133
134    # **** What if assoc folder is on read-only medium such as CD-ROM?
135    # Should really switch to using some collection specific tmp area
136    # => test if top_level assoc dir has write permission?
137
138    if (!-w $toplevel_assoc_dir) {
139    $gsdl_cgi->generate_error("Cannot write out resized image $dst_full_assoc_filename.");
140    }
141
142    # For now will assume it is writable
143
144    if (!-e $dst_full_assoc_filename) {
145    # generate resized image
146
147    # Better to make sure ImageMagick is installed
148   
149        my $resize = "-filter Lanczos -resize $dst_width"."x"."$dst_height!";
150    # use of "!" forces convert to produce exactly these dimensions, rather
151    # than preserving aspect ratio.  In actual fact, it is intended that
152    # the width and height values passed in *do* preserve the aspect ratio
153    # Doing it this way makes it easier for the web browser to know (ahead of time) the
154    # width and height of the image that will be generated (useful for putting into
155    # <img> and <div> tags
156
157
158    my $cmd = "convert \"$src_full_assoc_filename\" ";
159    $cmd .= "-rotate 90 " if ($orientation eq "landscape");
160
161    $cmd .= "$resize \"$dst_full_assoc_filename\"";
162
163    `$cmd`;
164
165    # generate resized image in assoc file area (if writable)
166    # otherwise in (collection's??) tmp directory
167    }
168
169    my $mime_type = $self->get_mime_type($dst_file);
170   
171    if (defined $mime_type) {
172    # now output it with suitable mime header
173    print STDOUT "Content-type:$mime_type\n\n";
174    system("cat \"$dst_full_assoc_filename\"");
175    }
176    else {
177    $gsdl_cgi->generate_error("Unrecognised image mime-type for $dst_file");
178    }
179
180}
181
182
1831;
Note: See TracBrowser for help on using the browser.