Initial commit.

2026-03-10 21:25:26 +08:00
commit 78739bf725
3089 changed files with 472990 additions and 0 deletions
--- a/htdocs/wov/cgi-bin/counter.cgi
+++ b/htdocs/wov/cgi-bin/counter.cgi
@@ -0,0 +1,219 @@
+#! /usr/bin/perl -w
+# Woman's Voice
+# 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::wov;
+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/wov/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], ":raw";
+    $_ = $image->png;
+    print $_;
+    
+    return length $_;
+}
--- a/htdocs/wov/cgi-bin/last_update.cgi
+++ b/htdocs/wov/cgi-bin/last_update.cgi
@@ -0,0 +1,142 @@
+#! /usr/bin/perl -w
+# Woman's Voice
+# 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::wov;
+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 "%04d.%02d.%02d", $_[5]+1900, $_[4]+1, $_[3];
+}
+
+# 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;
+}
--- a/htdocs/wov/cgi-bin/mailto.cgi
+++ b/htdocs/wov/cgi-bin/mailto.cgi
@@ -0,0 +1,70 @@
+#! /usr/bin/perl -w
+# Woman's Voice
+# mailto.cgi: The e-mail hyperlink redirector.
+
+#  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-05-13
+
+use 5.008;
+use strict;
+use warnings;
+use lib $ENV{"DOCUMENT_ROOT"} . qw(/magicat/lib/perl5);
+use Selima::wov;
+local $SIG{"__DIE__"} = \&http_500;
+my $d = new Selima::Destroy;
+# Prototype declaration
+sub main();
+sub check_post();
+
+use Fcntl qw(:seek);
+
+initenv(-allowed    => [qw(POST)],
+        -session    => 0,
+        -dbi        => DBI_NONE,
+        -lastmod    => 0);
+
+main;
+exit 0;
+
+sub main() {
+    local ($_, %_);
+    my $error;
+    
+    # Only POSTed forms are allowed
+    $error = check_post;
+    # If an error occurs
+    if (defined $error) {
+        http_400;
+    
+    # Else, save the data
+    } else {
+        http_303 "mailto:" . $POST->param("email");
+    }
+    return;
+}
+
+# check_post: Check the POSTed form
+sub check_post() {
+    local ($_, %_);
+    my ($checker, $error);
+    # Run the checker
+    $checker = new Selima::Checker::MailTo(curform);
+    $error = $checker->check(qw(email));
+    return $error if defined $error;
+    # OK
+    return;
+}
--- a/htdocs/wov/cgi-bin/search.cgi
+++ b/htdocs/wov/cgi-bin/search.cgi
@@ -0,0 +1,56 @@
+#! /usr/bin/perl -w
+# Woman's Voice
+# search.cgi: The web site full-text search.
+
+#  Copyright (c) 2004-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: 2004-11-28
+
+use 5.008;
+use strict;
+use warnings;
+use lib $ENV{"DOCUMENT_ROOT"} . qw(/magicat/lib/perl5);
+use Selima::wov;
+local $SIG{"__DIE__"} = \&http_500;
+my $d = new Selima::Destroy;
+# Prototype declaration
+sub main();
+
+use Fcntl qw(:seek);
+
+initenv(-allowed    => [qw(GET HEAD)],
+        -session    => 0,
+        -dbi_lock   => {"nlarts"                => LOCK_SH,
+                        "newslets"              => LOCK_SH,
+                        "guestbook"             => LOCK_SH,
+                        "pages"                 => LOCK_SH,
+                        "links"                 => LOCK_SH},
+        -lastmod    => 1,
+        -page_param => {"keywords"      => N_("search, query, full text search")});
+
+main;
+exit 0;
+
+sub main() {
+    local ($_, %_);
+    my $LIST;
+    # List handler handles its own error
+    $LIST = new Selima::wov::List::Search;
+    html_header $LIST->{"title"}, $LIST->{"etitle"}, $LIST->page_param;
+    $LIST->html;
+    html_footer;
+    return;
+}