root/main/trunk/greenstone2/perllib/cgiactions/imageaction.pm @ 24597

Revision 24597, 5.2 KB (checked in by davidb, 9 years ago)

Modifications to help image-server.pl run under Greenstone3 on Windows

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