143 lines
4.0 KiB
Perl
Executable File
143 lines
4.0 KiB
Perl
Executable File
#! /usr/bin/perl -w
|
|
# Emily Wu's Website
|
|
# last_update.cgi: The last-update date of the whole web site.
|
|
|
|
# Copyright (c) 2003-2021 imacat.
|
|
#
|
|
# Licensed under the Apache License, Version 2.0 (the "License");
|
|
# you may not use this file except in compliance with the License.
|
|
# You may obtain a copy of the License at
|
|
#
|
|
# http://www.apache.org/licenses/LICENSE-2.0
|
|
#
|
|
# Unless required by applicable law or agreed to in writing, software
|
|
# distributed under the License is distributed on an "AS IS" BASIS,
|
|
# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
|
|
# See the License for the specific language governing permissions and
|
|
# limitations under the License.
|
|
|
|
# Author: imacat <imacat@mail.imacat.idv.tw>
|
|
# First written: 2003-04-09
|
|
|
|
use 5.008;
|
|
use strict;
|
|
use warnings;
|
|
use lib $ENV{"DOCUMENT_ROOT"} . qw(/magicat/lib/perl5);
|
|
use Selima::emily;
|
|
local $SIG{"__DIE__"} = \&http_500;
|
|
my $d = new Selima::Destroy;
|
|
# Prototype declaration
|
|
sub main();
|
|
sub find_files_in(\@\@);
|
|
sub fmttime_local($);
|
|
sub html_image($);
|
|
|
|
use File::Spec;
|
|
use GD;
|
|
use IO::NestedCapture qw(CAPTURE_STDOUT);
|
|
|
|
use vars qw(@DIREXCS %RDIREXCS @FGCOLOR @BGCOLOR $FONT);
|
|
# Directories to be excluded (no leading and trailing slashes)
|
|
@DIREXCS = qw(magicat);
|
|
@FGCOLOR = (0, 0, 0); # #000000 Black
|
|
@BGCOLOR = (255, 255, 255); # #FFFFFF White
|
|
$FONT = gdLargeFont;
|
|
use constant TRANSPARENT => 1;
|
|
initenv( -allowed => [qw(GET HEAD)],
|
|
-session => 0,
|
|
-dbi => DBI_NONE,
|
|
-lastmod => 0,
|
|
-multilang => 0);
|
|
%RDIREXCS = map { File::Spec->catfile($DOC_ROOT, $_) => 1 } @DIREXCS;
|
|
|
|
main;
|
|
exit 0;
|
|
|
|
sub main() {
|
|
local ($_, %_);
|
|
my (@tables, @files);
|
|
|
|
@tables = qw();
|
|
@files = qw();
|
|
@_ = ($DOC_ROOT);
|
|
find_files_in(@files, @_);
|
|
http_304 if not_modified @tables, @files;
|
|
|
|
html_image($LAST_MODIFIED);
|
|
|
|
return;
|
|
}
|
|
|
|
# find_files_in: an easy file finder
|
|
sub find_files_in(\@\@) {
|
|
local ($_, %_);
|
|
my ($files, $dirs, @subdirs, $DH, $ent);
|
|
($files, $dirs) = @_;
|
|
|
|
# Bounce for nothing
|
|
return if scalar(@$dirs) == 0;
|
|
# Look in these directories
|
|
@subdirs = qw();
|
|
foreach my $dir (@$dirs) {
|
|
$dir =~ s/\/$//;
|
|
opendir $DH, $dir or die "$dir: $!";
|
|
while (defined($_ = readdir $DH)) {
|
|
next if /^\./;
|
|
# Using catfile() is better, but a lot slower
|
|
$ent = File::Spec->catfile($dir, $_);
|
|
#$ent = "$dir/$_";
|
|
if (-f $ent) {
|
|
push @$files, $ent;
|
|
} elsif (-d $ent) {
|
|
push @subdirs, $ent
|
|
if !exists $RDIREXCS{$ent};
|
|
}
|
|
}
|
|
closedir $DH or die "$dir: $!";
|
|
}
|
|
# Look in the subdirectories
|
|
find_files_in @$files, @subdirs;
|
|
return;
|
|
}
|
|
|
|
# fmttime_local: Format the time using my own format
|
|
sub fmttime_local($) {
|
|
@_ = localtime $_[0];
|
|
return sprintf "%d.%d.'%02d", $_[4]+1, $_[3], ($_[5]+1900) % 100;
|
|
}
|
|
|
|
# html_image: Make the image from the last-update value
|
|
sub html_image($) {
|
|
local $_;
|
|
my ($last_update, $image, $width, $height, $fgcolor, $bgcolor);
|
|
$last_update = $_[0];
|
|
|
|
# Format the date to my preferred format
|
|
$last_update = fmttime_local($last_update);
|
|
|
|
# Initialize the image object
|
|
# Get the width and height
|
|
$width = $FONT->width * (length $last_update);
|
|
$height = $FONT->height;
|
|
# Create an image object
|
|
$image = GD::Image->new($width, $height);
|
|
# Create the forground/background color objects
|
|
$fgcolor = $image->colorAllocate(@FGCOLOR);
|
|
$bgcolor = $image->colorAllocate(@BGCOLOR);
|
|
|
|
# Draw the image
|
|
# Set the transparent background
|
|
$image->transparent($bgcolor) if TRANSPARENT;
|
|
# Paint the background
|
|
$image->filledRectangle(0, 0, $width, $height, $bgcolor);
|
|
# Write the text
|
|
$image->string($FONT, 0, 0, $last_update, $fgcolor);
|
|
|
|
# Output
|
|
$CONTENT_TYPE = "image/png";
|
|
binmode IO::NestedCapture->instance->{"STDOUT_current"}[-1], ":raw";
|
|
print $image->png;
|
|
|
|
return;
|
|
}
|