Mkphotohtml Ver.2.0 (BIN)
山田邦博です。
Mkphothhtml Version 2 の投稿です。
-...-
本投稿は 4部に分けて投稿します。
ANN (Announce)
DOC (Document: README)(1000行弱)
BIN (この投稿)
ETC (Etc: 日本語と英語のメッセージファイル)
-...-
Mkphotohtml Ver.2.0 の全てのファイルは
ftp://ftp.tksa.gr.jp/king/image/Mkphotohtml_2.0.tgz
にあります。
これには本投稿にはない、インストーラ、小さな関連プログラム(便利グッズ)、
設定例、細かいドキュメントが含まれています。
最新の Mkphotohtml (ドキュメントを含む)については
http://www.tksa.gr.jp/king/Software/Mkphotohtml/index.html
を参照して下さい。
そこに実例も示しておきました。
=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
#!/bin/sh
# This is a shell archive (produced by GNU sharutils 4.2.1).
# To extract the files from this archive, save it to some FILE, remove
# everything before the `!/bin/sh' line above, then type `sh FILE'.
#
# Made on 2003-11-11 17:48 JST by <king@owlin>.
# Source directory was `/home/king/src/image/Mkphotohtml_2.0/bin'.
#
# Existing files will *not* be overwritten unless `-c' is specified.
#
# This shar contains:
# length mode name
# ------ ---------- ------------------------------------------
# 68563 -rwxr-xr-x mkphotohtml
#
save_IFS="${IFS}"
IFS="${IFS}:"
gettext_dir=FAILED
locale_dir=FAILED
first_param="$1"
for dir in $PATH
do
if test "$gettext_dir" = FAILED && test -f $dir/gettext \
&& ($dir/gettext --version >/dev/null 2>&1)
then
set `$dir/gettext --version 2>&1`
if test "$3" = GNU
then
gettext_dir=$dir
fi
fi
if test "$locale_dir" = FAILED && test -f $dir/shar \
&& ($dir/shar --print-text-domain-dir >/dev/null 2>&1)
then
locale_dir=`$dir/shar --print-text-domain-dir`
fi
done
IFS="$save_IFS"
if test "$locale_dir" = FAILED || test "$gettext_dir" = FAILED
then
echo=echo
else
TEXTDOMAINDIR=$locale_dir
export TEXTDOMAINDIR
TEXTDOMAIN=sharutils
export TEXTDOMAIN
echo="$gettext_dir/gettext -s"
fi
if touch -am -t 200112312359.59 $$.touch >/dev/null 2>&1 && test ! -f 200112312359.59 -a -f $$.touch; then
shar_touch='touch -am -t $1$2$3$4$5$6.$7 "$8"'
elif touch -am 123123592001.59 $$.touch >/dev/null 2>&1 && test ! -f 123123592001.59 -a ! -f 123123592001.5 -a -f $$.touch; then
shar_touch='touch -am $3$4$5$6$1$2.$7 "$8"'
elif touch -am 1231235901 $$.touch >/dev/null 2>&1 && test ! -f 1231235901 -a -f $$.touch; then
shar_touch='touch -am $3$4$5$6$2 "$8"'
else
shar_touch=:
echo
$echo 'WARNING: not restoring timestamps. Consider getting and'
$echo "installing GNU \`touch', distributed in GNU File Utilities..."
echo
fi
rm -f 200112312359.59 123123592001.59 123123592001.5 1231235901 $$.touch
#
if mkdir _sh01288; then
$echo 'x -' 'creating lock directory'
else
$echo 'failed to create lock directory'
exit 1
fi
# ============= mkphotohtml ==============
if test -f 'mkphotohtml' && test "$first_param" != -c; then
$echo 'x -' SKIPPING 'mkphotohtml' '(file already exists)'
else
$echo 'x -' extracting 'mkphotohtml' '(text)'
sed 's/^X//' << 'SHAR_EOF' > 'mkphotohtml' &&
#! /usr/bin/perl -w
X
# mkphotohtml : Make photo.html
#
X
# Author:
# YAMADA Kunihiro <king@tksa.gr.jp>
# (http://www.tksa.gr.jp/king/)
#
# Copyright policy:
# GNU GPL Ver.2
#
X
# Usage:
# mkphtohtml [option] [directories ...]
# Options:
# -b : Back button added to photo.html (Default: Not added)
# -c : Clean bogus shrinked images
# -C characterset : Specify charset to characterset for Contents.conf
# -D : Debug
# -e string : add string as epilog to photo.html
# -f : Force update
# -h : Help
# -l lang : Set laguage to lang for messages of photo.html
# -m mailaddress :
# Mail address like as 'yourid@your.domain'
# -o : Default theme options for Contents.conf:
# There are many sub options.
# The format is "Sub-Option=value,...."
# Type "mkphothtml -h: for detail theme options,
# or read README.jp.txt for more detail
# -p string : add string as prolog to photo.html
# -r : Recursive
# -s : Suppress start page infomation in HTML header
# -t url :
# address or URL of Top page for start
# -u Username :
# Full name of user like as "Firstname Lastname"
# -v : Verbose messages
# -w : check web page
#
# Directories:
# Directory list of the themes. (Default : current directory(.))
#
X
# Documents:
# Following documents are available;
# BUGS.jp.txt
# Change.log
# Format.txt
# INSTALL.jp.txt
# MUMBLE.jp.txt
# README.jp.txt (Japanese text only, sorry)
#
X
# Latest version:
# You can get the latest version and it's documents from
# my web page;
# http://www.tksa.gr.jp/king/Software/Mkphothtml/
#
X
# History:
# (Please see other document "Change.log" for detail.)
# 28 Dec.2000 starting Ver.0.0
# 11 Apr.2001 Ver.0.0
# 9 Jun.2003 starting Ver.1.0
# 21 Jun.2003 rewritten almost
# 22 Jul.2003 Ver.1.0-pre.1 : Released
# 29 Jul.2003 Ver.1.0 : Released
# 2 Aug.2003 Ver.1.0-patch.01 : Released
# 12 Sep.2003 Ver.1.1 : Released
# 8 Oct.2003 Ver.2.0-pre.02 : Released
# 11 Oct.2003 Ver.2.0-pre.03 : Released
# 18 Oct.2003 Ver.2.0-pre.04 : Released
# 11 Nov.2003 ver.2.0 : Released
#
X
no lib qw(:ALL .);
use strict qw(vars subs refs);
use Getopt::Std;
use Cwd;
use File::Basename;
use File::stat;
use Time::localtime;
use HTTP::Date;
use LWP::Simple;
use IPC::Open2;
use Net::Domain qw(hostfqdn hostdomain);
use Image::Size 'html_imgsize';
use Unicode::MapUTF8 qw(to_utf8 utf8_supported_charset);
use vars qw($opt_b $opt_c $opt_C $opt_D $opt_e $opt_f $opt_h $opt_l $opt_m
X $opt_o $opt_p $opt_r $opt_s $opt_t $opt_u $opt_v $opt_w);
X
die "$0 : \"Root user or group\" is prohibitted, sorry.\n"
X if $< == 0 or $> == 0 or $( == 0 or $) == 0; # uid,euid,gid,egid : root?
X
#######################################
### Please configure for your needs ###
#######################################
X
umask 022;
my $DMODE = 0755; # Permission for directory
my $CONFIG = "Contents.conf"; # Configure file for contents
my $CONTENT = "Contents.db"; # Contents file (generated)
my $HTML = "photo.html"; # HTML file (generated)
my $IMGEXT = "jpeg|JPEG|jpg|JPG"; # Extention of Image file
my $ORIG = "ORIG"; # Extention of Original image file
my $PREHTTP = ".http."; # Prefix of web theme file
my $SLASHHTTP = "%"; # Replace slashes of url for web theme file
X
## program path ##
my $DJPEG = "/usr/bin/djpeg"; # decompress a JPEG file to an image file
my $CJPEG = "/usr/bin/cjpeg"; # compress an image file to a JPEG file
my $JPEGTOPNM = "/usr/bin/jpegtopnm -quiet";
X # convert JFIF file to portable pixmap
my $PNMSCALE = "/usr/bin/pnmscale"; # scale a PNM image
my $PNMTOJPEG = "/usr/bin/pnmtojpeg"; # convert PNM image to a JFIF image
X
## Limit for web
my $MAXWEBDOCLENGTH = 1000000; # Maximum allowed size for web page
X
## default for option -o ##
## These options can be changed by option -o or system and user option file,
## and can be overlayed temporaly by $CONFIG file on each theme directory.
## Caution: These default options are not checked these validity,
## so take care when you change these default values!
## System wide options (/etc/mkphotohtml/option) are recommended.
##
$::opt_charset = "iso-2022-jp"; # charset for Contents.conf file
X # UTF-8 if ""
$::opt_lang = "Japanese"; # Language for message
$::opt_order = "New-First"; # , New-Last, Theme-First or Image-First
$::opt_image = "Reverse"; # or Normal
$::opt_theme = "Reverse"; # or Normal
$::opt_config = "Non"; # , First or Last
$::opt_mail = '$userid@$domain'; # your mail address
$::opt_uname = '$passwd'; # your name like as "First Middle Last"
$::opt_scale = "(1/1=:raw)(1/2=:shrink)(1/4=:shrink)(1/8=:shrink)";
X # Scale and Directory name for raw and shrinked pictures
$::opt_size = "(Normal=1/2)(Header=1/4)(Index=1/8)";
X # Size of Picture for Normal, Header and Indicies display
$::opt_back = "No"; # or Yes (Back button added to photo.html)
$::opt_start = "Yes"; # or No (start page added in HTML header)
$::opt_top = "/index.html"; # link to Top page or URL
$::opt_ckweb = "No"; # or Yes (Check Web theme page)
$::opt_refer = "Deny"; # or Allow (refer for photo album)
$::opt_prolog = '$copyright: $uname <$Mail>';
X # Any string for prolog clause
X # $copyrigh := $html_message{$::opt_lang}->{Copyright}
X # $uname := $::opt_uname
X # $Mail := $::opt_mail
$::opt_epilog = ""; # Any string for epilog clause
X
#############################
### End of Configuration ###
#############################
X
X
### Constants ###
my $VERSION = "2.0";
my $WEBINFO = "http://www.tksa.gr.jp/king/Software/Mkphothtml/";
X
my $PFIRST = "[-_]?(?:First|1st|Fir)";
my $PLAST = "[-_]?Last?";
my $PTHEME = "The(?:m[ea]?)?";
my $PDIR = "Dir(?:ectory)?";
my $PIMAGE = "Ima(?:ge)?";
my $PNAME = basename $0;
my $LPNAME = "\L$PNAME\E";
my $UPNAME = "\U$PNAME\E";
my $SYSCONFDIR = "/etc/$LPNAME";
my $USERCONFDIR = "$ENV{HOME}/etc/$LPNAME";
X
### Global valiables ###
my $picrawdir; # Directory name for raw images
my %scale_dir; # Scale-Directory
my %picheader; # Picture(Header,Index,Norml)-Scale
my %shrink_name; # shrink name(extention) inserted into image file name
my @sorted_scale; # Sorted scale of Pictures
my %version_checked;
my %html_message; # messages for html with multi lingual.
X # $html_message{$::opt_lang}->{Item}
X
my ($CLEAN,$DEBUG,$FORCEUPDATE,$HELP,$RECURSIVE,$VERBOSE);
X
getopts('bcC:De:fhl:m:op::rst:u:vw');
$CLEAN = $opt_c;
$DEBUG = $opt_D;
$FORCEUPDATE = $opt_f;
$HELP = $opt_h;
$RECURSIVE = $opt_r;
$VERBOSE = $opt_v;
X
sub set_option_from_file ( $;$ );
sub set_option ( $$;$ );
sub set_messages ( $ );
sub check_version ( $$;$ );
sub makephoto ( @ );
sub set_charset ( $ );
sub sanitize_meta ( $;$ );
X
X
if (-r "/etc/$PNAME/option") {
X set_option_from_file("/etc/$PNAME/option"); # System wide options
X warn <<EOF if $VERBOSE;
System wide option file "/etc/$PNAME/option" is read.
X Default theme-options are override.
EOF
}
X
if (-r "$USERCONFDIR/option") {
X set_option_from_file("$USERCONFDIR/option"); # User options
X warn <<EOF if $VERBOSE;
User theme options are set by "$USERCONFDIR/option".
X Default theme-options are override.
EOF
}
X
X
if ($HELP) {
X my @langs;
X foreach my $f (glob "/etc/$PNAME/message.* $USERCONFDIR/message.*") {
X next unless $f =~ m!/message\.(\w+)$!;
X next unless -r $f;
X my $lang = "\u$1";
X push @langs,$lang unless grep($_ eq $lang, @langs);
X }
X my $langs = join(',', sort(@langs));
X
X print <<EOF;
X
This is Mkphotohtml version $VERSION
X
Copyright 2001-2003, YAMADA Kunihiro <king\@tksa.gr.jp>
X
You can get the latest version from
\t$WEBINFO
X
X
Usage: $PNAME [option] [directories ...]
X
Options:
X -b : Back button added to photo.html
X (same as -o Back=Yes)
X -c : Clean up bogus shrinked images
X -C characterset :
X Specify charset to characterset for Contents.conf
X (same as -o Charset=characterset)
X -D : Debug
X -e string :
X add string as epilog to photo.html
X -f : Force update
X -h : Help
X -l lang :
X Set laguage to lang for messages of photo.html
X (same as -o Language=lang)
X -m mailaddress :
X Mail address like as 'yourid\@your.domain'
X (same as -o Mail-Address=yourid\@your.domain)
X -o : Default theme options for $CONFIG:
X Charset=characterset
X Language=any-language (Default : $::opt_lang)
X Note: You can specify any language if you prepared a proper
X message file.
X Order=New-First|New-Last|Theme-First|Image-First (Default : $::opt_order)
X Image=Reverse|Normal (Default : $::opt_image)
X Theme=Reverse|Normal (Default : $::opt_theme)
X Config=Non|First|Last (Default : $::opt_config)
X Mail-Address=yourid\@your.domain (Default : $::opt_mail)
X User-Name="FirstName LastName" (Default : $::opt_uname)
X Scale-Directory=(scale1=directory1)(scale2=directory2)....
X (Scale and Directory name for raw and shrinked pictures)
X Default : $::opt_scale
X Size-of-Picture=(display1=scale1)(display2=scale2)....
X (Size of Picture for Normal, Header and Indices display)
X Default : $::opt_size
X Back=No|Yes (Default : No)
X Start=Yes|No (Default : Yes)
X Top=url of top page (Default : /index.html)
X Check-Web=No|Yes (Default : No)
X Refer=Deny|Allow (Default : Deny)
X Prologue=any-string (Default : "$::opt_prolog")
X Epilogue=any-string (Defualt : "$::opt_epilog")
X -p string :
X add string as prolog to photo.html
X -r : Recursive
X -s : Suppress start page infomation in HTML header
X (Same as -o Start=No)
X -t url :
X address or URL of Top page for start
X (same as -o Top=url)
X -u username :
X Full name of user like as "Firstname Lastname"
X (same as -o "User-Name=Firstname Lastname")
X -v : Verbose messages
X -w : check web page
X (same as -o Check-Web=Yes)
X
Directories:
X Directory list of the themes. (Default : current directory(.))
X
Current usable languages by system and user defaults are
\t$langs.
X
EOF
X exit 0;
}
X
X
if (exists $ENV{$UPNAME}) {
X foreach (split m/,/,$ENV{$UPNAME}) {
X set_option("ENV",$_); # Options from Enviroment
X warn <<EOF if $VERBOSE;
Theme options are set by the environment "$UPNAME".
X Default theme-options are override.
EOF
X }
}
X
$::opt_charset = $opt_C if $opt_C;
{
X my $erm = set_charset($::opt_charset);
X if ($erm) {
X die <<EOF;
Bad command option: "-C $::opt_charset"
\t$erm
EOF
X }
}
X
set_option("sh","Language=$opt_l") if $opt_l; # Default language for message
$::opt_back = "Yes" if $opt_b; # Back button
$::opt_mail = $opt_m if $opt_m; # Mail address
if ($opt_m) {
X die <<EOF unless $opt_m =~ /\@/;
Bad command option: "-m $opt_m" : should be included "\@".
EOF
}
X
set_option("sh","Prolog=$opt_p") if $opt_p; # Add prolog clause to photo.html
set_option("sh","Epilog=$opt_e") if $opt_e; # Add epilog clause to photo.html
$::opt_start = "No" if $opt_s; # Start page info. into HTML header
$::opt_top = $opt_t if $opt_t; # address or URL of Top page
set_option("sh","User-Name=$opt_u") if $opt_u; #User Name
$::opt_ckweb = "Yes" if $opt_w; # check web theme page
if ($opt_o) { # Option -o (from sh command)
X foreach (split m/,/,$opt_o) {
X set_option("sh",$_);
X }
X warn <<EOF if $VERBOSE;
Theme options are set by the shell command option "-o".
X Default theme-options are override.
EOF
}
X
set_option("Default","Language=$::opt_lang"); # make sure while no option
X
unshift @ARGV, "." unless @ARGV; # add default directory to current
X
makephoto(@ARGV);
Xexit 0;
X
######################################################################
X
sub is_utf8 ( $ ) {
X my $s = shift;
X while ($s =~ s/^(.)//s) {
X return 0 if $1 eq "\e"; # JIS or other charset with ESC
X my $c = ord($1);
X next unless $c & 0x80; # ASCII
X my $n;
X if (($c & 0xe0) == 0xc0) {
X $n = 2;
X } elsif (($c & 0xf0) == 0xe0) {
X $n = 3;
X } elsif (($c & 0xf8) == 0xf0) {
X $n = 4;
X } elsif (($c & 0xfc) == 0xf8) {
X $n = 5;
X } elsif (($c & 0xfe) == 0xfc) {
X $n = 6;
X } else {
X return 0;
X }
X for (my $i=2; $i<=$n; ++$i) {
X $s =~ s/^(.)//s;
X return 0 unless (ord($1) & 0xc0) == 0x80;
X }
X }
X return 1;
}
X
sub get_config ( \*$ ) {
X my ($in,$f) = @_;
X local (*FH) = $$in;
X local ($_);
X return "" if eof(FH);
X while (<FH>) {
X $::ILN = $.;
X chomp;
# print "#",__LINE__,"# $.: \"$_\"\n" if $DEBUG;
X next if /^\s*$/; # Null line
X my $sv = $_;
X $_ = to_utf8({ -string => $_, -charset => $::opt_charset })
X if $::opt_charset;
X next if /^\s*\#/; # line with only comment
# print "#",__LINE__,"# ",($sv eq $_ ? "SAME" : "DIFF"),"\n" if $DEBUG;
X s/^\s+/\t/; # replace preceding spaces with single tab
X s/\s+$//; # remove trailing spaces
X s/\s+\#.*//; # remove comment part
# print "#",__LINE__,"# Charset=($::opt_charset) # $.: ($_)\n" if $DEBUG;
X if (is_utf8($_)) {
X return $_;
X } else {
X my $erm;
X if ($::opt_charset) {
X $erm = "Can't convert charset from $::opt_charset to UTF-8";
X } else {
X $erm = "Non UTF-8 character found";
X }
X $f = cwd() . "/$f" unless $f =~ m(^/);
X die "$erm\n\tat \"$f\" line $.\n";
X }
X }
X return "";
}
X
sub set_charset ( $ ) {
X $::opt_charset = shift;
X $::opt_charset = "" unless $::opt_charset;
X return undef unless $::opt_charset;
X if ($::opt_charset =~ /^utf[-_]?8$|^(us[-_]?)?ascii$/i) {
X $::opt_charset = ""; # Default setting
X return undef;
X }
X $::opt_charset = "jis" if $::opt_charset =~ /^iso-2022-jp$/i;
X # avoid bug?
X # to_utf can't convert properly from iso-2022-jp
X return undef if utf8_supported_charset($::opt_charset);
X return "Charset \"$::opt_charset\" is not supported.";
}
X
sub check_scale ( $ ) {
X my $scale = shift;
X my $v = 0;
X my $mes;
X if ($scale =~ /^(\d+)$/) {
X $v = $1;
X } elsif ($scale =~ /^(\d*)\.(\d*)$/) {
X $v = (($1 or $2) ? $scale + 0 : 0);
X } elsif ($scale =~ m!^(\d+)/(\d+)$!) {
X if ($2) {
X $v = $1 / $2;
X } else {
X $mes = "Bad scale value($scale) : cannot divide by 0.";
X }
X } else {
X $mes = "Bad scale format \"$scale\".";
X }
X if (not $mes and ($v > 1 or $v ==0)) {
X $mes = "Bad scale value($v): should be >0 and <=1.";
X }
X return ($v,$mes);
}
X
sub set_option_from_file ( $;$ ) {
X my $file = shift;
X my $only_scale_size = shift;
# my $save_ILN = $::ILN;
X local $::ILN;
X local $_;
X print "#",__LINE__,"# set_option_from_file, (",cwd,")($file) ",($only_scale_size?"ONLY":"ALL"),"\n" if $DEBUG;
X open(INF,"<$file") || die "Cannot open file $file : $!";
X my $from = "conf";
X $from = "db" if $file =~ /$CONTENT$/;
X $from = "$file" if $file =~ m!/!;
X OUTER:
X while ($_ = get_config(*INF,$file)) {
X if (/^Ver(sion)?:/i) {
X if ($_ = get_config(*INF,$file)) {
X check_version($file,$_);
X }
X } elsif (/^Opt(ion)?:$/i) {
X while ($_ = get_config(*INF,$file)) {
X last OUTER if /^\S/;
X unless ($only_scale_size) {
X if (s/^\s+(Pro|Epi)(?:log|logue)?\s*=\s*//i) {
X my $pt = ($1 =~ /Pro/i ? \$::opt_prolog : \$::opt_epilog);
X print "#",__LINE__,"# SETOPTF: ProEpi ($_)\n" if $DEBUG;
X $$pt = $_;
X while ($_ = get_config(*INF,$file)) {
X print "#",__LINE__,"# SETOPTF: ProEpi ($_)\n" if $DEBUG;
X last if /^\S|^\s+[\w\.-]+\s*=/;
X s/^\s+//;
X $$pt .= "\n\t\t $_";
X }
X redo;
X }
X }
X set_option($from,$_,$only_scale_size);
X }
X }
X }
X close(INF);
# $::ILN = $save_ILN;
}
X
sub set_option ( $$;$ ) {
X my $from = shift;
X local $_ = shift;
X my $only_scale_size = shift;
X print "#",__LINE__,"# set_option from='$from' \$_='$_'\n" if $DEBUG;
X s/^\s+//;
X s/\s+$//;
X my $errmes;
X if ($from eq "conf") {
X $errmes = "Error at " . cwd() . "/$CONFIG line $::ILN :";
X } elsif ($from eq "db") {
X $errmes = "Error at " . cwd() . "/$CONTENT line $::ILN :";
X } elsif ($from eq "sh") {
X $errmes = "Error in \"-o option\" on shell command:";
X } elsif ($from eq "ENV") {
X $errmes = "Error in Environment \"$UPNAME\":";
X } elsif ($from eq "Default") {
X $errmes = "Error while default setting:";
X } else { # Contents.db or mkphotohtml.conf
X $errmes = "Error at $from line $::ILN:";
X }
X
X if (s/Sca(le)?([-_]?($PDIR)?)?\s*=\s*//io) {
X s/\s+//g;
X $::opt_scale = $_;
X $::opt_size = ""; # option_size should be set later
X my %vlist;
X while (s/^\((.*?)\)//) {
X my $s = $1;
X unless ($s =~ /(.*)=(.*)/) {
X die <<EOF;
$errmes
\t"Scale-Directory=" should be formed as "(Scale=Directory)".
EOF
X }
X my ($scale,$dir) = ($1,$2);
X my ($v,$mes) = check_scale($1);
X die <<EOF if $mes;
$errmes
\t"Scale-Directory=" ($s)
\t\t$mes
EOF
X die <<EOF if exists $vlist{$v};
$errmes
\t"Scale-Directory=($s)" :
\t\tThe value($v) of the scale($scale) is doubly defined.
EOF
X $vlist{$v} = $dir;
X }
X die <<EOF if $_;
$errmes
\t"Scale-Directory=" : Bad format.
EOF
X die <<EOF unless exists $vlist{1};
$errmes
\t"Scale-Directory=" should be specified the raw image directory that
\t the value of scale is 1.
EOF
X my $c1 = substr($vlist{1},0,1); # 1st character of image directory name
X for my $v (keys %vlist) {
X my $cx = substr($vlist{$v},0,1);
X die <<EOF unless $c1 eq $cx;
$errmes
\t"Scale-Directory=$::opt_scale" :
\t First character of directory name should be same.
\t (First character of raw image directory is "$c1", but
\t the one of scale of $v is "$cx".)
EOF
X }
X } elsif (s/Size?([-_]?(of[-_]?)?Pic(ture)?)?\s*=\s*//i) {
X s/\s+//g;
X my ($h,$i,$n);
X while (s/^\(.+?\)//) {
X my $s = $&;
X if ($s =~ /\(\s*([^\s=]*)\s*=\s*([^\s\)]*)\s*\)/) {
X my $picture = $1;
X my $scale = $2;
X unless ($picture =~
X /^Nor(mal)?$|^N$|^Hea(der)?$|^H$|^Ind(ex)?$|^Indices$|^I$/i) {
X die <<EOF;
$errmes
\t"Size-of-Picture=" should be formed as "(Display=Scale)".
\t\t(Display=Scale)=($picture=$scale) : Bad Display specified.
\t\t\tDisplay is one of "Normal", "Header" and "Index".
EOF
X }
X die <<EOF unless $::opt_scale =~ /\($scale=/;
$errmes
\tOption: Size-of-Picture=($picture=$scale)
\t Scale($scale) not found on Scale-Directory.
EOF
X $h = $scale if $picture =~ /^H/i;
X $i = $scale if $picture =~ /^I/i;
X $n = $scale if $picture =~ /^N/i;
X }
X }
X die <<EOF if $_;
$errmes
\t"Size-of-Picture='$_'" : Bad format.
EOF
X die <<EOF unless $h and $i and $n;
$errmes
\t"Size-of-Picture=" should have Normal,Header and Index.
EOF
X $::opt_size = "(Normal=$n)(Header=$h)(Index=$i)";
# print "#",__LINE__,"# option_size='$::opt_size'\n" if $DEBUG;
X } elsif ($only_scale_size) { # truncate here if only scale size
X return;
X } elsif (s/^(Lan(guage)?|Lang)\s*=\s*//i) {
X $::opt_lang = "\L$_\E";
X unless (exists $html_message{$_}) {
X ### set default messages from files ###
X my $smfile = "$SYSCONFDIR/message.$::opt_lang";
X my $umfile = "$USERCONFDIR/message.$::opt_lang";
X set_messages($smfile) if -r $smfile;
X set_messages($umfile) if -r $umfile;
X die <<EOF unless -r $smfile or -r $umfile;
$errmes
\tLanguage "\u$::opt_lang" is not supported.
\tNo message file (message.$::opt_lang).
EOF
X }
X } elsif (s/^Ord(er)?\s*=\s*//i) {
X if (/^New$PFIRST$|^Old$PLAST$/io) {
X $::opt_order = "New-First";
X } elsif (/^New$PLAST$|^Old$PFIRST$/io) {
X $::opt_order = "New-Last";
X } elsif (/^$PTHEME$PFIRST$|^$PDIR$PFIRST$|^$PIMAGE$PLAST$/io) {
X $::opt_order = "Theme-First";
X } elsif (/^$PIMAGE$PFIRST$|^$PTHEME$PLAST$|^$PDIR$PLAST$/io) {
X $::opt_order = "Image-First";
X } else {
X die <<EOF;
$errmes
\t"Option: Order=" should be New-First (Old-Last)
\t or New_Last (New-First)
\t or Theme-First (Image-Last)
\t or Image-First (Theme-Last)
EOF
X }
X } elsif (s/$PIMAGE\s*=\s*//i) {
X if (/^Nor(mal)?$/i) {
X $::opt_image = "Normal";
X } elsif (/^Rev(erse)?$/i) {
X $::opt_image = "Reverse";
X } else {
X die <<EOF;
$errmes
\t"Option: Image=" should be "Normal" or "Reverse"
EOF
X }
X } elsif (s/($PTHEME|$PDIR)\s*=\s*//io) {
X if (/^Nor(mal)?$/i) {
X $::opt_theme = "Normal";
X } elsif (/^Rev(erse)?$/i) {
X $::opt_theme = "Reverse";
X } else {
X die <<EOF;
$errmes
\t"Option: Theme=" should be "Reverse" or "Normal"
EOF
X }
X } elsif (s/Con(fig)?\s*=\s*//i) {
X if (/^Non$/i) {
X $::opt_config = "Non";
X } elsif (/^(First|1st|Fir)$/i) {
X $::opt_config = "First";
X } elsif (/^Last?$/i) {
X $::opt_config = "Last";
X } else {
X die <<EOF;
$errmes
\t"Option: Config=" should be "Non" or "Normal" or "Reverse"
EOF
X }
X } elsif (s/^Cha(rset)?\s*=\s*//i) {
X my $erm = set_charset($_);
X die <<EOF if $erm;
$errmes
\t$erm
EOF
X } elsif (s/^Mail?([-_]?Add(ress)?)?\s*=\s*//i) {
X $::opt_mail = $_;
X die <<EOF unless not $_ or /\@/;
$errmes
\t"Option: Mail=$_" : should be included "\@".
EOF
X } elsif (s/^User?([-_]?Name?)?\s*=\s*//i) {
X $::opt_uname = $_; # Name of User
X } elsif (s/^Back?\s*=\s*//i) {
X if (/^Yes$|^Use$/i) {
X $::opt_back = "Yes";
X } elsif (/^No[nt]?$/i) {
X $::opt_back = "No";
X } else {
X die <<EOF;
$errmes
\t"Option: Back=" should be "Yes" or "No" ("Use" or "Non" can be used).
EOF
X }
X } elsif (s/^Sta(rt)?\s*=\s*//i) {
X if (/^Yes$|^Use$/i) {
X $::opt_start = "Yes";
X } elsif (/^No[nt]?$/i) {
X $::opt_start = "No";
X } else {
X die <<EOF;
$errmes
\t"Option: Start=" should be "Yes" or "No" ("Use" or "Non" can be used).
EOF
X }
X } elsif (s/^Top\s*=\s*//i) {
X $::opt_top = $_;
X } elsif (s/^Che(ck)?([-_]?Web)?\s*=\s*//i) {
X if (/^Yes$|^On$/i) {
X $::opt_ckweb = "Yes";
X } elsif (/^No$|^Off$/i) {
X $::opt_ckweb = "No";
X } else {
X die <<EOF
$errmes
\t"Option: Check-Web=" should be "Yes" or "No" ("On" or "Off" can be used).
EOF
X }
X } elsif (s/^Ref(er)?\s*=\s*//i) {
X if (/^All(ow)?$/i) {
X $::opt_refer = "Allow";
X } elsif (/^Deny?$/i) {
X $::opt_refer = "Deny";
X } else {
X die <<EOF;
$errmes
\t"Option: Refer=" should be "Allow" or "Deny".
EOF
X }
X } elsif (s/^(Pro|Epi)(?:log|logue)?\s*=\s*//i) {
X # from Command line option or Environment
X my $pe = $1;
X if ($pe =~ /Pro/i) {
X $::opt_prolog = $_;
X } else {
X $::opt_epilog = $_;
X }
X } elsif (/^$/) {
X # skip
X } else {
X die <<EOF;
$errmes
\tOption: "$_" is bad theme option.
EOF
X }
} # end of set_option
X
sub set_messages ( $ ) {
X my $msgfile = shift;
X $msgfile =~ s/^\s+//;
X $msgfile =~ s/\s+$//;
X return unless $msgfile;
X $msgfile =~ /\.([^.]+)$/;
X my $fext = $1;
# my $save_ILN = $::ILN;
X local $::ILN;
X local $::opt_charset = "";
X local $_;
X my ($lang,$album,$comment,$theme,$webtheme,$latest,$arrow);
X my $back = "";
X my $copyright = "";
X die "\"$msgfile\" : Bad message file name.\n" unless $msgfile =~ /^[\/.\w]/;
X $msgfile = cwd . "/$msgfile" unless $msgfile =~ m!^/!;
X open(INMES,"<$msgfile") || die "Cannot open Message-File \"$msgfile\" : $!";
X while ($_ = get_config(*INMES,$msgfile)) {
# print "#",__LINE__,"# title: \"$_\"\n" if $DEBUG;
X if (s/^\s*(\w+)\s*=\s*//i) {
X my $tl = $1;
X s/\"$// if s/^\"//; # remove quote
X my $item =$_;
X die <<EOF unless $item;
Error at $msgfile line $::ILN :
\tNo item for $tl found.
EOF
X if ($tl =~ /^Cha(rset)?$/i) {
X my $erm = set_charset($item);
X die <<EOF if $erm;
Error at $msgfile line $::ILN :
\t$erm
EOF
X } elsif ($tl =~ /^Lan(guage)?$/i) {
X $lang = "\L$item\E"; # lower case
X die <<EOF unless $lang eq $fext;
Specified language($lang) is not match with the file extension.
\tat message file ($msgfile) line $::ILN.
EOF
X } elsif ($tl =~ /^Alb(um)?$/i) {
X $album = sanitize_meta($item);
X } elsif ($tl =~ /^Com(ment)?$/i) {
X $comment = sanitize_meta($item);
X } elsif ($tl =~ /^The(me)?$/i) {
X $theme = sanitize_meta($item);
X } elsif ($tl =~ /^Web(Theme)?$/i) {
X $webtheme = sanitize_meta($item);
X } elsif ($tl =~ /^Lat(est)?$/i) {
X $latest = sanitize_meta($item);
X } elsif ($tl =~ /^Arr(ow)?$/i) {
X $arrow = sanitize_meta($item);
X } elsif ($tl =~ /^Back?$/i) {
X $back = sanitize_meta($item);
X } elsif ($tl =~ /^Cop(yright)?$/i) {
X $copyright = $item;
X } else {
X die <<EOF;
Bad message item ($tl) :
\tat message file \"$msgfile\" line $::ILN.
EOF
X }
# redo;
X } elsif (/^$/) {
X last;
X } else {
X die <<EOF;
No proper message item found ($_) :
\tat message file \"$msgfile\" line $::ILN.
EOF
X }
X }
X close(INMES);
# $::ILN = $save_ILN;
X die "Language should be defined in message file \"$msgfile\"\n"
X unless $lang;
X $html_message{$lang} = {} unless $html_message{$lang};
X my $hml = $html_message{$lang};
X $hml->{Album} = $album if $album;
X $hml->{Comment} = $comment if $comment;
X $hml->{Theme} = $theme if $theme;
X $hml->{WebTheme} = $webtheme if $webtheme;
X $hml->{Latest} = $latest if $latest;
X $hml->{Arrow} = $arrow if $arrow;
X $hml->{Back} = $back if $back;
X $hml->{Copyright} = $copyright if $copyright;
X die "Some title and item not defined in message file \"$msgfile\"\n"
X unless $hml->{Album} and $hml->{Comment} and $hml->{Theme}
X and $hml->{WebTheme} and $hml->{Latest} and $hml->{Arrow}
X and $hml->{Copyright};
} # end of set_messages
X
sub get_mtime_of_original_file ( $ ) {
X my $f = shift;
X unless ($f =~ /(.*\/)?(.+)\.($IMGEXT)/) {
X die "!!BUG!! \$f=($f) : Bad image extension : ";
X }
X my $path = ($1 ? "$1$picrawdir" : $picrawdir);
X my $fname = $2;
X my $ext = $3;
X unless (-r "$path/$f") {
X print "#",__LINE__,"# no file: \"$path/$f\" \n" if $DEBUG;
X return undef;
X }
X my $f_orig;
X if ( -r "$path/$fname.$ORIG.$ext") {
X $f_orig = "$fname.$ORIG.$ext";
X } elsif (-r "$path/$fname.$ext.$ORIG") {
X $f_orig = "$fname.$ext.$ORIG";
X } else {
X $f_orig = "$fname.$ext";
X }
X return stat("$path/$f_orig")->mtime;
}
X
sub get_default_theme ( ;$ ) {
X my $fullpath = shift;
X local ($_) = (defined $fullpath ? $fullpath : cwd);
X s!/$!!; # remove last "/"
X s!.*/!!; # remove leading path
X $_ = "root" unless $_;
X return $_;
}
X
sub n_version ( $ ) {
X my $ver = shift;
X unless ($ver =~ /^(\d+)\.(\d+)(-[a-z][.\w]*)?$/i) {
X die "!!BUG!! bad version format : $!";
X }
X return $1+$2/1000;
}
X
sub check_version ( $$;$ ) {
X my ($file,$pname_version,$http) = @_;
X print "#",__LINE__,"# check_version : file=($file)\n" if $DEBUG;
X $file = cwd . "/$file" unless $file =~ m!/!;
X my $db = ($file =~ /\.db$/ ? 1 : 0);
X my $recommended = ($db ? "\"$PNAME -fr\" is recommended."
X : "Config-file should be corrected.");
X my $version;
X if ($pname_version =~ /^\s+(\S+)\s+(\d+)\.(\d+)(-[a-z][.\w]*)?$/) {
X $version = "$2.$3";
X $version .= $4 if $4;
X die <<EOF unless $1 eq $PNAME;
X
Mismatched program!
X
X This program is "$PNAME".
X The specified program at $file line $::ILN
X is "$1".
$recommended
X
EOF
X my ($nV,$nv) = (n_version($VERSION),n_version($version));
X die <<EOF unless int($nV) == int($nv) and $nV >= $nv;
X
Mismatched version!
X
X The version of $PNAME
X is "$VERSION".
X The version at $file line $::ILN
X is "$version".
$recommended
X
EOF
X if ($VERSION ne $version and not exists $version_checked{$file}) {
X warn <<EOF;
X
Versions of $PNAME ($VERSION)
X and of $file line $::ILN ($version)
X are not exactly same, but accepted.
$recommended
X
EOF
X if ($version =~ /-pre/i) {
X warn <<EOF;
### Mismatched pre-released-version may cause curious phenomena. ###
### Please take care! ###
X
EOF
X }
X }
X } else {
X s/^\s+//;
X die <<EOF;
X
Improper version format ($_) is detected.
\tat $file line $::ILN.
X
$recommended
X
EOF
X }
X $version_checked{$file} = 1;
X return $version;
}
X
X
sub getTheme ( $;$ ) {
X my ($file,$http) = @_; # Contents-File, url
# my $save_ILN = $::ILN;
X local $::opt_charset = "";
X local $::ILN;
X local $_;
X my $dir = "";
X print "#",__LINE__,"# getTheme($file)\n" if $DEBUG;
X if ($file =~ m!/$!) {
X $dir = $file;
X $file .= $CONTENT;
X }
X my ($version,$theme,$image,$comment,$mtime);
X my $time_locale = "";
X open(CF,"$file") || die "Cannot open $file : $!";
X SECTION:
X while ($_ = get_config(*CF,$file)) {
X my $iln = $::ILN;
X if (/^Option:/) {
X while ($_ = get_config(*CF,$file)) {
X redo SECTION if /^\S/; # Skip Option: section
X }
X } elsif (/^Version:/) {
X if ($_ = get_config(*CF,$file)) {
X $version = check_version($file,$_,$http);
X }
X } elsif (/^Theme:/) {
# print "#",__LINE__,"# getTheme (Theme:)\n" if $DEBUG;
X while($_ = get_config(*CF,$file)) {
X print "#",__LINE__,"# getTheme \$_=($_)\n" if $DEBUG;
X if (s/^\s+Theme\s*=\s*//) {
X $theme = $_;
X } elsif (s/^\s+Image\s*=\s*//) {
X $image = $_;
X my $info = "";
X while ($_ = get_config(*CF,$file)) {
X last if /^\S|^\s+[\w\.-]+=/;
X s/\s//g;
X $info .= "\n\t $_";
X }
X $image = $dir . $image unless $image =~ m(^http://)i;
X $image .= $info;
X $info =~ s/\s+//g;
X $info =~ s/\)\(/ /g;
X $info =~ s/[()]//g;
X my $i = 0;
X foreach my $im (split ' ',$info) {
X $i += 1 if $im =~ /^N/i;
X $i += 10 if $im =~ /^H/i;
X $i += 100 if $im =~ /^I/i;
X }
X die <<EOF unless $i == 111;
Broken contents-file: (No info for image)
\tat $file line $iln.
EOF
X redo;
X } elsif (s/^\s+Comment\s*=\s*//) {
X $comment = "$_";
X while ($_ = get_config(*CF,$file)) {
X last if /^\S|^\s+[\w\.-]+\s*=/;
X s/^\s+//;
X $comment .= "\n\t\t$_";
X }
X redo;
X } elsif (/^\s+Latest\s*=(\d+)/) {
X $mtime = $1;
X $time_locale = $1 if /\((.+)\)/;
# } elsif (/^\s+Mtime=(\d+)/) {
# $w_mtime = $1;
X } elsif (/^\S|^$/) {
X last;
X } else {
X die <<EOF;
Broken contents-file:
\tat $file line $::ILN.
"$PNAME -fr" is recommended.
EOF
X }
X }
X }
X last if $version and $theme;
X }
X close(CF);
X print "#",__LINE__,"# getTheme result : $version,$theme,$image,$comment,$mtime\n" if $DEBUG;
X die <<EOF unless $version;
Version is not found in the contents-file. (It might be too old.):
\t$file
"$PNAME -fr" is recommended.
EOF
X die <<EOF unless $theme and $image and $mtime;
"Theme:" section on the contents-file (as following) is broken.
\t$file
"$PNAME -fr" is recommended.
EOF
# $::ILN = $save_ILN;
X return ($theme,$image,$comment,$mtime,$time_locale);
} # end of getTheme
X
sub get_theme_image ( $ ) {
X my $dbf = shift;
X print "#",__LINE__,"# get_theme_image: dbf=($dbf)\n" if $DEBUG;
X die "!!BUG!! \"$dbf\" : not found : " unless -r $dbf;
# my $save_ILN = $::ILN;
X local $::ILN;
X local $_;
X my ($theme,$image,$comment,$mtime,$time_locale) = getTheme($dbf);
# $::ILN = $save_ILN;
X return $image;
}
X
sub get_shrink_size () {
# print "#",__LINE__,"# get_shrink_size\n" if $DEBUG;
X local $_ = $::opt_scale;
X die "!!BUG!! \"Option: Scale-Directory=\" is not set.\n" unless $_;
X %scale_dir = ();
X while (s/^\((.*?)\)//) {
X my $s = $1;
X $s =~ s/^\s+//;
X $s =~ s/\s+$//;
X if ($s =~ /(\S*)\s*=\s*(.*)/) {
X my $scale = $1;
X my $dir = $2;
X $scale_dir{$scale} = $dir;
X } else {
X die <<EOF;
\t"Option: Scale-Directory=" should be formed as "(Scale=Directory)".
EOF
X }
X }
X die "Bad format." if $_;
X $_ = $::opt_size;
X die <<EOF unless $_;
"Option: Size-of-Picture=" is not set.
\tNote: "Size-of-Picture" should be placed after "Scale-Directory"
EOF
X %picheader = ();
X while (s/^\((.*?)\)//) {
X my $s = $1;
X if ($s =~ /(.*)=(.*)/) {
X my $picture = $1;
X my $scale = $2;
X if ($picture eq "Normal") {
X $picheader{Normal} = $scale;
X } elsif ($picture eq "Header") {
X $picheader{Header} = $scale;
X } elsif ($picture eq "Index") {
X $picheader{Index} = $scale;
X } else {
X die "!!BUG!! \"Bad Option: Size=\" should be Normal|Header|Index.";
X }
X } else {
X die <<EOF;
\t"Option: Size-of-Picture=" should be formed as "(Title=scale)".
\t\t(Title is one of "Normal", "Header" and "Index".)
EOF
X }
X }
X die "Bad format.\n" if $_;
X
X my %value;
X foreach my $scale (keys %scale_dir) {
X my ($v,$mes) = check_scale($scale);
X die "In Scale-Directory:\n$mes\n" if $mes;
X if (exists $value{$v}) {
X die "!!BUG!! Scale value($v) doubly defined in Scale-Dierectory.";
X }
X $value{$v} = $scale;
X my $sn;
X if ($scale =~ m!(.+)/(.+)!) {
X $sn = "$1_$2";
X } elsif ($scale =~ m/(.*)\.(.*)/) {
X $sn = "$2" if (not defined $1 or $1 == 0);
X }
X $shrink_name{$scale} = ($v == 1 ? "" : ".$sn.");
X }
X unless (exists $value{1}) {
X die "!!BUG!! Raw image file (Scale=1) is not found.";
X }
X @sorted_scale = ();
X foreach my $v (sort keys %value) {
X unshift @sorted_scale,$value{$v};
X }
X $picrawdir = $scale_dir{$sorted_scale[0]};
} # end of get_shrink_size
X
sub get_only_shrink_size_from_file () {
# print "#",__LINE__,"# get_only_shrink_size_from_file\n" if $DEBUG;
X local %::option_scale = %::option_scale;
X local %::option_size = %::option_size;
X my $only_scale_and_size = 1;
X my $file;
X if (-r $CONFIG and -r $CONTENT) {
X $file = (stat($CONFIG)->mtime > stat($CONTENT)->mtime ?
X $CONFIG : $CONTENT);
X } elsif (-r $CONFIG) {
X $file = $CONFIG;
X } elsif (-r $CONTENT) {
X $file = $CONTENT;
X }
X set_option_from_file($file,$only_scale_and_size) if $file;
X get_shrink_size();
}
X
sub image_path ( $$;$ ) {
X my ($header,$o_image,$require_size) = @_;
# print "#",__LINE__,"# image_path header='$header' image='$o_image'\n" if $DEBUG;
X $o_image =~ s(.+/http://)(http://);
X my $image = $o_image;
X my $info = "";
X if ($image =~ s/\s*(\(.*)//) {
# print "#",__LINE__,"# \$image=($image)\n" if $DEBUG;
X $info = ($1 ? $1 : "");
# print "#",__LINE__,"# \$info=($info)\n" if $DEBUG;
X $info =~ s/\s+//g;
X $info =~ s/\)\(/ /g;
X $info =~ s/[()]//g;
X }
X unless ($image =~ /(.*)\.($IMGEXT)$/) {
X die "Bad image file name ($image) : ";
X }
X my ($base,$ext) = ($1,$2);
X my $path = "./"; # for mozilla
X ($path,$base) = ($1,$2) if $base =~ m!(.*/)([^/]+)$!;
X my $sub_theme = ($path and $path ne "./"); # sub theme image
X my $html_image_size;
X my $im_info;
X if ($info) {
X foreach my $im (split ' ',$info) {
# print "#",__LINE__,"# \$im=($im)\n" if $DEBUG;
X unless ($im =~ /^(.+)=([^,]+),([^,]+),([^,]+)$/) {
X die <<EOF;
Bad info for image "$o_image".
EOF
X }
X my ($hd,$scale,$dir,$wxh) = ($1,$2,$3,$4);
X $wxh =~ /(\d+)x(\d+)/;
X my $hiz = "width=\"$1\" height=\"$2\"";
X my $sn;
X if ($scale =~ m!(.+)/(.+)!) {
X $sn = "$1_$2";
X } elsif ($scale =~ m/(.*)\.(.*)/) {
X $sn = "$2" if (not defined $1 or $1 == 0);
X }
X $shrink_name{$scale} = ".$sn.";
X if ($hd =~ /^N(ormal)?$/) {
X next unless $header eq "Normal";
X $picheader{Normal} = $scale;
X $im_info = "N=$dir,$scale,$wxh";
X $html_image_size = $hiz;
X last;
X } elsif ($hd =~ /^H(eader)?$/) {
X next unless $header eq "Header";
X $picheader{Header} = $scale;
X $im_info = "H=$dir,$scale,$wxh";
X $html_image_size = $hiz;
X last;
X } elsif ($hd =~ /^I(ndex)?$/) {
X next unless $header eq "Index";
X $picheader{Index} = $scale;
X $im_info = "I=$dir,$scale,$wxh";
X $html_image_size = $hiz;
X last;
X } else {
X die <<EOF;
Bad info for image "$o_image".
EOF
X }
X $scale_dir{$scale} = $dir;
X }
X } elsif ($sub_theme) { # theme image
X my $oldwd = cwd;
X chdir $path; # goto theme sub-directory
X get_only_shrink_size_from_file();
X chdir $oldwd;
X }
X my $scale;
X my $dir;
X if ($header eq "Header" or $header eq "Index" or $header eq "Normal") {
X $scale = $picheader{$header};
X $header =~ /^(.)/;
X my $hd = $1;
X foreach my $im (split ' ',$info) {
X $im =~ /^(.).*=(.+)/;
X if ($hd eq $1) {
X $im_info = "$hd=$2";
X last;
X }
X }
X $dir = $scale_dir{$scale};
X } elsif ($header eq "Raw") {
X $scale = $sorted_scale[0];
X } else {
X $scale = $header;
X }
X $path .= $scale_dir{$scale};
X my $real_image_path;
X if ($scale eq $sorted_scale[0]) {
X $real_image_path = "$path/$base.$ext";
X } else {
X $real_image_path = "$path/$base$shrink_name{$scale}$ext";
X }
X if ($require_size and not $html_image_size) {
X die <<EOF if $path =~ /^http:/;
No info of "$header" size of the image on http:
\t$o_image
The version of mkphotohtml on the remote site might be mismatch with local one.
Try "mkphotohtml -fw" once to renew the cache file.
EOF
X $html_image_size = html_imgsize($real_image_path);
X }
X if ($require_size and not $im_info) {
X $html_image_size =~ /width=\"(\d+)/i;
X my $width = $1;
X $html_image_size =~ /height=\"(\d+)/i;
X my $height = $1;
X $header =~ /^(.)/;
X my $hd = $1;
X $im_info = "$hd=$scale,$dir,${width}x${height}";
X }
# print "#",__LINE__,"# real_image_path=($real_image_path)\n\tHD=($header) size=($html_image_size) im_info=($im_info)\n" if $DEBUG;
X get_shrink_size() if $sub_theme; # restore variables for scale and dir.
X if ($require_size) {
X return $real_image_path,$html_image_size,$im_info;
X } else {
X return $real_image_path;
X }
} # end of image_path
X
X
sub sanitize_meta ( $;$ ) {
X local $_ = shift;
X my $no_br = shift;
X return "" unless $_;
X s/\\\#/\#/g;
X s/&/&/g;
X s/\"/"/g;
X s/</</g;
X s/>/>/g;
X s/^\s+/\t/mg;
X s/\n$//;
X s/\n/<br>\n/g unless $no_br;
X return $_;
}
X
######################################################################
X
my $depth = 0;
X
sub makephoto (@) {
X print "#",__LINE__,"# MAKEPHOTO dirs=`@_'\n" if $DEBUG;
X my @ds = @_;
X my $oldpwd = cwd;
X ++$depth;
X
X SPECIFIED_DIRECTORY:
X foreach my $d (@ds) {
X chdir $oldpwd;
X $d =~ s!/$!!;
X if (-l $d) {
X warn "\"$oldpwd/$d\" is symbolic link, skipped.\n" if $VERBOSE;
X next SPECIFIED_DIRECTORY;
X }
X chdir $d || die "Cannot change directory to \"$d\".\n";
X my $pwd = cwd; # Full Path
X if ($FORCEUPDATE) {
X if (-r $CONTENT) {
X rename "$CONTENT", "$CONTENT.OLD";
X warn <<EOF if $VERBOSE;
Force-update:
\t$pwd/$CONTENT renamed to $CONTENT.OLD
EOF
X }
X }
X my @dirs = ();
X my @dirs_rec = ();
X {
X get_only_shrink_size_from_file();
X foreach my $f (glob("*")) {
X next if $f =~ /^$ORIG$|^$ORIG\.|\.$ORIG$|\.$ORIG\./o;
X next if substr($f,0,1) eq substr($picrawdir,0,1);
X push @dirs, $f if -d $f;
X push @dirs_rec, $f if (-d $f && ! -l $f);
X }
X }
X if (@dirs_rec && $RECURSIVE) {
X makephoto(@dirs_rec);
X print "#",__LINE__,"# Back from recursive call. Now pwd=",cwd,"\n" if $DEBUG;
X }
X undef @dirs_rec;
X warn <<EOF if $VERBOSE;
Now, theme directory "$pwd" is processed.
EOF
X
X if ($CLEAN) {
X print "#",__LINE__,"# CLEAN\n" if $DEBUG;
X get_only_shrink_size_from_file();
X foreach my $scale (@sorted_scale[1..$#sorted_scale]) {
X my $dir = $scale_dir{$scale};
X if (-l $dir) {
X warn "\"$pwd/$dir\" is symbolic link, skipped.\n" if $VERBOSE;
X next;
X }
X my $cleaned;
X foreach my $f (glob "$dir/*") {
X next unless $f =~ m!/(.+)\.([^.]+)\.($IMGEXT)$!o;
X my $rf = "$1.$3";
X my $shrinkname = ".$2.";
X next unless $shrinkname eq $shrink_name{$scale};
X unless (-f "$picrawdir/$rf") {
X unlink $f;
X warn "unlink $pwd/$f\n" if $VERBOSE;
X $cleaned = 1;
X }
X }
X warn "Cleaned up bogus images on $dir\n"
X if $cleaned and $VERBOSE;
X }
X next SPECIFIED_DIRECTORY;
X } # end of CLEAN
X
X print "#",__LINE__,"# Now dir: ",cwd,"\n" if $DEBUG;
X my @tmp = ();
X while (my $d = shift @dirs) {
X if (-r "$d/$CONTENT") {
X push @tmp,$d;
X } else {
X warn "No $CONTENT under \"$pwd/$d/\" ... skipped\n";
X }
X }
X @dirs = @tmp;
X print "#",__LINE__,"# \@dirs=(@dirs)\n" if $DEBUG;
X
X my @images = ();
X foreach my $f (glob("$picrawdir/*")) {
X next if $f =~ /\.$ORIG$|\.$ORIG\./o;
X $f =~ s!.+/!!; # remove directory part
X push @images, $f
X if -r "$picrawdir/$f" and $f =~ /\.($IMGEXT)$/o;
X }
X print "#",__LINE__,"# \@images=(@images)\n" if $DEBUG;
X
X my $should_be_updated = $FORCEUPDATE;
X
X my $mkshrink;
X foreach my $f (@images) {
X my ($base,$dir,$ext) = fileparse $f, '\.[^.]*';
X push @images, $f if -r $f;
X foreach my $scale (@sorted_scale[1..$#sorted_scale]) {
X my $rawfile = image_path("Raw", $f);
X my $shrinkfile = image_path($scale,$f);
X unless (-e "$shrinkfile" &&
X (stat($shrinkfile)->mtime > stat("$rawfile")->mtime)) {
X unless (-d $scale_dir{$scale}) {
X mkdir $scale_dir{$scale},$DMODE;
X warn "Directory \"$pwd/$scale_dir{$scale}\" is created\n"
X if $VERBOSE;
X }
X warn "Shrink image(s) for \"$pwd/$picrawdir\".\n"
X if $VERBOSE and not $mkshrink;
X $mkshrink = 1;
X if ($scale =~ m!^1/[248]$!) {
X die "$DJPEG : cannot be executed.\n" unless -x $DJPEG;
X die "$CJPEG : cannot be executed.\n" unless -x $CJPEG;
X system "$DJPEG -scale $scale $rawfile | $CJPEG >$shrinkfile";
X } else {
X my ($v,$mess) = check_scale($scale);
X die "!!BUG!! $mess : " if $mess;
X die "$JPEGTOPNM : cannot be executed.\n" unless -x $JPEGTOPNM;
X die "$PNMSCALE : cannot be executed.\n" unless -x $PNMSCALE;
X die "$PNMTOJPEG : cannot be executed.\n" unless -x $PNMTOJPEG;
X system
X "$JPEGTOPNM $rawfile | $PNMSCALE $v | $PNMTOJPEG >$shrinkfile";
X }
X die "Cannot shrink $pwd/$rawfile.\n" if $?;
X $should_be_updated = 1
X }
X }
X }
X
X if (not $should_be_updated and -f $CONFIG and -f $CONTENT) {
X $should_be_updated = 1
X if stat($CONFIG)->mtime > stat($CONTENT)->mtime ;
X }
X if (-f $CONTENT) {
X unless ($should_be_updated) {
X if (@images) {
X foreach my $d (values %scale_dir) {
X if (! -d $d or stat($CONTENT)->mtime < stat($d)->mtime) {
X $should_be_updated = 1;
X print "#",__LINE__,
X "# No $d, or \$CONTENT($CONTENT) is older than $d\n" if $DEBUG;
X last;
X }
X }
X } else {
X warn "No image on $pwd\n" if $VERBOSE;
X }
X if (@dirs) {
X foreach my $d (@dirs) {
X if (stat($CONTENT)->mtime < stat($d)->mtime) {
X $should_be_updated = 1;
X print "#",__LINE__,"# \$CONTENT($CONTENT) is older than $d\n" if $DEBUG;
X last;
X }
X }
X } else {
X warn "No sub-theme directory on $pwd\n" if $VERBOSE;
X }
X }
X } else {
X $should_be_updated = 1;
X warn "$pwd/$CONTENT is not found.\n" if $VERBOSE;
X }
X
X unless ($should_be_updated) {
X warn "No update for $CONTENT and $HTML on $pwd\n" if $VERBOSE;
X next SPECIFIED_DIRECTORY;
X }
X
X ### $CONENT and $HTML should be updated. ###
X
X my $option_on;
X local $::opt_lang = $::opt_lang;
X local $::opt_order = $::opt_order;
X local $::opt_image = $::opt_image;
X local $::opt_theme = $::opt_theme;
X local $::opt_config = $::opt_config;
X local $::opt_mail = $::opt_mail;
X local $::opt_uname = $::opt_uname;
X local $::opt_charset = $::opt_charset;
X local $::opt_scale = $::opt_scale;
X local $::opt_size = $::opt_size;
X local $::opt_back = $::opt_back;
X local $::opt_start = $::opt_start;
X local $::opt_top = $::opt_top;
X local $::opt_ckweb = $::opt_ckweb;
X local $::opt_refer = $::opt_refer;
X local $::opt_prolog = $::opt_prolog;
X local $::opt_epilog = $::opt_epilog;
X
X my $theTheme_on;
X my $theTheme_theme = get_default_theme();
X my $theTheme_image;
X my $theTheme_comment = "";
X my $theTheme_latest;
X my @contents;
X if (-r $CONTENT) {
X rename "$CONTENT", "$CONTENT.OLD";
X warn "$pwd/$CONTENT : renamed to $CONTENT.OLD\n" if $VERBOSE;
X }
X
X if (-r $CONFIG) {
X warn "$pwd/$CONFIG is found.\n" if $VERBOSE;
X open(INCONFIG,$CONFIG) || die "Cannot read $pwd/$CONFIG : $!";
X while ($_ = get_config(*INCONFIG,$CONFIG)) {
###
X sub get_theme_items ( * ) {
X my $section = shift;
X print "#",__LINE__,"# CONFIG: get_theme_item:($section)\n" if $DEBUG;
X my ($theme,$image,$comment,$latest) = ("","","","");
X my $pwd = cwd;
X while ($_ = get_config(*INCONFIG,$CONFIG)) {
X last if /^\S|^$/;
X if (s/^\s+$PTHEME\s*=\s*//io) {
X $theme = $_;
X } elsif (s/^\s+$PIMAGE\s*=\s*//io) {
X if ($section eq "http") {
X warn <<EOF;
Image item in http section is specified, but it is not allowed :
\tat $pwd/$CONFIG line $::ILN.
\t..... ignored.
EOF
X $image = "";
X } elsif (m!/$!) {
X $image = $_;
X unless (-d $image) {
X warn <<EOF;
Sub-theme($_) for theme image specified, but it is not found :
\tat $pwd/$CONFIG line $::ILN.
\t..... ignored.
EOF
X $image = "";
X }
X } else {
X s/\s+.*$//; # ignore (...) parts
X $image = $_;
X unless (/\.($IMGEXT)$/o) {
X warn <<EOF;
Bad theme image file name ($_):
\tat $pwd/$CONFIG line $::ILN.
\t..... ignored.
EOF
X $image = "";
X }
X }
X print "#",__LINE__,"# image:($image)\n" if $DEBUG;
X } elsif (s/^\s+Com(ment)?\s*=\s*//i) {
X s/^\s+//;
X $comment = $_;
X while ($_ = get_config(*INCONFIG,$CONFIG)) {
X last if /^\S|^\s+[\w\.-]+\s*=/;
X s/^\s+//;
X $comment .= "\n\t\t$_";
X }
X redo;
X } elsif (/^\s+Lat(est)?\s*=.*?\((.+)\)/) {
X $latest = $2;
X if ($section eq "Sub-Theme") {
X warn <<EOF;
Latest item in Sub-Theme section is specified, but it is not allowed :
\tat $pwd/$CONFIG line $::ILN.
\t..... ignored.
X
EOF
X $latest = "";
X }
X } else {
X die <<EOF;
Error at $pwd/$CONFIG line $::ILN :
\t"$_" is bad $section item.
EOF
X }
X }
X return ($theme,$image,$comment,$latest);
X } ### End of sub get_theme_items;
###
X if (/^Ver(sion)?:/i) {
X print "#",__LINE__,"# CONFIG: Version\n" if $DEBUG;
X while ($_ = get_config(*INCONFIG,$CONFIG)) {
X last if /^\S/; # version checked already
X }
X redo;
X } elsif (/^Opt(ion)?:$/i) { ### Option:
X print "#",__LINE__,"# CONFIG: Option\n" if $DEBUG;
X die "\"Option:\" doubly defined at $pwd/$CONFIG line $::ILN.\n"
X if $option_on;
X $option_on = 1;
X while ($_ = get_config(*INCONFIG,$CONFIG)) {
X last if /^\S/;
X if (s/^\s+(Pro|Epi)(?:log|logue)?\s*=\s*//i) {
X my $pt = ($1 =~ /Pro/i ? \$::opt_prolog : \$::opt_epilog);
X print "#",__LINE__,"# CONFIG: ProEpi ($_)\n" if $DEBUG;
X $$pt = $_;
X while ($_ = get_config(*INCONFIG,$CONFIG)) {
X print "#",__LINE__,"# CONFIG: ProEpi ($_)\n" if $DEBUG;
X last if /^\S|^\s+[\w\.-]+\s*=/;
X s/^\s+//;
X $$pt .= "\n\t\t $_";
X }
X redo;
X }
X set_option("conf",$_);
X }
X get_shrink_size();
X redo; ### End of Option:
X } elsif (/^$PTHEME:$/io) { ### Theme:
X print "#",__LINE__,"# CONFIG: Theme\n" if $DEBUG;
X die "\"Theme:\" doubly defined at $pwd/$CONFIG line $::ILN.\n"
X if $theTheme_on;
X $theTheme_on = 1;
X ($theTheme_theme,$theTheme_image,$theTheme_comment,$theTheme_latest)
X = get_theme_items("Theme");
X print "#",__LINE__,"# CONFIG: Theme image : ($theTheme_image)\n" if $DEBUG;
X if ($theTheme_image =~ m!/$!) {
X die <<EOF unless -d $theTheme_image;
Bad theme directory specified ($theTheme_image):
\tat $pwd/$CONFIG line $::ILN.
EOF
X if (-r "$theTheme_image$CONTENT") {
X $theTheme_image = get_theme_image($theTheme_image);
X die <<EOF unless $theTheme_image;
"$theTheme_image" : Bad theme specified.
\tat $pwd/$CONFIG line $::ILN.
EOF
X } else {
X die <<EOF;
"$theTheme_image/$CONTENT" : not found.
\tat $pwd/$CONFIG line $::ILN.
EOF
X }
X }
X if ($theTheme_image) {
X my $imp = (image_path("Header",$theTheme_image));
X print "#",__LINE__,"# imp=($imp)\n" if $DEBUG;
X unless ($imp and -r $imp) {
X warn <<EOF;
"$imp" is not found.
\t\t.... ignored it and took default theme image instead.
\t"$theTheme_image" is specified
\t\tat $pwd/$CONFIG line $::ILN.
EOF
X $theTheme_image = "";
X }
X }
X print "#",__LINE__,"# theTheme_image:($theTheme_image)\n" if $DEBUG;
X redo; ### End of Theme:
X } elsif (s!^http:?//(\S+)/($CONTENT)?$!http://$1/!i) { ### Web-theme
X print "#",__LINE__,"# CONFIG: http: ($_)\n" if $DEBUG;
X my $url = $_;
X $_ .= $CONTENT;
X my $http = $_;
X s(^http://)($PREHTTP)o;
X s(/)($SLASHHTTP)og;
X my $fhttp = $_;
X my ($theme,$image,$comment,$latest) = get_theme_items("http");
X print "#",__LINE__,"# CONFIG(http): theme=($theme) image=($image) comment=($comment) latest=($latest)\n" if $DEBUG;
X my $update_web;
X my $ignore;
X my ($w_theme,$w_image,$w_comment,$mtime,$time_locale,$w_mtime);
X if (-r "$fhttp") {
X $w_mtime = stat($fhttp)->mtime;
X print "#",__LINE__,"# CONFIG: w_mtime=($w_mtime)\n" if $DEBUG;
X if ($::opt_ckweb eq "Yes") {
X $update_web = 1;
X }
X } else {
X $update_web = 1;
X }
X if ($update_web) {
X print "#",__LINE__,"# CONFIG: update_web=($update_web)\n" if $DEBUG;
X my ($content_type, $document_length, $modified_time,
X $expires, $server) = head("$http");
X print "#",__LINE__,"# content_type=($content_type) document_length=($document_length) modified_time=($modified_time) expires=($expires) server=($server)\n" if $DEBUG;
X unless ($content_type and $modified_time) {
X warn "Cannot access to \"$http\" ... skipped.\n";
X $ignore = 1;
X }
X print "#",__LINE__,"# w_mtime=($w_mtime) modified_time=($modified_time)\n" if $DEBUG;
# if (defined $w_mtime and ($w_mtime == str2time($modified_time))) {
X if (defined $w_mtime and ($w_mtime == $modified_time)) {
X warn "Content of Web page ($http) is not changed.\n"
X if $VERBOSE;
X $update_web = 0;
X } else {
X if ($content_type and $content_type =~ m(text/plain)i) {
X $document_length = 0 unless defined $document_length;
X if ($document_length <= $MAXWEBDOCLENGTH) {
# $w_mtime = str2time($modified_time);
X $w_mtime = $modified_time;
X } else {
X warn "Document length on Web page ($http) is too long.\n";
X $ignore = 1;
X }
X } else {
X warn "Bad Content_type on Web page ($http).\n";
X $ignore = 1;
X }
X }
X }
X if ($ignore) {
X print "#",__LINE__,"# CONFIG: $url : ignored\n" if $DEBUG;
X } else {
X if ($update_web) {
X rename $fhttp,"$fhttp.OLD" if -r $fhttp;
X my $rc = getstore($http,$fhttp);
X if (is_error($rc)) {
X my $mes = status_message($rc);
X die "Error($mes) while accessed $http\n";
X }
X utime $w_mtime,$w_mtime,$fhttp;
X open(FHTTP,$fhttp) || die "Cannot read $pwd/$fhttp : $!";
X my $allowed;
X {
X local $::ILN;
X local $_;
X while ($_ = get_config(*FHTTP,$fhttp)) {
X if (s/^\s+Ref(er)?\s*=\s*//i) {
X $allowed = 1 if /^All(ow)?$/i;
X last;
X }
X }
X }
X close FHTTP;
X if ($allowed) {
X warn "$fhttp is updated\n" if $VERBOSE;
X } else {
X unlink $fhttp;
X $ignore = 1;
X warn <<EOF;
Web-theme ($url) is specified at
\t\t$pwd/$CONFIG line $::ILN.
\tBut denied to refer for Network Photo Album.
\t.... skipped.
EOF
X }
X }
X unless ($ignore) {
X my ($w_theme,$w_image,$w_comment,$mtime,$time_locale)
X = getTheme($fhttp,$http);
X $theme = $w_theme unless $theme;
X $image = $w_image; #unless $image;
X $comment = $w_comment unless $comment;
X $latest = $time_locale unless $latest;
X push @contents,{ "ThemeWeb" => $http,
X "Theme" => $theme,
X "Image" => $image,
X "Comment" => $comment,
X "Mtime" => $mtime,
X "Ltime" => $latest,
X "URL" => $url
X };
X }
X }
X redo; ### End of Web-theme
X } elsif (s!^(\S+)/$!!) { ### Sub-theme
X print "#",__LINE__,"# CONFIG: Sub-Theme: ($1)\n" if $DEBUG;
X my $theme_dir = $1;
X @dirs = grep {$_ ne $theme_dir} @dirs; # remove it from @dirs
X my ($theme,$image,$comment,$latest) = get_theme_items("Sub-Theme");
X my $im = "$theme_dir/$image";
X $im =~ s!/([^/]+)$!/$picrawdir/$1!;
X print "#",__LINE__,"# CONFIG: Sub-Theme image: ($im)\n" if $DEBUG;
X unless (-r $im) {
X $image = "";
X warn <<EOF;
Theme image($im) is not found
\tat $pwd/$CONFIG line $::ILN.
\t ... ignored it and took default theme image instead.
EOF
X }
X if ($latest) {
X warn <<EOF;
Bad "Latest:" item found
\tat $pwd/$CONFIG line $::ILN.
\t ... ignored it.
EOF
X }
X if (-r "$theme_dir/$CONTENT") {
X my ($d_theme,$d_image,$d_comment,$mtime,$time_locale)
X = getTheme("$theme_dir/$CONTENT");
X $theme = $d_theme unless $theme;
X $image = $d_image unless $image;
X $comment = $d_comment unless $comment;
X push @contents,{ "ThemeDir" => $theme_dir,
X "Theme" => $theme,
X "Image" => $image,
X "Comment" => $comment,
X "Mtime" => $mtime,
X "Ltime" => $time_locale
X };
X } else {
X warn <<EOF;
Sub theme "$theme_dir" is specified
\tat $pwd/$CONFIG line $::ILN,
\tbut "$theme_dir/$CONTENT" is not found.
\t ... ignored it.
EOF
X }
X redo; # end of sub theme
X } elsif (s/^([^\s:]+)$//) {
X print "#",__LINE__,"# CONFIG: Image\n" if $DEBUG;
X my $image_file = $1;
X die <<EOF unless $image_file =~ /\.($IMGEXT)$/o;
Error at $pwd/$CONFIG line $::ILN :
\tImage: "$image_file" does not have proper extension of image.
EOF
X @images = grep {$_ ne $image_file} @images; # remove it from @images
X my ($name,$date,$comment) = ("","","");
X while ($_ = get_config(*INCONFIG,$CONFIG)) {
X last if /^\S|^$/;
X if (s/^\s+Name?\s*=\s*//i) {
X $name = $_;
X } elsif (s/^\s+Date?\s*=\s*//i) {
X $date = $_;
X } elsif (s/^\s+Com(ment)?\s*=\s*//i) {
X s/^\s+//;
X $comment = "$_";
X while ($_ = get_config(*INCONFIG,$CONFIG)) {
X last if /^\S|^\s+[\w\.-]+\s*=/;
X s/^\s+//;
X $comment .= "\n\t\t$_";
X }
X redo;
X } else {
X die <<EOF;
Error at $pwd/$CONFIG line $::ILN :
\tImage: "$_" is bad theme option.
EOF
X }
X }
X my $mtime = get_mtime_of_original_file($image_file);
X if (defined $mtime) {
X $name = $image_file unless $name;
X $date = ctime($mtime) unless $date;
X push @contents,{ "ImageFile" => $image_file,
X "Name" => $name,
X "Date" => $date,
X "Comment" => $comment,
X "Mtime" => $mtime
X };
X } else {
X warn "$image_file: specified at $pwd/$CONFIG line $::ILN,",
X " but not found ... skipped.\n";
X }
X redo; # end of image
X } elsif (/^$/) {
X last;
X } else {
X die <<EOF;
Error at $pwd/$CONFIG line $::ILN :
\t"$_" is wrong section.
EOF
X }
X }
X close(INCONFIG);
X } # end of CONFIG
X
X print "#",__LINE__,"# Option: Language=$::opt_lang, Order=$::opt_order, Image=$::opt_image, Theme=$::opt_theme, Config=$::opt_config\n" if $DEBUG;
X
X get_shrink_size();
X
X my @here_d;
X while (my $d = shift @dirs) { # add new SubTheme entries to Contents
X if (-r "$pwd/$d/$CONTENT") {
X my ($theme,$image,$comment,$mtime,$time_locale)
X = getTheme("$pwd/$d/$CONTENT");
X push @here_d,{ "ThemeDir" => $d,
X "Theme" => $theme,
X "Image" => $image,
X "Comment" => $comment,
X "Mtime" => $mtime,
X "Ltime" => $time_locale
X }
X } else {
X die "!!BUG!! No $pwd/$d/$CONTENT found. : ";
X }
X }
X undef @dirs;
X
X my @here_f;
X while (my $f = shift @images) { # add new Image entries to here_f
X my $mtime = get_mtime_of_original_file($f);
X my $date = ctime($mtime);
X push @here_f,{ "ImageFile" => $f,
X "Name" => $f,
X "Date" => $date,
X "Comment" => "",
X "Mtime" => $mtime
X }
X }
X undef @images;
X
X print "#",__LINE__,"# opt_config=\"$::opt_config\"\n" if $DEBUG;
X if ($::opt_config eq "Non") {
X foreach (@contents) {
X if (exists $_->{ThemeDir}) {
X push @here_d,$_;
X } elsif (exists $_->{ThemeWeb}) {
X unless ($_->{Image} =~ m(^http://)) {
# print "### http=($_->{URL}) Image=($_->{Image})\n" if $DEBUG;
X $_->{Image} = $_->{URL} . $_->{Image};
X }
X push @here_d,$_;
X } else {
X $_->{Mtime} = get_mtime_of_original_file($_->{ImageFile});
X $_->{Date} = ctime($_->{Mtime}) unless $_->{Date};
X push @here_f, $_;
X }
X print "#",__LINE__,"# \@contents: Mtime=($_->{Mtime})\n" if $DEBUG;
X }
X }
X
X my @here;
X if ($::opt_order =~ /^New-|^Old-/) {
X print "#",__LINE__,"# opt_order=\"$::opt_order\"\n" if $DEBUG;
X @here = sort {$a->{Mtime} <=> $b->{Mtime}} (@here_d,@here_f);
X @here = reverse(@here)
X if $::opt_order eq "New-First" or $::opt_order eq "Old-Last";
X } else {
X @here_d = sort {$a->{Mtime} <=> $b->{Mtime}} @here_d;
X @here_f = sort {$a->{Mtime} <=> $b->{Mtime}} @here_f;
X
X @here_d = reverse(@here_d) if $::opt_theme eq "Reverse";
X @here_f = reverse(@here_f) if $::opt_image eq "Reverse";
X
X if ($::opt_order eq "Image-First") {
X @here = (@here_f,@here_d); # Order=Image-First
X } else {
X @here = (@here_d,@here_f); # Order=Directoy-First
X }
X }
X undef @here_d;
X undef @here_f;
X
X if ($::opt_config eq "Last") {
X @contents = (@here,@contents); # Config=Last
X } elsif ($::opt_config eq "First") {
X @contents = (@contents,@here); # Config=First
X } else {
X @contents = @here; # Config=Non
X }
X undef @here;
X
X rename "$CONTENT", "$CONTENT.OLD" if -r $CONTENT;
X unless (@contents) {
X if (-r $CONFIG) {
X warn "Configuration file($CONFIG) exists but no image found\n",
X " under $pwd ... ignored.\n";
X } else {
X warn "No image in \"$pwd/\" ... skipped.\n";
X }
X next SPECIFIED_DIRECTORY;
X }
X
X unless ($theTheme_image) {
X my $c = $contents[0];
X if (exists $c->{ImageFile}) {
X $theTheme_image = $c->{ImageFile};
X } elsif (exists $c->{ThemeDir}) {
X if ($c->{Image} =~ m(^http://)i) {
X $theTheme_image = "$c->{Image}";
X } else {
X $theTheme_image = "$c->{ThemeDir}/$c->{Image}";
X }
X } elsif (exists $c->{ThemeWeb}) {
X $theTheme_image = "$c->{Image}";
X } else {
X die "!!BUG!! Cannot get default theme image on $pwd : ";
X }
X $theTheme_comment = $c->{Comment} unless $theTheme_comment;
X }
# unless ($theTheme_image =~ /\S+\s+(.+)/) {
## if ($theTheme_image =~ m(http://)) {
## }
# }
X
X ### Generate Contents file ###
X print "#",__LINE__,"# Generate Contents: $pwd/$CONTENT\n" if $DEBUG;
X
X my $max_mtime = 0;
X foreach my $c (@contents) {
X $max_mtime = $c->{Mtime} if $max_mtime < $c->{Mtime};
X }
X my $ctime = ctime();
X my $latestdate = ($theTheme_latest ? $theTheme_latest : ctime($max_mtime));
X my ($titleimage_N,$size_titleimage_N,$t_info_N)
X = image_path("Normal",$theTheme_image,"size-required");
X my ($titleimage_H,$size_titleimage_H,$t_info_H)
X = image_path("Header",$theTheme_image,"size-required");
X my ($titleimage_I,$size_titleimage_I,$t_info_I)
X = image_path("Index",$theTheme_image,"size-required");
X $theTheme_image .= "\n\t ($t_info_N)($t_info_H)($t_info_I)"
X unless $theTheme_image =~ /\s/;
X
X my $content_db = <<EOF;
# $CONTENT: Do not edit this!
# This file was generated by $PNAME at $ctime
X
Version:
\t$PNAME $VERSION
X
Option:
\tCharset=utf8
\tLanguage=$::opt_lang
\tOrder=$::opt_order
\tImage=$::opt_image
\tTheme=$::opt_theme
\tConfig=$::opt_config
\tMail-Address=$::opt_mail
\tUser-Name=$::opt_uname
\tScale-Directory=$::opt_scale
\tSize-of-Picture=$::opt_size
\tBack=$::opt_back
\tStart=$::opt_start
\tTop=$::opt_top
\tCheck-Web=$::opt_ckweb
\tRefer=$::opt_refer
\tPrologue=$::opt_prolog
\tEpilogue=$::opt_epilog
X
Theme:
\tTheme=$theTheme_theme
\tImage=$theTheme_image
\tComment=$theTheme_comment
\tLatest=$max_mtime ($latestdate)
X
EOF
X foreach my $c (@contents) {
X if (exists $c->{ThemeDir}) {
X $content_db .= <<EOF;
$c->{ThemeDir}/
\tTheme=$c->{Theme}
\tImage=$c->{Image}
\tComment=$c->{Comment}
\tLatest=$c->{Mtime} ($c->{Ltime})
EOF
X } elsif (exists $c->{ThemeWeb}) {
X $content_db .= <<EOF;
$c->{ThemeWeb}
\tTheme=$c->{Theme}
\tImage=$c->{Image}
\tComment=$c->{Comment}
\tLatest=$c->{Mtime} ($c->{Ltime})
EOF
X } elsif (exists $c->{ImageFile}) {
X $content_db .= <<EOF;
$c->{ImageFile}
\tName=$c->{Name}
\tDate=$c->{Date}
\tComment=$c->{Comment}
EOF
X } else {
X die "!!BUG!! No theme nor Image found on \@contents : ";
X }
X }
X open(CFILE,">$CONTENT") || die "Cannot write on $pwd/$CONTENT : $!";
X print CFILE $content_db;
X close(CFILE);
X undef $content_db;
X warn "$pwd/$CONTENT is updated.\n" if $VERBOSE;
X
X ### Generate photo.html ###
X my $hml = $html_message{$::opt_lang};
X
X foreach my $c (@contents) {
X $c->{Comment} = sanitize_meta($c->{Comment})
X if exists $c->{Comment};
X foreach my $item (qw(ThemeWeb Theme Image URL Mtime Ltime
X theme_dir ImageFile Name Date)) {
X $c->{$item} = sanitize_meta($c->{$item},"No<br>")
X if exists $c->{$item};
X }
X }
X
X my $back;
X $back = 1 if $::opt_back eq "Yes"
X and $hml->{Back}
X and ($depth >= 2 or -r "../$HTML");
X
X $_ = $::opt_mail;
X if (/\$userid\b|\${userid}/i) {
X s/\$userid\b|\${userid}/$ENV{USER}/ig;
X }
X if (/\$fqdn\b|\${fqdn}/i) {
X my $m = $_; # save $_ for Net::Domain ver. 2.13
X my $f = hostfqdn();
X $_ = $m; # restore $_
X s/\$fqdn\b|\${fqdn}/$f/ig;
X }
X if (/\$domain\b|\${domain}/i) {
X my $m = $_; # save $_ for Net::Domain ver. 2.13
X my $d = hostdomain();
X $_ = $m; # restore $_
X s/\$domain\b|\${domain}/$d/ig;
X }
X $::opt_mail = $_;
X
X $_ = $::opt_uname;
X if (/^\$passwd$/i) {
X open(INP,"/etc/passwd") || die "Cannot read /etc/passwd : $!";
X while (<INP>) {
X next unless /^$ENV{USER}:/o;
X /[^:]*?:[^:]*?:[^:]*?:[^:]*?:([^:]*?)?:/;
X $_ = $1;
X s/,.*//s; # Full name of the user
X last;
X }
X close(INP);
X die "User name of \"$ENV{USER}\" is not found in /etc/passwd.\n"
X unless $_;
X }
X $_ = to_utf8({ -string => $_, -charset => $::opt_charset })
X if $::opt_charset;
X $::opt_uname = $_;
X
X
X for my $pe (\$::opt_prolog,\$::opt_epilog) {
X next unless $$pe;
X $$pe =~ s/\$uname\b|\${uname}/$::opt_uname/ig;
X $$pe =~ s/\$copyright\b|\${copyright}/$hml->{Copyright}/ig;
X if ($::opt_mail
X and $$pe =~ s(\$mail\b|\${mail})($::opt_mail)ig
X and $& eq '$Mail') {
X $$pe = sanitize_meta($$pe);
X $$pe =~ s/^\s+/\t /mg;
X $$pe = <<EOF;
X <address><a href="mailto:$::opt_mail">
\t<small>
\t$$pe
\t</small>
X </a></address>
EOF
X } else {
X $$pe =~ s/\s*<?\s*(\$Mail\b|\${Mail})\s*>?\s*/ /g;
X $$pe = sanitize_meta($$pe);
X $$pe = " <small>\n\t$$pe\n </small>";
X }
X }
X
X for my $p (\$theTheme_theme,\$theTheme_comment,\$theTheme_latest) {
X $$p = sanitize_meta($$p);
X }
X
X print "#",__LINE__,"# Generate $HTML\n" if $DEBUG;
X print "#",__LINE__,"# \$theTheme_image=`$theTheme_image'\n" if $DEBUG;
X $theTheme_image =~ s/\s.*//;
X my $html = "";
X $html = <<EOF;
<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 3.2 Final//EN">
<!-- This is generated by $PNAME (version $VERSION).
\tYou can get the latest version of mkphotohtml and it\'s documents
\tfrom following web page;
\t\t$WEBINFO
X -->
<html>
X <head>
X <META HTTP-EQUIV="Content-Type"
X CONTENT="text/html; charset=utf-8">
X <META NAME="GENERATOR" CONTENT="mkphotohtml V$VERSION">
X <META NAME="Keyword" CONTENT="mkphotohtml,Network Photo Album">
X <META NAME="Networkphotoalbum" CONTENT="$::opt_refer">
EOF
X $html .= <<EOF if $::opt_start eq "Yes";
X <link rel="start" href="$::opt_top">
EOF
X $html .= <<EOF if -r "../$HTML";
X <link rel="previous" href="../$HTML">
EOF
X $html .= <<EOF if $::opt_mail;
X <link rev="made" href="mailto:$::opt_mail">
EOF
X $html .= <<EOF;
X <title>$theTheme_theme</title>
X </head>
X <body>
X <center>
X <h1>$theTheme_theme</h1>
X <a href="$titleimage_N">
X <img src="$titleimage_H"
X $size_titleimage_H
X alt="Theme-image: $theTheme_image">
X </a><br>
X $theTheme_comment
X </center><br>
EOF
X $html .= <<EOF if $back;
X <a href="../$HTML">$hml->{Back}</a>
EOF
X $html .= <<EOF if $::opt_prolog;
X <hr>
X <center>
$::opt_prolog
X </center>
EOF
X $html .= <<EOF;
X <hr>
X <h1>$hml->{Album}</h1>
X $hml->{Comment}
X <br><br>
EOF
X while (my $c = shift @contents) {
X if (exists $c->{ThemeDir}) { # SubThemeDir
X my ($subtheme_image,$size_image,$info_dummy)
X = image_path("Index","$c->{ThemeDir}/$c->{Image}","size_required");
X my $date = ($c->{Ltime} ? $c->{Ltime} : ctime($c->{Mtime}));
X print "#",__LINE__,"# \$subtheme_image=$subtheme_image\n" if $DEBUG;
X $html .= <<EOF;
X <a href="$c->{ThemeDir}/$HTML">
X <img src="$subtheme_image"
X $size_image
X alt="$c->{ThemeDir}" align="left"></a>
X <font size="+2">$hml->{Theme}$c->{Theme}</font><br>
X <font size="-1">$hml->{Latest} $date</font><br>
X $c->{Comment}<br clear="left">
EOF
X } elsif (exists $c->{ThemeWeb}) { # Web theme
X unless ($c->{Image} =~ m(http://)) {
X $c->{Image} = $c->{URL} . $c->{Image};
X }
X my ($web_image,$size_image)
X = image_path("Index",$c->{Image},"size-required");
X my $date = ($c->{Ltime} ? $c->{Ltime} : ctime($c->{Mtime}));
X $html .= <<EOF;
X <a href="$c->{URL}$HTML">
X <img src="$web_image"
X $size_image
X alt="$c->{URL}" align="left"></a>
X <font size="+2">$hml->{WebTheme}$c->{Theme}</font><br>
X <font size="-1">$hml->{Latest} $date</font><br>
X $c->{Comment}<br clear="left">
EOF
X
X } elsif (exists $c->{ImageFile}) { # Image file
X $c->{ImageFile} =~ /(.*)(\.[^.]+)/;
X my ($base,$ext) = ($1,$2);
X my $ifile = image_path("Raw",$c->{ImageFile});
X my $imagefiles = "<a href=\"$ifile\" "
X . "title=\"$c->{ImageFile}\">$sorted_scale[0]</a>";
X for my $scale (@sorted_scale[1..$#sorted_scale]) {
X my $ifile = image_path($scale,$c->{ImageFile});
X $imagefiles .= "\n\t, <a href=\"$ifile\" "
X . "title=\"$c->{ImageFile}\">$scale</a>";
X }
X my $image_normal = image_path("Normal",$c->{ImageFile});
X my $image_index = image_path("Index", $c->{ImageFile});
X my $size_index = html_imgsize($image_index);
X $html .= <<EOF;
X <a href="$image_normal">
X <img src="$image_index"
X $size_index
X alt="$c->{ImageFile}" align="left"></a>
X <font size="-1">
X $hml->{Arrow} $imagefiles
X </font><br>
X <strong><font size="+1">$c->{Name}</font></strong><br>
X <font size="-1">$c->{Date}</font><br>
X $c->{Comment}<br clear="left">
EOF
X } else {
X die "!!BUG!! Broken \@contents";
X }
X }
X
X my $time = ctime();
X
X $html .= <<EOF;
X <hr>
EOF
X $html .= <<EOF if $back;
X <a href="../$HTML">$hml->{Back}</a>
EOF
X $html .= <<EOF if $::opt_epilog;
X <center>
$::opt_epilog
X </center>
X <hr>
EOF
X if ($::opt_uname and $::opt_mail) {
X $html .= <<EOF;
X <address><a href="mailto:$::opt_mail">
X $::opt_uname
X </a></address>
EOF
X }
X $html .= <<EOF;
X Last modified: $time
X </body>
</html>
EOF
X rename "$HTML", "$HTML.OLD" if -r $HTML;
X open(HTML,">$HTML") || die "Cannot write on $pwd/$HTML : $!";
X print HTML $html;
X close(HTML);
X warn "$pwd/$HTML is updated.\n" if $VERBOSE;
X }
X chdir $oldpwd;
X --$depth;
}
SHAR_EOF
(set 20 03 11 11 15 49 09 'mkphotohtml'; eval "$shar_touch") &&
chmod 0755 'mkphotohtml' ||
$echo 'restore of' 'mkphotohtml' 'failed'
if ( md5sum --help 2>&1 | grep 'sage: md5sum \[' ) >/dev/null 2>&1 \
&& ( md5sum --version 2>&1 | grep -v 'textutils 1.12' ) >/dev/null; then
md5sum -c << SHAR_EOF >/dev/null 2>&1 \
|| $echo 'mkphotohtml:' 'MD5 check failed'
de71286a0b82221ce44879b1bc184660 mkphotohtml
SHAR_EOF
else
shar_count="`LC_ALL= LC_CTYPE= LANG= wc -c < 'mkphotohtml'`"
test 68563 -eq "$shar_count" ||
$echo 'mkphotohtml:' 'original size' '68563,' 'current size' "$shar_count!"
fi
fi
rm -fr _sh01288
exit 0
Fnews-brouse 1.9(20180406) -- by Mizuno, MWE <mwe@ccsf.jp>
GnuPG Key ID = ECC8A735
GnuPG Key fingerprint = 9BE6 B9E9 55A5 A499 CD51 946E 9BDC 7870 ECC8 A735