1954 lines
64 KiB
Perl
1954 lines
64 KiB
Perl
# ================================================================== # Plugins::SlideShow - Auto Generated Program Module
|
||
#
|
||
# Plugins::SlideShow
|
||
# Author : Gossamer Threads Inc.
|
||
# Version : $Id: SlideShow.pm,v 1.33 2008/09/11 16:23:05 aaron Exp $
|
||
# Updated : Tue Nov 27 17:18:24 2001
|
||
#
|
||
# ==================================================================
|
||
#
|
||
|
||
package Plugins::SlideShow;
|
||
# ==================================================================
|
||
|
||
use strict;
|
||
use GT::Base;
|
||
use GT::Plugins qw/STOP CONTINUE/;
|
||
use Links qw/$CFG $IN $DB/;
|
||
use Links::Plugins;
|
||
use GT::CGI;
|
||
use GT::AutoLoader;
|
||
use vars qw/@image_types/;
|
||
|
||
# Inhert from base class for debug and error methods
|
||
@Plugins::SlideShow::ISA = qw/GT::Base/;
|
||
|
||
@image_types = qw/thumbnail medium large largest/;
|
||
|
||
|
||
sub check_input {
|
||
# -------------------------------------------------------------------
|
||
# This checks the modify input to ensure that all
|
||
# image files comply with the settings in the plugin
|
||
#
|
||
my $p = $IN->get_hash;
|
||
|
||
my $cfg = Links::Plugins->get_plugin_user_cfg('SlideShow');
|
||
my ( $max_width, $max_height, $image_cols, $temp_dir ) =
|
||
map { $cfg->{$_} || undef } qw| max_width max_height image_cols temp_dir |;
|
||
|
||
my @image_cols = grep $_, map { s,^\s*|\s*$,,g; $_ } split /,/, $image_cols;
|
||
|
||
require GT::SQL::File;
|
||
# is there an image to deal with?
|
||
foreach my $image_col (@image_cols) {
|
||
|
||
my $fh = $p->{$image_col};
|
||
ref $fh or next;
|
||
my $fname = get_filename("$fh");
|
||
$fname =~ s/\s+/_/g;
|
||
my $efname = GT::CGI::escape($fname);
|
||
|
||
# save the Image file (if required)
|
||
my $main_fpath = "$temp_dir/$efname";
|
||
if ( $main_fpath ne "$fh" ) {
|
||
open IMG, ">$main_fpath" or do {
|
||
GT::Plugins->action( STOP );
|
||
return { error => $! };
|
||
};
|
||
binmode IMG;
|
||
print IMG <$fh>;
|
||
close IMG;
|
||
}
|
||
|
||
# make sure it fits within the bounds
|
||
if (my $max_size = $cfg->{max_upload_size}) {
|
||
if ($max_size <= -s $main_fpath) {
|
||
unlink $main_fpath;
|
||
GT::Plugins->action( STOP );
|
||
return { error =>"Image in '$image_col' too large" };
|
||
}
|
||
}
|
||
if (my $max_dim = $cfg->{max_upload_constraints}) {
|
||
if ($max_dim =~ /(\d+)\s*x\s*(\d+)/) {
|
||
my ($max_dim_width, $max_dim_height) = ($1, $2);
|
||
my ($im_width, $im_height) = imgsize($main_fpath);
|
||
if ($max_dim_width < $im_width) {
|
||
unlink $main_fpath;
|
||
GT::Plugins->action( STOP );
|
||
return { error => "Image in '$image_col' is too wide" };
|
||
}
|
||
if ($max_dim_height < $im_height) {
|
||
unlink $main_fpath;
|
||
GT::Plugins->action( STOP );
|
||
return { error => "Image in '$image_col' is too tall" };
|
||
}
|
||
}
|
||
}
|
||
|
||
# now setup the record to save
|
||
$IN->param( $image_col, GT::SQL::File->open( $main_fpath ) );
|
||
}
|
||
|
||
return @_;
|
||
}
|
||
|
||
sub modify_link {
|
||
# -------------------------------------------------------------------
|
||
# This subroutine will get called whenever the hook 'add_link'
|
||
# is run. You should call GT::Plugins->action ( STOP ) if you don't
|
||
# want the regular code to run, otherwise the code will continue as
|
||
# normal.
|
||
#
|
||
my ($p) = @_;
|
||
|
||
my $cfg = Links::Plugins->get_plugin_user_cfg( 'SlideShow' );
|
||
my ( $max_width, $max_height, $image_cols, $temp_dir ) =
|
||
map { $cfg->{$_} || undef } qw| max_width max_height image_cols temp_dir |;
|
||
|
||
my @image_cols = grep $_, map { s,^(\s*),,; s,(\s*)$,,; $_ } split /,/, $image_cols;
|
||
|
||
my $err = '';
|
||
|
||
require GT::SQL::File;
|
||
# is there an image to deal with?
|
||
foreach my $image_col (@image_cols) {
|
||
my $fh = $p->{$image_col};
|
||
|
||
# Is the user trying to delete the image?
|
||
# If so, just delete all the other images
|
||
if ( $p->{$image_col . "_del"} ) {
|
||
for my $types (@image_types) {
|
||
$p->{$image_col."_${types}_del"} = "delete";
|
||
}
|
||
}
|
||
|
||
ref $fh or next;
|
||
my $fname = get_filename("$fh");
|
||
$fname =~ s/\s+/_/g;
|
||
my $efname = GT::CGI::escape($fname);
|
||
|
||
# save the Image file (if required)
|
||
my $main_fpath = "$temp_dir/work-$efname";
|
||
if ($main_fpath ne "$fh") {
|
||
open IMG, ">$main_fpath" or return throw_error( $! );
|
||
binmode IMG;
|
||
print IMG <$fh>;
|
||
close IMG;
|
||
}
|
||
|
||
# make sure it fits within the bounds
|
||
if (my $max_size = $cfg->{max_upload_size}) {
|
||
if ($max_size <= -s $main_fpath) {
|
||
unlink $main_fpath;
|
||
return throw_error( "Image in '$image_col' too large" );
|
||
}
|
||
}
|
||
if (my $max_dim = $cfg->{max_upload_constraints}) {
|
||
if ($max_dim =~ /(\d+)\s*x\s*(\d+)/) {
|
||
my ($max_dim_width, $max_dim_height) = ($1, $2);
|
||
my ($im_width, $im_height) = imgsize($main_fpath);
|
||
|
||
if ($max_dim_width < $im_width) {
|
||
unlink $main_fpath;
|
||
return throw_error("Image in '$image_col' is too wide");
|
||
}
|
||
if ($max_dim_height < $im_height) {
|
||
unlink $main_fpath;
|
||
return throw_error("Image in '$image_col' is too tall");
|
||
}
|
||
}
|
||
}
|
||
|
||
my $type_index = ($cfg->{'link_type_2'} eq $p->{Link_Type}) ? 2 : 1;
|
||
my $quality = $cfg->{"image_quality"};
|
||
foreach my $col (@image_types) {
|
||
my $constraints = $cfg->{"${col}_constraints_${type_index}"} or next;
|
||
my ($crop, $mx, $my) = $constraints =~ /(crop\s*)?(\d+)\s*[,x]\s*(\d+)/;
|
||
my $thumb_fpath = "$temp_dir/${col}_$efname";
|
||
|
||
if ($crop) {
|
||
crop_resize_image($main_fpath, $thumb_fpath, $mx, $my, $quality);
|
||
}
|
||
else {
|
||
resize_image($main_fpath, $thumb_fpath, $mx, $my, $quality);
|
||
}
|
||
|
||
$p->{"${image_col}_${col}"} = GT::SQL::File->open($thumb_fpath);
|
||
|
||
# If the image is large enough to support it, add the watermark
|
||
if (my $water_fpath = $cfg->{watermark_path} and $mx > 100 and $my > 100) {
|
||
apply_watermark($thumb_fpath, $water_fpath);
|
||
}
|
||
}
|
||
|
||
# apply watermarks to main image
|
||
if (my $water_fpath = $cfg->{watermark_path}) {
|
||
apply_watermark($main_fpath, $water_fpath);
|
||
}
|
||
|
||
# now setup the record to save
|
||
$p->{$image_col} = GT::SQL::File->open($main_fpath);
|
||
}
|
||
|
||
# delete the image cache so that it will be rebuilt next run through
|
||
$p->{SlideShowCache} = '';
|
||
|
||
return @_;
|
||
}
|
||
|
||
sub add_link {
|
||
modify_link(@_)
|
||
}
|
||
|
||
sub get_filename($) {
|
||
# -------------------------------------------------------------------
|
||
my $fpath = shift;
|
||
my @path = split m#(?:/|\\)#, $fpath;
|
||
return pop @path;
|
||
}
|
||
|
||
sub generate_paths {
|
||
#-------------------------------------------------------------------------------
|
||
# this method is used by the templates to generate all the paths that
|
||
# are required to have a direct point to the image file, this ensures that
|
||
# the images are not downloaded via the cgi, because the cgi puts an
|
||
# inordinate amount of load on the server
|
||
#
|
||
my $conf = Links::Plugins::get_plugin_user_cfg( 'SlideShow' );
|
||
my @image_cols = grep $_, map { s,^(\s*),,; s,(\s*)$,,; $_ } split /,/, $conf->{image_cols};
|
||
my $tags = $_[1] ? $_[1] : GT::Template->tags;
|
||
my $vars = {};
|
||
my $linkid = ( shift || $tags->{ID} ) or return;
|
||
|
||
my $rec = ( $tags->{ID} == $linkid and $tags->{SlideShowCache} )
|
||
? { SlideShowCache => $tags->{SlideShowCache} }
|
||
: $Links::DB->table( "Links" )->get( $linkid );
|
||
|
||
my $cache_dump = $vars->{SlideShowCache} || $rec->{SlideShowCache} || '{}';
|
||
|
||
my $cached = ( eval $cache_dump ) || {};
|
||
my $changed = 0;
|
||
my ($linksdb, $linkscols);
|
||
my @imgs_loop;
|
||
|
||
foreach my $img_col (@image_cols) {
|
||
if ( # if one has been wiped out
|
||
$cached->{unchanged}{$img_col} xor $rec->{$img_col} or
|
||
# if one has been changed
|
||
$cached->{unchanged}{$img_col} ne $rec->{$img_col} or
|
||
# if the cache contains nothing but the column does
|
||
(not exists $cached->{$img_col} and $rec->{$img_col})
|
||
) {
|
||
$cached->{unchanged}{$img_col} = $rec->{$img_col};
|
||
$changed = 1;
|
||
foreach my $coltype ('', qw( _thumbnail _medium _large _largest )) {
|
||
my $base_col = $img_col . $coltype;
|
||
|
||
$linksdb ||= $Links::DB->table( 'Links' );
|
||
$linkscols ||= $linksdb->cols;
|
||
|
||
next unless defined $linkscols->{$base_col};
|
||
|
||
my $fh = $linksdb->file_info($base_col, $linkid) or next;
|
||
my $fdir = $fh->File_Directory();
|
||
my $full_path = "$fh";
|
||
my $rel_path = $full_path;
|
||
$rel_path =~ s,$fdir,,;
|
||
$rel_path =~ s,%,%25,g;
|
||
|
||
if (-f $full_path) {
|
||
my ($width, $height) = imgsize($full_path);
|
||
$vars->{"${base_col}_height"} = $cached->{extra}{"${base_col}_height"} = $height;
|
||
$vars->{"${base_col}_width"} = $cached->{extra}{"${base_col}_width"} = $width;
|
||
};
|
||
|
||
$vars->{"${base_col}_path"} = $cached->{$base_col} = $rel_path ? qq!$conf->{image_url_path}$rel_path! : '';
|
||
}
|
||
}
|
||
else {
|
||
foreach my $coltype ('', qw( _thumbnail _medium _large _largest )) {
|
||
my $base_col = $img_col . $coltype;
|
||
$vars->{"${base_col}_path"} = $cached->{$base_col} || '';
|
||
$vars->{"${base_col}_path"} =~ s,^http://www.slowtwitch.com\/,\/,;
|
||
$vars->{"${base_col}_width" } = $cached->{extra}{"${base_col}_width"} || '';
|
||
$vars->{"${base_col}_height" } = $cached->{extra}{"${base_col}_height"} || '';
|
||
}
|
||
}
|
||
|
||
next unless $cached->{$img_col};
|
||
|
||
my $img_loop_element = {
|
||
col_name => $img_col,
|
||
description => $rec->{$img_col."_description"}
|
||
};
|
||
|
||
foreach my $coltype ('', qw( _thumbnail _medium _large _largest )) {
|
||
$img_loop_element->{"${coltype}_path"} = $cached->{"${img_col}${coltype}"};
|
||
$img_loop_element->{"${coltype}_path"} =~ s,^http://www.slowtwitch.com\/,\/,i;
|
||
$img_loop_element->{"${coltype}_width"} = $cached->{extra}{"${img_col}${coltype}_width"};
|
||
$img_loop_element->{"${coltype}_height"} = $cached->{extra}{"${img_col}${coltype}_height"};
|
||
}
|
||
|
||
push @imgs_loop, $img_loop_element;
|
||
}
|
||
|
||
if ($changed) {
|
||
$linksdb ||= $Links::DB->table('Links');
|
||
require GT::Dumper;
|
||
my $cache_dump = GT::Dumper->dump(data => $cached, var => '');
|
||
|
||
my $update_sth = $linksdb->prepare(
|
||
"UPDATE ".$linksdb->name." SET SlideShowCache = ? WHERE ID = ?"
|
||
);
|
||
$update_sth->execute($cache_dump, $linkid)
|
||
or warn "Couldn't update Link ID: $linkid because $GT::SQL::error";
|
||
}
|
||
|
||
$vars->{image_loop} = $vars->{images_loop} = \@imgs_loop if @imgs_loop;
|
||
|
||
return $vars;
|
||
}
|
||
|
||
sub field_management {
|
||
Plugins::SlideShow->_field_management(@_);
|
||
}
|
||
|
||
sub _field_management;
|
||
$COMPILE{_field_management} = __LINE__ . <<'END_OF_SUB';
|
||
sub _field_management {
|
||
# --------------------------------------------------
|
||
# get rid of the class name
|
||
my $junk = shift;
|
||
my $conf = Links::Plugins::get_plugin_user_cfg('SlideShow');
|
||
|
||
my $ltbl = $DB->table('Links');
|
||
my $lcols = $ltbl->cols;
|
||
|
||
my @thumbnail_fields = grep $_, map { s,^(\s*),,; s,(\s*)$,,; $_ } split /,/, $conf->{image_cols};
|
||
|
||
my @errors;
|
||
my $tags = {};
|
||
|
||
# register all the file save in locations
|
||
my %file_save_in;
|
||
|
||
my @columns;
|
||
|
||
foreach my $col (@thumbnail_fields) {
|
||
push @columns, $col;
|
||
push @columns, map { $conf->{"${_}_constraints_1"} ? "${col}_${_}" : () } @image_types;
|
||
push @columns, map { $conf->{"${_}_constraints_2"} ? "${col}_${_}" : () } @image_types;
|
||
push @columns, "${col}_description";
|
||
}
|
||
|
||
foreach my $col (@columns) {
|
||
next if ($col =~ /_description$/);
|
||
my $col_info = $lcols->{$col} or next;
|
||
push @{$file_save_in{$col_info->{file_save_in}}}, $col;
|
||
}
|
||
|
||
my ($create_file_save_in, $create_file_save_in_locked);
|
||
if (keys %file_save_in > 1) {
|
||
push @errors, {
|
||
message => 'There are more than one file_save_in locations specified across columns. SlideShow expects them all to be the same',
|
||
};
|
||
}
|
||
elsif (keys %file_save_in == 1) {
|
||
($create_file_save_in) = keys %file_save_in;
|
||
$create_file_save_in_locked = $create_file_save_in;
|
||
}
|
||
|
||
$create_file_save_in_locked or $create_file_save_in = $IN->param('create_file_save_in');
|
||
|
||
$tags->{create_file_save_in_locked} = $create_file_save_in_locked;
|
||
$tags->{create_file_save_in} = $create_file_save_in;
|
||
|
||
# Add columns to the Links table if asked
|
||
my %fields_checked;
|
||
if (my @create_fields = $IN->param("create_field")) {
|
||
%fields_checked = map {($_=>1)} @create_fields;
|
||
|
||
# Find out what types of fields we need to make. There are two types.
|
||
# File where the image file is loaded
|
||
# Description, a text field that contains a basic description of the image
|
||
my @ordered_create_fields = sort {
|
||
length($a) <=> length($b) || lc $a cmp lc $b
|
||
} @create_fields;
|
||
|
||
my $led = $DB->editor('Links');
|
||
|
||
foreach my $field_name (@ordered_create_fields) {
|
||
if ($field_name =~ /_description/) {
|
||
$led->add_col(
|
||
$field_name => {
|
||
form_display => $field_name,
|
||
form_type => 'TEXTAREA',
|
||
form_size => '30',
|
||
type => 'TEXT',
|
||
}
|
||
) or push @errors, {
|
||
message => q{Could not create field "$field_name" because "$GT::SQL::error"},
|
||
};
|
||
}
|
||
else {
|
||
unless ($create_file_save_in) {
|
||
push @errors, {
|
||
message => "You must provide a path to save the images being uploaded to create '$field_name'"
|
||
};
|
||
next;
|
||
}
|
||
$led->add_col(
|
||
$field_name => {
|
||
form_display => $field_name,
|
||
form_type => 'FILE',
|
||
type => 'char',
|
||
size => 200,
|
||
file_save_in => $create_file_save_in,
|
||
file_save_scheme => 'HASHED',
|
||
file_max_size => '',
|
||
}
|
||
) or push @errors, {
|
||
message => qq{Could not create field "$field_name" because "$GT::SQL::error"}
|
||
};
|
||
}
|
||
}
|
||
} # endif (my @create_fields = $IN->param("create_field"))
|
||
|
||
$tags->{fun_field_check} = sub {
|
||
my $field = shift;
|
||
return $fields_checked{$field} ? 'checked' : '';
|
||
};
|
||
|
||
my (@missing_fields, @available_fields);
|
||
foreach my $col (@columns) {
|
||
if ($lcols->{$col}) {
|
||
my $desc_col = { field_name => $col, %{$lcols->{$col}} };
|
||
$col =~ /description$/ and $desc_col->{file_save_in} = 'n/a';
|
||
push @available_fields, $desc_col;
|
||
}
|
||
else {
|
||
push @missing_fields, $col;
|
||
}
|
||
}
|
||
|
||
if (@missing_fields) {
|
||
$tags->{missing_field_list} = [
|
||
map {{ field_name => $_ }} @missing_fields
|
||
];
|
||
}
|
||
|
||
@errors and $tags->{errors} = \@errors;
|
||
@available_fields and $tags->{available_field_list} = \@available_fields;
|
||
|
||
my $cols_template = << 'END_OF_TEMPLATE';
|
||
<html>
|
||
|
||
<head>
|
||
<meta http-equiv="Content-Type" content="text/html; charset=windows-1252">
|
||
<title>Links SQL - Plugin Wizard</title>
|
||
</head>
|
||
|
||
<body bgcolor="#FFFFFF">
|
||
|
||
<p><font face="Tahoma,Arial,Helvetica" size="3"><b><table border="1" cellpadding="0" cellspacing="0"><tr><td>
|
||
<table bgColor="#ffffff" border="0" cellPadding="3" cellSpacing="3" width="500" valign="top">
|
||
<tr>
|
||
<td align="left" bgColor="navy"><b><font color="#ffffff" size="2" face="Tahoma,Arial,Helvetica">SlideShow Field Management</font></b></td>
|
||
|
||
</tr>
|
||
<tr>
|
||
<td>
|
||
<p align="center"><b><font color="#000000" size="2" face="Tahoma,Arial,Helvetica">Field Manager</font></b></p>
|
||
<p><font size="2" face="Tahoma,Arial,Helvetica">The SlideShow field manager allows you to rapidly create new image fields and inspect the existing image fields on your system.</font>
|
||
</td>
|
||
</tr>
|
||
</table>
|
||
|
||
</td></tr>
|
||
</table>
|
||
</b></font></p>
|
||
|
||
<%if errors%>
|
||
<table border="1" cellpadding="0" cellspacing="0"><tr><td>
|
||
|
||
<table bgColor="#ffffff" border="0" cellPadding="3" cellSpacing="0" width="500" valign="top">
|
||
|
||
<tr>
|
||
<td colspan=2><font face="Tahoma,Arial,Helvetica" size="2" color="red">
|
||
<b>Ooops, we had errors running the plugin action.</b>
|
||
<ul>
|
||
<%loop errors%>
|
||
<li><%message%></li>
|
||
<%endloop%>
|
||
</ul>
|
||
</font></td>
|
||
</tr>
|
||
|
||
</table>
|
||
|
||
</td></tr></table>
|
||
</p>
|
||
|
||
<%endif%>
|
||
|
||
<%if available_field_list%>
|
||
<p>
|
||
<table border="1" cellpadding="0" cellspacing="0"><tr><td>
|
||
|
||
<table bgColor="#ffffff" border="0" cellPadding="3" cellSpacing="0" width="500" valign="top">
|
||
|
||
<tr bgcolor='#aaaaaa'>
|
||
<td width='150' valign=bottom><font face="Tahoma,Arial,Helvetica" size="2"><b>
|
||
Field Name
|
||
</b></font></td>
|
||
<td valign=bottom><font face="Tahoma,Arial,Helvetica" size="2"><b>
|
||
File Save Path
|
||
</b></font></td>
|
||
</tr>
|
||
|
||
<%loop available_field_list%>
|
||
<tr>
|
||
|
||
<td><font face="Tahoma,Arial,Helvetica" size="2">
|
||
<%field_name%>
|
||
</font></td>
|
||
|
||
<td><font face="Tahoma,Arial,Helvetica" size="2">
|
||
<%file_save_in%>
|
||
</font></td>
|
||
|
||
</tr>
|
||
<%endloop%>
|
||
|
||
</table>
|
||
|
||
</td></tr></table>
|
||
</p>
|
||
<%endif%>
|
||
|
||
<%if missing_field_list%>
|
||
|
||
<form action="admin.cgi" method="post">
|
||
|
||
<input type="hidden" name="do" value="plugin">
|
||
<input type="hidden" name="plugin" value="SlideShow">
|
||
<input type="hidden" name="func" value="field_management">
|
||
|
||
<p>
|
||
<table border="1" cellpadding="0" cellspacing="0"><tr><td>
|
||
|
||
<table bgColor="#ffffff" border="0" cellPadding="3" cellSpacing="0" width="500" valign="top">
|
||
|
||
<tr>
|
||
<td colspan=2><font face="Tahoma,Arial,Helvetica" size="2" color="red">
|
||
Your database is currently missing fields that the
|
||
SlideShow plugin requires to function properly.
|
||
</font></td>
|
||
</tr>
|
||
|
||
</table>
|
||
|
||
</td></tr></table>
|
||
</p>
|
||
|
||
<p>
|
||
<table border="1" cellpadding="0" cellspacing="0"><tr><td>
|
||
|
||
<table bgColor="#ffffff" border="0" cellPadding="3" cellSpacing="0" width="500" valign="top">
|
||
|
||
<tr bgcolor='#aaaaaa'>
|
||
<td width='100' valign=bottom><font face="Tahoma,Arial,Helvetica" size="2"><b>
|
||
|
||
<script langauge="javascript">
|
||
<!--//
|
||
|
||
function check_items( status_checkbox ) {
|
||
// --------------------------------------------------
|
||
var target_checkboxes = status_checkbox.form.create_field;
|
||
|
||
for ( var i = 0; i < target_checkboxes.length; i++ ) {
|
||
target_checkboxes[i].checked = status_checkbox.checked ? true : false;
|
||
}
|
||
}
|
||
|
||
document.write( '<input type="checkbox" onchange="javascript:check_items( this )">' );
|
||
|
||
//-->
|
||
</script>
|
||
|
||
Create?
|
||
</b></font></td>
|
||
<td valign=bottom><font face="Tahoma,Arial,Helvetica" size="2"><b>Missing Column Name</b></font></td>
|
||
</tr>
|
||
|
||
<%loop missing_field_list%>
|
||
<tr>
|
||
<td><input type="checkbox" name="create_field" value="<%field_name%>" <%fun_field_check( $field_name )%>></td>
|
||
<td><font face="Tahoma,Arial,Helvetica" size="2">
|
||
<%field_name%>
|
||
</font></td>
|
||
</tr>
|
||
<%endloop%>
|
||
|
||
<tr>
|
||
<td colspan=2 align=center><hr></td>
|
||
</tr>
|
||
|
||
<tr>
|
||
<td colspan=2><font face="Tahoma,Arial,Helvetica" size="2">
|
||
<%if create_file_save_in_locked%>
|
||
<%html_escape create_file_save_in_locked%>
|
||
<%else%>
|
||
Please specify save directory: <input type="text" name="create_file_save_in" value="<%html_escape create_file_save_in%>">
|
||
<%endif%>
|
||
</font></td>
|
||
</tr>
|
||
|
||
<tr>
|
||
<td colspan=2 align=center><input type="submit" value="Update Database"></td>
|
||
</tr>
|
||
|
||
</table>
|
||
|
||
</td></tr></table>
|
||
</p>
|
||
|
||
</form>
|
||
|
||
<%endif%>
|
||
|
||
END_OF_TEMPLATE
|
||
|
||
print $IN->header;
|
||
require GT::Template;
|
||
print GT::Template->parse('slideshow_cols', $tags, { string => $cols_template });
|
||
|
||
}
|
||
END_OF_SUB
|
||
|
||
sub resize_image;
|
||
$COMPILE{resize_image} = __LINE__ . <<'END_OF_SUB';
|
||
sub resize_image {
|
||
# --------------------------------------------------
|
||
my ($fpath, $fopath, $mx, $my, $quality) = @_;
|
||
|
||
return unless -f $fpath;
|
||
return unless -s $fpath;
|
||
|
||
my $cfg = Links::Plugins->get_plugin_user_cfg('SlideShow');
|
||
|
||
# We will switch between the binary convert or the perl module
|
||
# Image::Magick based upon the key "convert_fpath". We believe
|
||
# the convert binary to be better than the perl module as is:
|
||
# a.) faster, no perl api to deal with
|
||
# b.) if it crashes don't take down perl with it and we can
|
||
# recover from the error (the perl module seems to
|
||
# segfault perl sometimes causing 500s and no recourse)
|
||
#
|
||
ATTEMPT_RESIZING: {
|
||
ATTEMPT_BINARY_CONVERT: {
|
||
if (my $convert_fpath = $cfg->{convert_fpath}) {
|
||
|
||
unless (-f $convert_fpath) {
|
||
warn "Cannot find '$convert_fpath'\n";
|
||
last ATTEMPT_BINARY_CONVERT;
|
||
}
|
||
|
||
unless (-x $convert_fpath) {
|
||
warn "Cannot execute '$convert_fpath'\n";
|
||
last ATTEMPT_BINARY_CONVERT;
|
||
}
|
||
|
||
my $err = system(
|
||
$convert_fpath,
|
||
($quality?("-quality",$quality):()),
|
||
"-geometry",
|
||
"${mx}x${my}",
|
||
$fpath,
|
||
$fopath
|
||
);
|
||
$err and warn "Could not convert using binary because: $?";
|
||
last ATTEMPT_RESIZING;
|
||
}
|
||
};
|
||
|
||
# Well, we don't have the convert f-path setup properly
|
||
# so let's just load up the perl modules.
|
||
|
||
# load up the image to resize
|
||
require Image::Magick;
|
||
my $image = Image::Magick->new();
|
||
my $err = $image->Read(filename => $fpath);
|
||
|
||
# deal with width
|
||
my ($iwidth, $iheight) = $image->Get('width', 'height');
|
||
my $resize_percent = 1;
|
||
|
||
if ($iwidth > $mx) {
|
||
$resize_percent = $mx / $iwidth;
|
||
}
|
||
|
||
if ($iheight * $resize_percent > $my) {
|
||
$resize_percent = $my / $iheight;
|
||
}
|
||
|
||
# Resize
|
||
my $nw = int($iwidth*$resize_percent);
|
||
my $nh = int($iheight*$resize_percent);
|
||
|
||
$err = $image->Scale(width => $nw, height => $nh);
|
||
$quality and $image->Set(quality => $quality);
|
||
$image->Write($fopath);
|
||
|
||
$image = undef;
|
||
}
|
||
|
||
return $fopath;
|
||
}
|
||
END_OF_SUB
|
||
|
||
sub crop_resize_image;
|
||
$COMPILE{crop_resize_image} = __LINE__ . <<'END_OF_SUB';
|
||
sub crop_resize_image {
|
||
# --------------------------------------------------
|
||
my ($fpath, $fopath, $mx, $my, $quality) = @_;
|
||
|
||
return unless -f $fpath;
|
||
return unless -s $fpath;
|
||
my $cfg = Links::Plugins->get_plugin_user_cfg('SlideShow');
|
||
|
||
# We will switch between the binary convert or the perl module
|
||
# Image::Magick based upon the key "convert_fpath". We believe
|
||
# the convert binary to be better than the perl module as is:
|
||
# a.) faster, no perl api to deal with
|
||
# b.) if it crashes don't take down perl with it and we can
|
||
# recover from the error (the perl module seems to
|
||
# segfault perl sometimes causing 500s and no recourse)
|
||
#
|
||
ATTEMPT_RESIZING: {
|
||
ATTEMPT_BINARY_CONVERT: {
|
||
if (my $convert_fpath = $cfg->{convert_fpath}) {
|
||
|
||
unless (-f $convert_fpath) {
|
||
warn "Cannot find '$convert_fpath'\n";
|
||
last ATTEMPT_BINARY_CONVERT;
|
||
}
|
||
|
||
unless (-x $convert_fpath) {
|
||
warn "Cannot execute '$convert_fpath'\n";
|
||
last ATTEMPT_BINARY_CONVERT;
|
||
}
|
||
|
||
# Find out the parameters of the image
|
||
my ($iwidth, $iheight) = imgsize($fpath);
|
||
my $crop_resize_percent = 1;
|
||
|
||
if ($iwidth > $mx) {
|
||
$crop_resize_percent = $mx / $iwidth;
|
||
}
|
||
|
||
if ($iheight * $crop_resize_percent < $my) {
|
||
$crop_resize_percent = $my / $iheight;
|
||
}
|
||
|
||
# Resize and crop
|
||
my $nw = int($iwidth*$crop_resize_percent);
|
||
my $nh = int($iheight*$crop_resize_percent);
|
||
my $ox = int(($nw - $mx) / 2);
|
||
my $oy = int(($nh - $my) / 2);
|
||
|
||
my $err = system(
|
||
$convert_fpath,
|
||
"-scale",
|
||
"${nw}x${nh}",
|
||
"-crop",
|
||
"${mx}x${my}+${ox}+${oy}",
|
||
$fpath,
|
||
$fopath
|
||
);
|
||
$err and warn "Could not convert using binary because: $?";
|
||
last ATTEMPT_RESIZING;
|
||
}
|
||
};
|
||
|
||
# Well, we don't have the convert f-path setup properly
|
||
# so let's just load up the perl modules.
|
||
|
||
# load up the image to crop_resize
|
||
require Image::Magick;
|
||
my $image = Image::Magick->new();
|
||
my $err = $image->Read(filename => $fpath);
|
||
|
||
# deal with width
|
||
my ($iwidth, $iheight) = $image->Get('width', 'height');
|
||
my $crop_resize_percent = 1;
|
||
|
||
if ($iwidth > $mx) {
|
||
$crop_resize_percent = $mx / $iwidth;
|
||
}
|
||
|
||
if ($iheight * $crop_resize_percent < $my) {
|
||
$crop_resize_percent = $my / $iheight;
|
||
}
|
||
|
||
# Resize
|
||
my $nw = int($iwidth*$crop_resize_percent);
|
||
my $nh = int($iheight*$crop_resize_percent);
|
||
$err = $image->Scale(width => $nw, height => $nh);
|
||
|
||
# And now we can crop
|
||
my $ox = int(($nw - $mx) / 2);
|
||
my $oy = int(($nh - $my) / 2);
|
||
|
||
$err = $image->Crop("${mx}x${my}+$ox+$oy");
|
||
$quality and $image->Set(quality => $quality);
|
||
$image->Write($fopath);
|
||
|
||
$image = undef;
|
||
};
|
||
|
||
return $fopath;
|
||
}
|
||
END_OF_SUB
|
||
|
||
sub apply_watermark;
|
||
$COMPILE{apply_watermark} = __LINE__ . <<'END_OF_SUB';
|
||
sub apply_watermark {
|
||
# --------------------------------------------------
|
||
my ( $fpath, $watermark_path, $quality ) = @_;
|
||
return unless $watermark_path and -f $watermark_path;
|
||
|
||
ATTEMPT_WATERMARKING: {
|
||
ATTEMPT_BINARY_WATERMARKING: {
|
||
unless (-f $convert_fpath) {
|
||
warn "Cannot find '$convert_fpath'\n";
|
||
last ATTEMPT_BINARY_CONVERT;
|
||
}
|
||
|
||
unless (-x $convert_fpath) {
|
||
warn "Cannot execute '$convert_fpath'\n";
|
||
last ATTEMPT_BINARY_CONVERT;
|
||
}
|
||
|
||
# Then let's composite the original image over the target
|
||
my $err = system(
|
||
$convert_fpath,
|
||
$fpath,
|
||
$watermark_path,
|
||
"-geometry",
|
||
"+10+10",
|
||
"-composite",
|
||
$fopath
|
||
);
|
||
$err and warn "Could not convert using binary because: $?";
|
||
last ATTEMPT_WATERMARKING;
|
||
};
|
||
|
||
# Seems like we couldn't get the binary version of the watermarking working
|
||
require Image::Magick;
|
||
|
||
my $base = Image::Magick->new;
|
||
my $im = Image::Magick->new;
|
||
|
||
my $err;
|
||
$err = $base->Read($fpath);
|
||
$err and warn $err and return;
|
||
$err = $im->Read($watermark_path);
|
||
$err and warn $err and return;
|
||
|
||
my $mask = $im->clone;
|
||
$err = $base->Composite(
|
||
image => $im,
|
||
opacity => '50',
|
||
compose => 'Over',
|
||
mask => $mask,
|
||
x => 10,
|
||
y => 10,
|
||
);
|
||
$err and warn $err and return;
|
||
|
||
$quality and $im->Set(quality => $quality);
|
||
|
||
$err = $base->Write($fpath);
|
||
$err and warn $err and return;
|
||
}
|
||
|
||
$base = $mask = $im = undef;
|
||
}
|
||
END_OF_SUB
|
||
|
||
sub imgsize {
|
||
# --------------------------------------------------
|
||
my $full_path = shift;
|
||
|
||
unless ($INC{"GT/Image/Size.pm"}) {
|
||
eval "require GT::Image::Size";
|
||
if ($@) {
|
||
{
|
||
local $/;
|
||
my $buf = <DATA>;
|
||
eval $buf;
|
||
};
|
||
$INC{"GT/Image/Size.pm"}++;
|
||
}
|
||
}
|
||
|
||
return GT::Image::Size::imgsize($full_path);
|
||
}
|
||
|
||
sub throw_error {
|
||
# --------------------------------------------------
|
||
my $error = shift;
|
||
GT::Plugins->action( STOP );
|
||
$DB->table('Links')->warn($error);
|
||
return;
|
||
}
|
||
|
||
# Always end with a 1.
|
||
1;
|
||
__DATA__
|
||
# ==================================================================
|
||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||
#
|
||
# GT::Image::Size
|
||
# Author: via CPAN (see POD)
|
||
# Revision: $Id: SlideShow.pm,v 1.33 2008/09/11 16:23:05 aaron Exp $
|
||
# Based off: Image::Size, 2.99
|
||
#
|
||
# ==================================================================
|
||
#
|
||
# This module is used to determine the size of a file, and is based on
|
||
# Image::Size (available at CPAN) version 2.99. It's been hacked up
|
||
# a little to use GT::AutoLoader instead of AutoLoader. It also had to
|
||
# be changed to _not_ use File::Spec, since that wasn't standard in
|
||
# Perl 5.004_04.
|
||
#
|
||
# Image/Size.pm had the following header:
|
||
#
|
||
###############################################################################
|
||
#
|
||
# This file copyright (c) 2000 by Randy J. Ray, all rights reserved
|
||
#
|
||
# Copying and distribution are permitted under the terms of the Artistic
|
||
# License as distributed with Perl versions 5.005 and later.
|
||
#
|
||
###############################################################################
|
||
#
|
||
# Once upon a time, this code was lifted almost verbatim from wwwis by Alex
|
||
# Knowles, alex@ed.ac.uk. Since then, even I barely recognize it. It has
|
||
# contributions, fixes, additions and enhancements from all over the world.
|
||
#
|
||
# See the file README [of the Image-Size package on CPAN] for change history.
|
||
#
|
||
###############################################################################
|
||
|
||
package GT::Image::Size;
|
||
|
||
require 5.002;
|
||
|
||
use strict;
|
||
use Cwd ();
|
||
use Symbol ();
|
||
use GT::AutoLoader;
|
||
require Exporter;
|
||
use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $revision $VERSION $NO_CACHE
|
||
%PCD_MAP $PCD_SCALE $read_in $last_pos *imagemagick_size);
|
||
|
||
@ISA = qw(Exporter);
|
||
@EXPORT = qw(imgsize);
|
||
@EXPORT_OK = qw(imgsize html_imgsize attr_imgsize $NO_CACHE $PCD_SCALE);
|
||
%EXPORT_TAGS = ('all' => [ @EXPORT_OK ]);
|
||
|
||
$revision = q$Id: SlideShow.pm,v 1.33 2008/09/11 16:23:05 aaron Exp $;
|
||
$VERSION = '1.20080911';
|
||
|
||
# Check if we have Image::Magick available
|
||
BEGIN {
|
||
eval {
|
||
local $SIG{__DIE__}; # protect against user installed die handlers
|
||
require Image::Magick;
|
||
};
|
||
if ($@) {
|
||
*imagemagick_size =
|
||
sub
|
||
{
|
||
(undef, undef, "Data stream is not a known image file format");
|
||
};
|
||
} else {
|
||
*imagemagick_size =
|
||
sub
|
||
{
|
||
my ($file_name) = @_;
|
||
my $img = Image::Magick->new();
|
||
my $x = $img->Read($file_name);
|
||
# Image::Magick error handling is a bit weird, see
|
||
# <http://www.simplesystems.org/ImageMagick/www/perl.html#erro>
|
||
if("$x") {
|
||
return (undef, undef, "$x");
|
||
} else {
|
||
return ($img->Get('width', 'height', 'format'));
|
||
}
|
||
};
|
||
}
|
||
}
|
||
|
||
# This allows people to specifically request that the cache not be used
|
||
$NO_CACHE = 0;
|
||
|
||
# Package lexicals - invisible to outside world, used only in imgsize
|
||
#
|
||
# Cache of files seen, and mapping of patterns to the sizing routine
|
||
my %cache = ();
|
||
my %type_map = ( '^GIF8[7,9]a' => \&gifsize,
|
||
"^\xFF\xD8" => \&jpegsize,
|
||
"^\x89PNG\x0d\x0a\x1a\x0a" => \&pngsize,
|
||
"^P[1-7]" => \&ppmsize, # also XVpics
|
||
'\#define\s+\S+\s+\d+' => \&xbmsize,
|
||
'\/\* XPM \*\/' => \&xpmsize,
|
||
'^MM\x00\x2a' => \&tiffsize,
|
||
'^II\x2a\x00' => \&tiffsize,
|
||
'^BM' => \&bmpsize,
|
||
'^8BPS' => \&psdsize,
|
||
'^PCD_OPA' => \&pcdsize,
|
||
'^FWS' => \&swfsize,
|
||
"^\x8aMNG\x0d\x0a\x1a\x0a" => \&mngsize);
|
||
# Kodak photo-CDs are weird. Don't ask me why, you really don't want details.
|
||
%PCD_MAP = ( 'base/16' => [ 192, 128 ],
|
||
'base/4' => [ 384, 256 ],
|
||
'base' => [ 768, 512 ],
|
||
'base4' => [ 1536, 1024 ],
|
||
'base16' => [ 3072, 2048 ],
|
||
'base64' => [ 6144, 4096 ] );
|
||
# Default scale for PCD images
|
||
$PCD_SCALE = 'base';
|
||
|
||
#
|
||
# These are lexically-scoped anonymous subroutines for reading the three
|
||
# types of input streams. When the input to imgsize() is typed, then the
|
||
# lexical "read_in" is assigned one of these, thus allowing the individual
|
||
# routines to operate on these streams abstractly.
|
||
#
|
||
|
||
my $read_io = sub {
|
||
my $handle = shift;
|
||
my ($length, $offset) = @_;
|
||
|
||
if (defined($offset) && ($offset != $last_pos))
|
||
{
|
||
$last_pos = $offset;
|
||
return '' if (! seek($handle, $offset, 0));
|
||
}
|
||
|
||
my ($data, $rtn) = ('', 0);
|
||
$rtn = read $handle, $data, $length;
|
||
$data = '' unless ($rtn);
|
||
$last_pos = tell $handle;
|
||
|
||
$data;
|
||
};
|
||
|
||
my $read_buf = sub {
|
||
my $buf = shift;
|
||
my ($length, $offset) = @_;
|
||
|
||
if (defined($offset) && ($offset != $last_pos))
|
||
{
|
||
$last_pos = $offset;
|
||
return '' if ($last_pos > length($$buf));
|
||
}
|
||
|
||
my $data = substr($$buf, $last_pos, $length);
|
||
$last_pos += length($data);
|
||
|
||
$data;
|
||
};
|
||
|
||
sub imgsize
|
||
{
|
||
my $stream = shift;
|
||
|
||
my ($handle, $header);
|
||
my ($x, $y, $id, $mtime, @list);
|
||
# These only used if $stream is an existant open FH
|
||
my ($save_pos, $need_restore) = (0, 0);
|
||
# This is for when $stream is a locally-opened file
|
||
my $need_close = 0;
|
||
# This will contain the file name, if we got one
|
||
my $file_name = undef;
|
||
|
||
$header = '';
|
||
|
||
if (ref($stream) eq "SCALAR")
|
||
{
|
||
$handle = $stream;
|
||
$read_in = $read_buf;
|
||
$header = substr($$handle, 0, 256);
|
||
}
|
||
elsif (ref $stream)
|
||
{
|
||
#
|
||
# I no longer require $stream to be in the IO::* space. So I'm assuming
|
||
# you don't hose yourself by passing a ref that can't do fileops. If
|
||
# you do, you fix it.
|
||
#
|
||
$handle = $stream;
|
||
$read_in = $read_io;
|
||
$save_pos = tell $handle;
|
||
$need_restore = 1;
|
||
|
||
#
|
||
# First alteration (didn't wait long, did I?) to the existant handle:
|
||
#
|
||
# assist dain-bramaged operating systems -- SWD
|
||
# SWD: I'm a bit uncomfortable with changing the mode on a file
|
||
# that something else "owns" ... the change is global, and there
|
||
# is no way to reverse it.
|
||
# But image files ought to be handled as binary anyway.
|
||
#
|
||
binmode($handle);
|
||
seek($handle, 0, 0);
|
||
read $handle, $header, 256;
|
||
seek($handle, 0, 0);
|
||
}
|
||
else
|
||
{
|
||
unless ($NO_CACHE)
|
||
{
|
||
$stream = Cwd::cwd() . '/' . $stream
|
||
unless $stream =~ m{^(?:[a-zA-Z]:)?[\\/]};
|
||
$mtime = (stat $stream)[9];
|
||
if (-e "$stream" and exists $cache{$stream})
|
||
{
|
||
@list = split(/,/, $cache{$stream}, 4);
|
||
|
||
# Don't return the cache if the file is newer.
|
||
return @list[1 .. 3] unless ($list[0] < $mtime);
|
||
# In fact, clear it
|
||
delete $cache{$stream};
|
||
}
|
||
}
|
||
|
||
#first try to open the stream
|
||
$handle = Symbol::gensym();
|
||
open($handle, "< $stream") or
|
||
return (undef, undef, "Can't open image file $stream: $!");
|
||
|
||
$need_close = 1;
|
||
# assist dain-bramaged operating systems -- SWD
|
||
binmode($handle);
|
||
read $handle, $header, 256;
|
||
seek($handle, 0, 0);
|
||
$read_in = $read_io;
|
||
$file_name = $stream;
|
||
}
|
||
$last_pos = 0;
|
||
|
||
#
|
||
# Oh pessimism... set the values of $x and $y to the error condition. If
|
||
# the grep() below matches the data to one of the known types, then the
|
||
# called subroutine will override these...
|
||
#
|
||
$id = "Data stream is not a known image file format";
|
||
$x = undef;
|
||
$y = undef;
|
||
|
||
grep($header =~ /$_/ && (($x, $y, $id) = &{$type_map{$_}}($handle)),
|
||
keys %type_map);
|
||
|
||
#
|
||
# Added as an afterthought: I'm probably not the only one who uses the
|
||
# same shaded-sphere image for several items on a bulleted list:
|
||
#
|
||
$cache{$stream} = join(',', $mtime, $x, $y, $id)
|
||
unless ($NO_CACHE or (ref $stream) or (! defined $x));
|
||
|
||
#
|
||
# If we were passed an existant file handle, we need to restore the
|
||
# old filepos:
|
||
#
|
||
seek($handle, $save_pos, 0) if $need_restore;
|
||
# ...and if we opened the file ourselves, we need to close it
|
||
close($handle) if $need_close;
|
||
|
||
#
|
||
# Image::Magick operates on file names.
|
||
#
|
||
if ($file_name && ! defined($x) && ! defined($y)) {
|
||
($x, $y, $id) = imagemagick_size($file_name);
|
||
}
|
||
|
||
|
||
# results:
|
||
return (wantarray) ? ($x, $y, $id) : ();
|
||
}
|
||
|
||
sub html_imgsize
|
||
{
|
||
my @args = imgsize(@_);
|
||
|
||
# Use lowercase and quotes so that it works with xhtml.
|
||
return ((defined $args[0]) ?
|
||
sprintf('width="%d" height="%d"', @args) :
|
||
undef);
|
||
}
|
||
|
||
sub attr_imgsize
|
||
{
|
||
my @args = imgsize(@_);
|
||
|
||
return ((defined $args[0]) ?
|
||
(('-width', '-height', @args)[0, 2, 1, 3]) :
|
||
undef);
|
||
}
|
||
|
||
# This used only in gifsize:
|
||
sub img_eof
|
||
{
|
||
my $stream = shift;
|
||
|
||
return ($last_pos >= length($$stream)) if (ref($stream) eq "SCALAR");
|
||
|
||
eof $stream;
|
||
}
|
||
|
||
#
|
||
# Autoloaded subroutines below this point
|
||
#
|
||
|
||
###########################################################################
|
||
# Subroutine gets the size of the specified GIF
|
||
###########################################################################
|
||
$COMPILE{gifsize} = __LINE__ . <<'END_OF_SUB';
|
||
sub gifsize {
|
||
my $stream = shift;
|
||
|
||
my ($cmapsize, $buf, $h, $w, $x, $y, $type);
|
||
|
||
my $gif_blockskip = sub {
|
||
my ($skip, $type) = @_;
|
||
my ($lbuf);
|
||
|
||
&$read_in($stream, $skip); # Skip header (if any)
|
||
while (1)
|
||
{
|
||
if (&img_eof($stream))
|
||
{
|
||
return (undef, undef,
|
||
"Invalid/Corrupted GIF (at EOF in GIF $type)");
|
||
}
|
||
$lbuf = &$read_in($stream, 1); # Block size
|
||
last if ord($lbuf) == 0; # Block terminator
|
||
&$read_in($stream, ord($lbuf)); # Skip data
|
||
}
|
||
};
|
||
|
||
$type = &$read_in($stream, 6);
|
||
if (length($buf = &$read_in($stream, 7)) != 7 )
|
||
{
|
||
return (undef, undef, "Invalid/Corrupted GIF (bad header)");
|
||
}
|
||
($x) = unpack("x4 C", $buf);
|
||
if ($x & 0x80)
|
||
{
|
||
$cmapsize = 3 * (2**(($x & 0x07) + 1));
|
||
if (! &$read_in($stream, $cmapsize))
|
||
{
|
||
return (undef, undef,
|
||
"Invalid/Corrupted GIF (global color map too small?)");
|
||
}
|
||
}
|
||
|
||
FINDIMAGE:
|
||
while (1)
|
||
{
|
||
if (&img_eof($stream))
|
||
{
|
||
return (undef, undef,
|
||
"Invalid/Corrupted GIF (at EOF w/o Image Descriptors)");
|
||
}
|
||
$buf = &$read_in($stream, 1);
|
||
($x) = unpack("C", $buf);
|
||
if ($x == 0x2c)
|
||
{
|
||
# Image Descriptor (GIF87a, GIF89a 20.c.i)
|
||
if (length($buf = &$read_in($stream, 8)) != 8)
|
||
{
|
||
return (undef, undef,
|
||
"Invalid/Corrupted GIF (missing image header?)");
|
||
}
|
||
($x, $w, $y, $h) = unpack("x4 C4", $buf);
|
||
$x += $w * 256;
|
||
$y += $h * 256;
|
||
return ($x, $y, 'GIF');
|
||
}
|
||
if ($x == 0x21)
|
||
{
|
||
# Extension Introducer (GIF89a 23.c.i, could also be in GIF87a)
|
||
$buf = &$read_in($stream, 1);
|
||
($x) = unpack("C", $buf);
|
||
if ($x == 0xF9)
|
||
{
|
||
# Graphic Control Extension (GIF89a 23.c.ii)
|
||
&$read_in($stream, 6); # Skip it
|
||
next FINDIMAGE; # Look again for Image Descriptor
|
||
}
|
||
elsif ($x == 0xFE)
|
||
{
|
||
# Comment Extension (GIF89a 24.c.ii)
|
||
&$gif_blockskip(0, "Comment");
|
||
next FINDIMAGE; # Look again for Image Descriptor
|
||
}
|
||
elsif ($x == 0x01)
|
||
{
|
||
# Plain Text Label (GIF89a 25.c.ii)
|
||
&$gif_blockskip(13, "text data");
|
||
next FINDIMAGE; # Look again for Image Descriptor
|
||
}
|
||
elsif ($x == 0xFF)
|
||
{
|
||
# Application Extension Label (GIF89a 26.c.ii)
|
||
&$gif_blockskip(12, "application data");
|
||
next FINDIMAGE; # Look again for Image Descriptor
|
||
}
|
||
else
|
||
{
|
||
return (undef, undef,
|
||
sprintf("Invalid/Corrupted GIF (Unknown " .
|
||
"extension %#x)", $x));
|
||
}
|
||
}
|
||
else
|
||
{
|
||
return (undef, undef,
|
||
sprintf("Invalid/Corrupted GIF (Unknown code %#x)",
|
||
$x));
|
||
}
|
||
}
|
||
}
|
||
END_OF_SUB
|
||
|
||
$COMPILE{xbmsize} = __LINE__ . <<'END_OF_SUB';
|
||
sub xbmsize {
|
||
my $stream = shift;
|
||
|
||
my $input;
|
||
my ($x, $y, $id) = (undef, undef, "Could not determine XBM size");
|
||
|
||
$input = &$read_in($stream, 1024);
|
||
if ($input =~ /^\#define\s*\S*\s*(\d+)\s*\n\#define\s*\S*\s*(\d+)/si)
|
||
{
|
||
($x, $y) = ($1, $2);
|
||
$id = 'XBM';
|
||
}
|
||
|
||
($x, $y, $id);
|
||
}
|
||
END_OF_SUB
|
||
|
||
# Added by Randy J. Ray, 30 Jul 1996
|
||
# Size an XPM file by looking for the "X Y N W" line, where X and Y are
|
||
# dimensions, N is the total number of colors defined, and W is the width of
|
||
# a color in the ASCII representation, in characters. We only care about X & Y.
|
||
$COMPILE{xpmsize} = __LINE__ . <<'END_OF_SUB';
|
||
sub xpmsize {
|
||
my $stream = shift;
|
||
|
||
my $line;
|
||
my ($x, $y, $id) = (undef, undef, "Could not determine XPM size");
|
||
|
||
while ($line = &$read_in($stream, 1024))
|
||
{
|
||
next unless ($line =~ /"\s*(\d+)\s+(\d+)(\s+\d+\s+\d+){1,2}\s*"/s);
|
||
($x, $y) = ($1, $2);
|
||
$id = 'XPM';
|
||
last;
|
||
}
|
||
|
||
($x, $y, $id);
|
||
}
|
||
END_OF_SUB
|
||
|
||
|
||
# pngsize : gets the width & height (in pixels) of a png file
|
||
# cor this program is on the cutting edge of technology! (pity it's blunt!)
|
||
#
|
||
# Re-written and tested by tmetro@vl.com
|
||
$COMPILE{pngsize} = __LINE__ . <<'END_OF_SUB';
|
||
sub pngsize {
|
||
my $stream = shift;
|
||
|
||
my ($x, $y, $id) = (undef, undef, "could not determine PNG size");
|
||
my ($offset, $length);
|
||
|
||
# Offset to first Chunk Type code = 8-byte ident + 4-byte chunk length + 1
|
||
$offset = 12; $length = 4;
|
||
if (&$read_in($stream, $length, $offset) eq 'IHDR')
|
||
{
|
||
# IHDR = Image Header
|
||
$length = 8;
|
||
($x, $y) = unpack("NN", &$read_in($stream, $length));
|
||
$id = 'PNG';
|
||
}
|
||
|
||
($x, $y, $id);
|
||
}
|
||
END_OF_SUB
|
||
|
||
# mngsize: gets the width and height (in pixels) of an MNG file.
|
||
# See <URL:http://www.libpng.org/pub/mng/spec/> for the specification.
|
||
#
|
||
# Basically a copy of pngsize.
|
||
$COMPILE{mngsize} = __LINE__ . <<'END_OF_SUB';
|
||
sub mngsize {
|
||
my $stream = shift;
|
||
|
||
my ($x, $y, $id) = (undef, undef, "could not determine MNG size");
|
||
my ($offset, $length);
|
||
|
||
# Offset to first Chunk Type code = 8-byte ident + 4-byte chunk length + 1
|
||
$offset = 12; $length = 4;
|
||
if (&$read_in($stream, $length, $offset) eq 'MHDR')
|
||
{
|
||
# MHDR = Image Header
|
||
$length = 8;
|
||
($x, $y) = unpack("NN", &$read_in($stream, $length));
|
||
$id = 'MNG';
|
||
}
|
||
|
||
($x, $y, $id);
|
||
}
|
||
END_OF_SUB
|
||
|
||
# jpegsize: gets the width and height (in pixels) of a jpeg file
|
||
# Andrew Tong, werdna@ugcs.caltech.edu February 14, 1995
|
||
# modified slightly by alex@ed.ac.uk
|
||
# and further still by rjray@blackperl.com
|
||
# optimization and general re-write from tmetro@vl.com
|
||
$COMPILE{jpegsize} = __LINE__ . <<'END_OF_SUB';
|
||
sub jpegsize {
|
||
my $stream = shift;
|
||
|
||
my $MARKER = "\xFF"; # Section marker.
|
||
|
||
my $SIZE_FIRST = 0xC0; # Range of segment identifier codes
|
||
my $SIZE_LAST = 0xC3; # that hold size info.
|
||
|
||
my ($x, $y, $id) = (undef, undef, "could not determine JPEG size");
|
||
|
||
my ($marker, $code, $length);
|
||
my $segheader;
|
||
|
||
# Dummy read to skip header ID
|
||
&$read_in($stream, 2);
|
||
while (1)
|
||
{
|
||
$length = 4;
|
||
$segheader = &$read_in($stream, $length);
|
||
|
||
# Extract the segment header.
|
||
($marker, $code, $length) = unpack("a a n", $segheader);
|
||
|
||
# Verify that it's a valid segment.
|
||
if ($marker ne $MARKER)
|
||
{
|
||
# Was it there?
|
||
$id = "JPEG marker not found";
|
||
last;
|
||
}
|
||
elsif ((ord($code) >= $SIZE_FIRST) && (ord($code) <= $SIZE_LAST))
|
||
{
|
||
# Segments that contain size info
|
||
$length = 5;
|
||
($y, $x) = unpack("xnn", &$read_in($stream, $length));
|
||
$id = 'JPG';
|
||
last;
|
||
}
|
||
else
|
||
{
|
||
# Dummy read to skip over data
|
||
&$read_in($stream, ($length - 2));
|
||
}
|
||
}
|
||
|
||
($x, $y, $id);
|
||
}
|
||
END_OF_SUB
|
||
|
||
# ppmsize: gets data on the PPM/PGM/PBM family.
|
||
#
|
||
# Contributed by Carsten Dominik <dominik@strw.LeidenUniv.nl>
|
||
$COMPILE{ppmsize} = __LINE__ . <<'END_OF_SUB';
|
||
sub ppmsize {
|
||
my $stream = shift;
|
||
|
||
my ($x, $y, $id) = (undef, undef,
|
||
"Unable to determine size of PPM/PGM/PBM data");
|
||
my $n;
|
||
|
||
my $header = &$read_in($stream, 1024);
|
||
|
||
# PPM file of some sort
|
||
$header =~ s/^\#.*//mg;
|
||
($n, $x, $y) = ($header =~ /^(P[1-6])\s+(\d+)\s+(\d+)/s);
|
||
$id = "PBM" if $n eq "P1" || $n eq "P4";
|
||
$id = "PGM" if $n eq "P2" || $n eq "P5";
|
||
$id = "PPM" if $n eq "P3" || $n eq "P6";
|
||
if ($n eq 'P7')
|
||
{
|
||
# John Bradley's XV thumbnail pics (thanks to inwap@jomis.Tymnet.COM)
|
||
$id = 'XV';
|
||
($x, $y) = ($header =~ /IMGINFO:(\d+)x(\d+)/s);
|
||
}
|
||
|
||
($x, $y, $id);
|
||
}
|
||
END_OF_SUB
|
||
|
||
# tiffsize: size a TIFF image
|
||
#
|
||
# Contributed by Cloyce Spradling <cloyce@headgear.org>
|
||
$COMPILE{tiffsize} = __LINE__ . <<'END_OF_SUB';
|
||
sub tiffsize {
|
||
my $stream = shift;
|
||
|
||
my ($x, $y, $id) = (undef, undef, "Unable to determine size of TIFF data");
|
||
|
||
my $endian = 'n'; # Default to big-endian; I like it better
|
||
my $header = &$read_in($stream, 4);
|
||
$endian = 'v' if ($header =~ /II\x2a\x00/o); # little-endian
|
||
|
||
# Set up an association between data types and their corresponding
|
||
# pack/unpack specification. Don't take any special pains to deal with
|
||
# signed numbers; treat them as unsigned because none of the image
|
||
# dimensions should ever be negative. (I hope.)
|
||
my @packspec = ( undef, # nothing (shouldn't happen)
|
||
'C', # BYTE (8-bit unsigned integer)
|
||
undef, # ASCII
|
||
$endian, # SHORT (16-bit unsigned integer)
|
||
uc($endian), # LONG (32-bit unsigned integer)
|
||
undef, # RATIONAL
|
||
'c', # SBYTE (8-bit signed integer)
|
||
undef, # UNDEFINED
|
||
$endian, # SSHORT (16-bit unsigned integer)
|
||
uc($endian), # SLONG (32-bit unsigned integer)
|
||
);
|
||
|
||
my $offset = &$read_in($stream, 4, 4); # Get offset to IFD
|
||
$offset = unpack(uc($endian), $offset); # Fix it so we can use it
|
||
|
||
my $ifd = &$read_in($stream, 2, $offset); # Get number of directory entries
|
||
my $num_dirent = unpack($endian, $ifd); # Make it useful
|
||
$offset += 2;
|
||
$num_dirent = $offset + ($num_dirent * 12); # Calc. maximum offset of IFD
|
||
|
||
# Do all the work
|
||
$ifd = '';
|
||
my $tag = 0;
|
||
my $type = 0;
|
||
while (!defined($x) || !defined($y)) {
|
||
$ifd = &$read_in($stream, 12, $offset); # Get first directory entry
|
||
last if (($ifd eq '') || ($offset > $num_dirent));
|
||
$offset += 12;
|
||
$tag = unpack($endian, $ifd); # ...and decode its tag
|
||
$type = unpack($endian, substr($ifd, 2, 2)); # ...and the data type
|
||
# Check the type for sanity.
|
||
next if (($type > @packspec+0) || (!defined($packspec[$type])));
|
||
if ($tag == 0x0100) { # ImageWidth (x)
|
||
# Decode the value
|
||
$x = unpack($packspec[$type], substr($ifd, 8, 4));
|
||
} elsif ($tag == 0x0101) { # ImageLength (y)
|
||
# Decode the value
|
||
$y = unpack($packspec[$type], substr($ifd, 8, 4));
|
||
}
|
||
}
|
||
|
||
# Decide if we were successful or not
|
||
if (defined($x) && defined($y)) {
|
||
$id = 'TIF';
|
||
} else {
|
||
$id = '';
|
||
$id = 'ImageWidth ' if (!defined($x));
|
||
if (!defined ($y)) {
|
||
$id .= 'and ' if ($id ne '');
|
||
$id .= 'ImageLength ';
|
||
}
|
||
$id .= 'tag(s) could not be found';
|
||
}
|
||
|
||
($x, $y, $id);
|
||
}
|
||
END_OF_SUB
|
||
|
||
# bmpsize: size a Windows-ish BitMaP image
|
||
#
|
||
# Adapted from code contributed by Aldo Calpini <a.calpini@romagiubileo.it>
|
||
$COMPILE{bmpsize} = __LINE__ . <<'END_OF_SUB';
|
||
sub bmpsize {
|
||
my $stream = shift;
|
||
|
||
my ($x, $y, $id) = (undef, undef, "Unable to determine size of BMP data");
|
||
my ($buffer);
|
||
|
||
$buffer = &$read_in($stream, 26);
|
||
($x, $y) = unpack("x18VV", $buffer);
|
||
$id = 'BMP' if (defined $x and defined $y);
|
||
|
||
($x, $y, $id);
|
||
}
|
||
END_OF_SUB
|
||
|
||
# psdsize: determine the size of a PhotoShop save-file (*.PSD)
|
||
$COMPILE{psdsize} = __LINE__ . <<'END_OF_SUB';
|
||
sub psdsize {
|
||
my $stream = shift;
|
||
|
||
my ($x, $y, $id) = (undef, undef, "Unable to determine size of PSD data");
|
||
my ($buffer);
|
||
|
||
$buffer = &$read_in($stream, 26);
|
||
($y, $x) = unpack("x14NN", $buffer);
|
||
$id = 'PSD' if (defined $x and defined $y);
|
||
|
||
($x, $y, $id);
|
||
}
|
||
END_OF_SUB
|
||
|
||
# swfsize: determine size of ShockWave/Flash files. Adapted from code sent by
|
||
# Dmitry Dorofeev <dima@yasp.com>
|
||
$COMPILE{swfsize} = __LINE__ . <<'END_OF_SUB';
|
||
sub swfsize {
|
||
my $image = shift;
|
||
my $header = &$read_in($image, 33);
|
||
|
||
sub _bin2int { unpack("N", pack("B32", substr("0" x 32 . shift, -32))); }
|
||
|
||
my $ver = _bin2int(unpack 'B8', substr($header, 3, 1));
|
||
my $bs = unpack 'B133', substr($header, 8, 17);
|
||
my $bits = _bin2int(substr($bs, 0, 5));
|
||
my $x = int(_bin2int(substr($bs, 5+$bits, $bits))/20);
|
||
my $y = int(_bin2int(substr($bs, 5+$bits*3, $bits))/20);
|
||
|
||
return ($x, $y, 'SWF');
|
||
}
|
||
END_OF_SUB
|
||
|
||
# Suggested by Matt Mueller <mueller@wetafx.co.nz>, and based on a piece of
|
||
# sample Perl code by a currently-unknown author. Credit will be placed here
|
||
# once the name is determined.
|
||
$COMPILE{pcdsize} = __LINE__ . <<'END_OF_SUB';
|
||
sub pcdsize {
|
||
my $stream = shift;
|
||
|
||
my ($x, $y, $id) = (undef, undef, "Unable to determine size of PCD data");
|
||
my $buffer = &$read_in($stream, 0xf00);
|
||
|
||
# Second-tier sanity check
|
||
return ($x, $y, $id) unless (substr($buffer, 0x800, 3) eq 'PCD');
|
||
|
||
my $orient = ord(substr($buffer, 0x0e02, 1)) & 1; # Clear down to one bit
|
||
($x, $y) = @{$GT::Image::Size::PCD_MAP{lc $GT::Image::Size::PCD_SCALE}}
|
||
[($orient ? (0, 1) : (1, 0))];
|
||
|
||
return ($x, $y, 'PCD');
|
||
}
|
||
END_OF_SUB
|
||
|
||
1;
|
||
|
||
__END__
|
||
|
||
=head1 NAME
|
||
|
||
GT::Image::Size - read the dimensions of an image in several popular formats
|
||
|
||
=head1 SYNOPSIS
|
||
|
||
use GT::Image::Size;
|
||
# Get the size of globe.gif
|
||
($globe_x, $globe_y) = imgsize("globe.gif");
|
||
# Assume X=60 and Y=40 for remaining examples
|
||
|
||
use GT::Image::Size 'html_imgsize';
|
||
# Get the size as 'width="X" height="Y"' for HTML generation
|
||
$size = html_imgsize("globe.gif");
|
||
# $size == 'width="60" height="40"'
|
||
|
||
use GT::Image::Size 'attr_imgsize';
|
||
# Get the size as a list passable to routines in CGI.pm
|
||
@attrs = attr_imgsize("globe.gif");
|
||
# @attrs == ('-width', 60, '-height', 40)
|
||
|
||
use GT::Image::Size;
|
||
# Get the size of an in-memory buffer
|
||
($buf_x, $buf_y) = imgsize(\$buf);
|
||
# Assuming that $buf was the data, imgsize() needed a reference to a scalar
|
||
|
||
=head1 DESCRIPTION
|
||
|
||
The B<GT::Image::Size> library is based upon the C<wwwis> script written by
|
||
Alex Knowles I<(alex@ed.ac.uk)>, a tool to examine HTML and add 'width' and
|
||
'height' parameters to image tags. The sizes are cached internally based on
|
||
file name, so multiple calls on the same file name (such as images used
|
||
in bulleted lists, for example) do not result in repeated computations.
|
||
|
||
B<GT::Image::Size> provides three interfaces for possible import:
|
||
|
||
=over
|
||
|
||
=item imgsize(I<stream>)
|
||
|
||
Returns a three-item list of the X and Y dimensions (width and height, in
|
||
that order) and image type of I<stream>. Errors are noted by undefined
|
||
(B<undef>) values for the first two elements, and an error string in the third.
|
||
The third element can be (and usually is) ignored, but is useful when
|
||
sizing data whose type is unknown.
|
||
|
||
=item html_imgsize(I<stream>)
|
||
|
||
Returns the width and height (X and Y) of I<stream> pre-formatted as a single
|
||
string C<'width="X" height="Y"'> suitable for addition into generated HTML IMG
|
||
tags. If the underlying call to C<imgsize> fails, B<undef> is returned. The
|
||
format returned is dually suited to both HTML and XHTML.
|
||
|
||
=item attr_imgsize(I<stream>)
|
||
|
||
Returns the width and height of I<stream> as part of a 4-element list useful
|
||
for routines that use hash tables for the manipulation of named parameters,
|
||
such as the Tk or CGI libraries. A typical return value looks like
|
||
C<("-width", X, "-height", Y)>. If the underlying call to C<imgsize> fails,
|
||
B<undef> is returned.
|
||
|
||
=back
|
||
|
||
By default, only C<imgsize()> is exported. Any one or combination of the three
|
||
may be explicitly imported, or all three may be with the tag B<:all>.
|
||
|
||
=head2 Input Types
|
||
|
||
The sort of data passed as I<stream> can be one of three forms:
|
||
|
||
=over
|
||
|
||
=item string
|
||
|
||
If an ordinary scalar (string) is passed, it is assumed to be a file name
|
||
(either absolute or relative to the current working directory of the
|
||
process) and is searched for and opened (if found) as the source of data.
|
||
Possible error messages (see DIAGNOSTICS below) may include file-access
|
||
problems.
|
||
|
||
=item scalar reference
|
||
|
||
If the passed-in stream is a scalar reference, it is interpreted as pointing
|
||
to an in-memory buffer containing the image data.
|
||
|
||
# Assume that &read_data gets data somewhere (WWW, etc.)
|
||
$img = &read_data;
|
||
($x, $y, $id) = imgsize(\$img);
|
||
# $x and $y are dimensions, $id is the type of the image
|
||
|
||
=item Open file handle
|
||
|
||
The third option is to pass in an open filehandle (such as an object of
|
||
the C<IO::File> class, for example) that has already been associated with
|
||
the target image file. The file pointer will necessarily move, but will be
|
||
restored to its original position before subroutine end.
|
||
|
||
# $fh was passed in, is IO::File reference:
|
||
($x, $y, $id) = imgsize($fh);
|
||
# Same as calling with filename, but more abstract.
|
||
|
||
=back
|
||
|
||
=head2 Recognized Formats
|
||
|
||
GT::Image::Size natively understands and sizes data in the following formats:
|
||
|
||
=over 4
|
||
|
||
=item GIF
|
||
|
||
=item JPG
|
||
|
||
=item XBM
|
||
|
||
=item XPM
|
||
|
||
=item PPM family (PPM/PGM/PBM)
|
||
|
||
=item XV thumbnails
|
||
|
||
=item PNG
|
||
|
||
=item MNG
|
||
|
||
=item TIF
|
||
|
||
=item BMP
|
||
|
||
=item PSD (Adobe PhotoShop)
|
||
|
||
=item SWF (ShockWave/Flash)
|
||
|
||
=item PCD (Kodak PhotoCD, see notes below)
|
||
|
||
=back
|
||
|
||
Additionally, if the B<Image::Magick> module is present, the file types
|
||
supported by it are also supported by GT::Image::Size. See also L<"CAVEATS">.
|
||
|
||
When using the C<imgsize> interface, there is a third, unused value returned
|
||
if the programmer wishes to save and examine it. This value is the identity of
|
||
the data type, expressed as a 2-3 letter abbreviation as listed above. This is
|
||
useful when operating on open file handles or in-memory data, where the type
|
||
is as unknown as the size. The two support routines ignore this third return
|
||
value, so those wishing to use it must use the base C<imgsize> routine.
|
||
|
||
Note that when the B<Image::Magick> fallback is used (for all non-natively
|
||
supported files), the data type identity comes directly from the 'format'
|
||
parameter reported by B<Image::Magick>, so it may not meet the 2-3 letter
|
||
abbreviation format. For example, a WBMP file might be reported as
|
||
'Wireless Bitmap (level 0) image' in this case.
|
||
|
||
=head2 Information Cacheing and C<$NO_CACHE>
|
||
|
||
When a filename is passed to any of the sizing routines, the default behavior
|
||
of the library is to cache the resulting information. The modification-time of
|
||
the file is also recorded, to determine whether the cache should be purged and
|
||
updated. This was originally added due to the fact that a number of CGI
|
||
applications were using this library to generate attributes for pages that
|
||
often used the same graphical element many times over.
|
||
|
||
However, the cacheing can lead to problems when the files are generated
|
||
dynamically, at a rate that exceeds the resolution of the modification-time
|
||
value on the filesystem. Thus, the optionally-importable control variable
|
||
C<$NO_CACHE> has been introduced. If this value is anything that evaluates to a
|
||
non-false value (be that the value 1, any non-null string, etc.) then the
|
||
cacheing is disabled until such time as the program re-enables it by setting
|
||
the value to false.
|
||
|
||
The parameter C<$NO_CACHE> may be imported as with the B<imgsize> routine, and
|
||
is also imported when using the import tag B<C<:all>>. If the programmer
|
||
chooses not to import it, it is still accessible by the fully-qualified package
|
||
name, B<$GT::Image::Size::NO_CACHE>.
|
||
|
||
=head2 Sizing PhotoCD Images
|
||
|
||
With version 2.95, support for the Kodak PhotoCD image format is
|
||
included. However, these image files are not quite like the others. One file
|
||
is the source of the image in any of a range of pre-set resolutions (all with
|
||
the same aspect ratio). Supporting this here is tricky, since there is nothing
|
||
inherent in the file to limit it to a specific resolution.
|
||
|
||
The library addresses this by using a scale mapping, and requiring the user
|
||
(you) to specify which scale is preferred for return. Like the C<$NO_CACHE>
|
||
setting described earlier, this is an importable scalar variable that may be
|
||
used within the application that uses B<GT::Image::Size>. This parameter is called
|
||
C<$PCD_SCALE>, and is imported by the same name. It, too, is also imported
|
||
when using the tag B<C<:all>> or may be referenced as
|
||
B<$GT::Image::Size::PCD_SCALE>.
|
||
|
||
The parameter should be set to one of the following values:
|
||
|
||
base/16
|
||
base/4
|
||
base
|
||
base4
|
||
base16
|
||
base64
|
||
|
||
Note that not all PhotoCD disks will have included the C<base64>
|
||
resolution. The actual resolutions are not listed here, as they are constant
|
||
and can be found in any documentation on the PCD format. The value of
|
||
C<$PCD_SCALE> is treated in a case-insensitive manner, so C<base> is the same
|
||
as C<Base> or C<BaSe>. The default scale is set to C<base>.
|
||
|
||
Also note that the library makes no effort to read enough of the PCD file to
|
||
verify that the requested resolution is available. The point of this library
|
||
is to read as little as necessary so as to operate efficiently. Thus, the only
|
||
real difference to be found is in whether the orientation of the image is
|
||
portrait or landscape. That is in fact all that the library extracts from the
|
||
image file.
|
||
|
||
=head1 DIAGNOSTICS
|
||
|
||
The base routine, C<imgsize>, returns B<undef> as the first value in its list
|
||
when an error has occured. The third element contains a descriptive
|
||
error message.
|
||
|
||
The other two routines simply return B<undef> in the case of error.
|
||
|
||
=head1 MORE EXAMPLES
|
||
|
||
The B<attr_imgsize> interface is also well-suited to use with the Tk
|
||
extension:
|
||
|
||
$image = $widget->Photo(-file => $img_path, attr_imgsize($img_path));
|
||
|
||
Since the C<Tk::Image> classes use dashed option names as C<CGI> does, no
|
||
further translation is needed.
|
||
|
||
This package is also well-suited for use within an Apache web server context.
|
||
File sizes are cached upon read (with a check against the modified time of
|
||
the file, in case of changes), a useful feature for a B<mod_perl> environment
|
||
in which a child process endures beyond the lifetime of a single request.
|
||
Other aspects of the B<mod_perl> environment cooperate nicely with this
|
||
module, such as the ability to use a sub-request to fetch the full pathname
|
||
for a file within the server space. This complements the HTML generation
|
||
capabilities of the B<CGI> module, in which C<CGI::img> wants a URL but
|
||
C<attr_imgsize> needs a file path:
|
||
|
||
# Assume $Q is an object of class CGI, $r is an Apache request object.
|
||
# $imgpath is a URL for something like "/img/redball.gif".
|
||
$r->print($Q->img({ -src => $imgpath,
|
||
attr_imgsize($r->lookup_uri($imgpath)->filename) }));
|
||
|
||
The advantage here, besides not having to hard-code the server document root,
|
||
is that Apache passes the sub-request through the usual request lifecycle,
|
||
including any stages that would re-write the URL or otherwise modify it.
|
||
|
||
=head1 CAVEATS
|
||
|
||
Caching of size data can only be done on inputs that are file names. Open
|
||
file handles and scalar references cannot be reliably transformed into a
|
||
unique key for the table of cache data. Buffers could be cached using the
|
||
MD5 module, and perhaps in the future I will make that an option. I do not,
|
||
however, wish to lengthen the dependancy list by another item at this time.
|
||
|
||
As B<Image::Magick> operates on file names, not handles, the use of it is
|
||
restricted to cases where the input to C<imgsize> is provided as file name.
|
||
|
||
=head1 SEE ALSO
|
||
|
||
C<http://www.tardis.ed.ac.uk/~ark/wwwis/> for a description of C<wwwis>
|
||
and how to obtain it, L<Image::Magick>.
|
||
|
||
=head1 AUTHORS
|
||
|
||
Perl module interface by Randy J. Ray I<(rjray@blackperl.com)>, original
|
||
image-sizing code by Alex Knowles I<(alex@ed.ac.uk)> and Andrew Tong
|
||
I<(werdna@ugcs.caltech.edu)>, used with their joint permission.
|
||
|
||
Some bug fixes submitted by Bernd Leibing I<(bernd.leibing@rz.uni-ulm.de)>.
|
||
PPM/PGM/PBM sizing code contributed by Carsten Dominik
|
||
I<(dominik@strw.LeidenUniv.nl)>. Tom Metro I<(tmetro@vl.com)> re-wrote the JPG
|
||
and PNG code, and also provided a PNG image for the test suite. Dan Klein
|
||
I<(dvk@lonewolf.com)> contributed a re-write of the GIF code. Cloyce Spradling
|
||
I<(cloyce@headgear.org)> contributed TIFF sizing code and test images. Aldo
|
||
Calpini I<(a.calpini@romagiubileo.it)> suggested support of BMP images (which
|
||
I I<really> should have already thought of :-) and provided code to work
|
||
with. A patch to allow html_imgsize to produce valid output for XHTML, as
|
||
well as some documentation fixes was provided by Charles Levert
|
||
I<(charles@comm.polymtl.ca)>. The ShockWave/Flash support was provided by
|
||
Dmitry Dorofeev I<(dima@yasp.com)>. Though I neglected to take note of who
|
||
supplied the PSD (PhotoShop) code, a bug was identified by Alex Weslowski
|
||
<aweslowski@rpinteractive.com>, who also provided a test image. PCD support
|
||
was adapted from a script made available by Phil Greenspun, as guided to my
|
||
attention by Matt Mueller I<mueller@wetafx.co.nz>. A thorough read of the
|
||
documentation and source by Philip Newton I<Philip.Newton@datenrevision.de>
|
||
found several typos and a small buglet. Ville Skytt<74> I<(ville.skytta@iki.fi)>
|
||
provided the MNG and the Image::Magick fallback code.
|
||
|
||
=cut
|