220 lines
6.7 KiB
Perl
Executable File
220 lines
6.7 KiB
Perl
Executable File
#! /usr/bin/perl -w
|
|
# Emily Wu's Website
|
|
# counter.cgi: The visitor counter.
|
|
|
|
# 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-07
|
|
|
|
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 dont_update();
|
|
sub read_counter();
|
|
sub update_counter();
|
|
sub log_visitor($);
|
|
sub counter_cookie();
|
|
sub html_image($);
|
|
|
|
use Fcntl qw(:seek);
|
|
use Date::Format qw(time2str);
|
|
use GD;
|
|
use IO::NestedCapture qw(CAPTURE_STDOUT);
|
|
use Net::CIDR::Lite qw();
|
|
|
|
use constant DATA_FILE => $ENV{"DOCUMENT_ROOT"} . "/magicat/data/counter.dat";
|
|
use constant LOG_FILE => "/var/log/apache2/emily/counter.log";
|
|
use vars qw($OUR_NETWORKS @FGCOLOR @BGCOLOR $FONT);
|
|
# People in our networks will not be counted
|
|
$OUR_NETWORKS = Net::CIDR::Lite->new(
|
|
qw(127.0.0.1/8 10.0.0.0/8 211.20.30.96/29));
|
|
@FGCOLOR = (0, 0, 0); # #000000 Black
|
|
@BGCOLOR = (255, 255, 255); # #FFFFFF White
|
|
$FONT = gdLargeFont;
|
|
use constant TRANSPARENT => 1;
|
|
use constant COOKIE_NAME => "counter";
|
|
use constant COUNT_ARG => "countme";
|
|
use constant IGNORE_ARG => "ignoreme";
|
|
initenv( -allowed => [qw(GET HEAD)],
|
|
-session => 0,
|
|
-dbi => DBI_NONE,
|
|
-lastmod => 0,
|
|
-multilang => 0);
|
|
|
|
main;
|
|
exit 0;
|
|
|
|
sub main() {
|
|
local ($_, %_);
|
|
|
|
# If we should not update the counter
|
|
if (dont_update) {
|
|
# Check last-modified here
|
|
my (@tables, @files);
|
|
@tables = qw();
|
|
@files = (DATA_FILE);
|
|
http_304 if not_modified @tables, @files;
|
|
html_image read_counter;
|
|
|
|
# Update the counter
|
|
} else {
|
|
$_ = html_image update_counter;
|
|
# Log the visitor
|
|
log_visitor $_;
|
|
}
|
|
|
|
# Set the counter cookie
|
|
$NEWCOOKIES{COOKIE_NAME()} = $_ if defined ($_ = counter_cookie);
|
|
|
|
return;
|
|
}
|
|
|
|
# dont_update: If we should not update the counter
|
|
sub dont_update() {
|
|
local ($_, %_);
|
|
# Find any reason that we should not update the counter
|
|
# If this visitor came from our own network
|
|
return 1 if $OUR_NETWORKS->find($ENV{"REMOTE_ADDR"});
|
|
# If this visitor had been counted
|
|
return 1 if exists $COOKIES{COOKIE_NAME()};
|
|
# If we are not told to count this visitor
|
|
return 1 if !defined $GET->param(COUNT_ARG);
|
|
# Well, update it
|
|
return 0;
|
|
}
|
|
|
|
# read_counter: Read the counter
|
|
sub read_counter() {
|
|
return -s DATA_FILE? xfread DATA_FILE: 0;
|
|
}
|
|
|
|
# update_counter: Update the counter
|
|
sub update_counter() {
|
|
local ($_, %_);
|
|
# File exists
|
|
if (-s DATA_FILE) {
|
|
my $FH;
|
|
open $FH, "+<", DATA_FILE or http_500 DATA_FILE . ": $!";
|
|
flock $FH, LOCK_EX or http_500 DATA_FILE . ": $!";
|
|
$_ = <$FH>;
|
|
$_++;
|
|
seek $FH, 0, SEEK_SET or http_500 DATA_FILE . ": $!";
|
|
truncate $FH, 0 or http_500 DATA_FILE . ": $!";
|
|
print $FH $_ or http_500 DATA_FILE . ": $!";
|
|
flock $FH, LOCK_UN or http_500 DATA_FILE . ": $!";
|
|
close $FH or http_500 DATA_FILE . ": $!";
|
|
|
|
# Not exists or zero sized -- create a new one
|
|
} else {
|
|
xfwrite DATA_FILE, ($_ = 1);
|
|
}
|
|
return $_;
|
|
}
|
|
|
|
# log_visitor: Log the visitor
|
|
sub log_visitor($) {
|
|
local ($_, %_);
|
|
my ($host, $user, $date, $uri, $size, $referer, $ua, $langs, $FD);
|
|
$size = $_[0];
|
|
|
|
# Gather the infomation to log
|
|
$host = (defined remote_host)? remote_host: $ENV{"REMOTE_ADDR"};
|
|
$user = (exists $ENV{"REMOTE_USER"} && $ENV{"REMOTE_USER"} ne "")?
|
|
$ENV{"REMOTE_USER"}: "-";
|
|
$date = time2str("%d/%b/%Y:%T %z", time);
|
|
$uri = $REQUEST_URI;
|
|
$referer = (exists $ENV{"HTTP_REFERER"} && $ENV{"HTTP_REFERER"} ne "")?
|
|
$ENV{"HTTP_REFERER"}: "-";
|
|
$ua = (exists $ENV{"HTTP_USER_AGENT"} && $ENV{"HTTP_USER_AGENT"} ne "")?
|
|
$ENV{"HTTP_USER_AGENT"}: "=";
|
|
$langs = (exists $ENV{"HTTP_ACCEPT_LANGUAGE"} && $ENV{"HTTP_ACCEPT_LANGUAGE"} ne "")?
|
|
$ENV{"HTTP_ACCEPT_LANGUAGE"}: "-";
|
|
|
|
# Compose the log record 組合紀錄行
|
|
$_ = sprintf "%s - %s [%s] \"%s %s %s\" 200 %s \"%s\" \"%s\" \"%s\" %s %s\n",
|
|
$host, $user, $date, $ENV{"REQUEST_METHOD"}, $uri,
|
|
$ENV{"SERVER_PROTOCOL"}, $size, $referer, $ua, $langs,
|
|
$ENV{"REMOTE_ADDR"}, country_lookup($ENV{"REMOTE_ADDR"});
|
|
|
|
# Save the log record 儲存記錄
|
|
xfappend LOG_FILE, $_;
|
|
|
|
return;
|
|
}
|
|
|
|
# counter_cookie: Set the counter cookie
|
|
sub counter_cookie() {
|
|
local ($_, %_);
|
|
# Leave our network alone
|
|
return if $OUR_NETWORKS->find($ENV{"REMOTE_ADDR"});
|
|
# Already set
|
|
return if exists $COOKIES{COOKIE_NAME()};
|
|
# Count me
|
|
return new CGI::Cookie( -name=>COOKIE_NAME,
|
|
-value=>"counted",
|
|
-path=>$REQUEST_PATH)
|
|
if defined $GET->param(COUNT_ARG);
|
|
# Ignore me
|
|
return new CGI::Cookie( -name=>COOKIE_NAME,
|
|
-value=>"ignored",
|
|
-path=>$REQUEST_PATH)
|
|
if defined $GET->param(IGNORE_ARG);
|
|
# Leave it alone
|
|
return;
|
|
}
|
|
|
|
# html_image: Make the image from the counter value
|
|
sub html_image($) {
|
|
local $_;
|
|
my ($counter, $image, $width, $height, $fgcolor, $bgcolor);
|
|
$counter = $_[0];
|
|
|
|
# Group the counter with commas at thousand digits.
|
|
$counter = fmtno($counter);
|
|
|
|
# Initialize the image object
|
|
# Get the width and height
|
|
$width = $FONT->width * (length $counter);
|
|
$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, $counter, $fgcolor);
|
|
|
|
# Output
|
|
$CONTENT_TYPE = "image/png";
|
|
binmode IO::NestedCapture->instance->{"STDOUT_current"}[-1];
|
|
$_ = $image->png;
|
|
print $_;
|
|
|
|
return length $_;
|
|
}
|