;#
;# Copyright (c) 1995-1997
;#	Ikuo Nakagawa. All rights reserved.
;#
;# Redistribution and use in source and binary forms, with or without
;# modification, are permitted provided that the following conditions
;# are met:
;#
;# 1. Redistributions of source code must retain the above copyright
;#    notice unmodified, this list of conditions, and the following
;#    disclaimer.
;# 2. Redistributions in binary form must reproduce the above copyright
;#    notice, this list of conditions and the following disclaimer in the
;#    documentation and/or other materials provided with the distribution.
;#
;# THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
;# ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
;# IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
;# PURPOSE ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS
;# BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY,
;# OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT
;# OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR
;# BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
;# WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE
;# OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE,
;# EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
;#
;# $Id: Cool.pm,v 1.12 1999/10/28 10:32:19 ikuo Exp $
;#
package Fan::Cool;

use strict;
use vars qw($VERSION @ISA @EXPORT
	$LOG %plog_level @nameofday @nameofmonth @daysofmonth
	@accept %escape $black_hole_begin $black_hole_end);

use Carp;
use POSIX qw(errno_h);
use AutoLoader 'AUTOLOAD';
require Exporter;

@ISA = qw(Exporter);
@EXPORT = qw(
	append mkdirhier rmdirhier plock encode decode
	plog plog_level plog_mask
	str4time str4date timezone isleap
	dayofweek daysofmonth nameofmonth lookup
);
$VERSION = '0.01';
$LOG = 5; # default is INFO

@plog_level{qw(EMERGE ALERT CRIT ERR WARNING NOTICE INFO DEBUG)} = (0..7);
@nameofday = qw(Sun Mon Tue Wed Thu Fri Sat);
@nameofmonth = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
@daysofmonth = qw(31 28 31 30 31 30 31 31 30 31 30 31);

;# for encoding charactors
@accept = ('*', '-', '.', '0'..'9', '@', 'A'..'Z', '_', 'a'..'z');
@escape{@accept} = @accept;

;# initialize @escape
for (my $i = 0; $i < 256; $i++) {
	my $c = pack("C", $i);
	defined($escape{$c}) || ($escape{$c} = sprintf("%%%02x", $i));
	$escape{' '} = '+';
}

;# for day counter
$black_hole_begin = &days(3, 9, 1752);
$black_hole_end = &days(14, 9, 1752);

;# prototypes are generated automatically by AutoSplit.
;# sub append (@);
;# sub mkdirhier ($$);
;# sub rmdirhier ($);
;# sub plog ($@);
;# sub plog_level ($);
;# sub plog_mask ($;$);
;# sub plock ($;$);
;# sub encode ;
;# sub decode ;
;# sub str4time (;$);
;# sub str4date (;$);
;# sub timezone ();
;# sub isleap (;$);
;# sub dayofyear ($$$);
;# sub days ($$$);
;# sub dayofweek ($$$);
;# sub daysofmonth ($;$);
;# sub nameofmonth ($);
;# sub lookup ($);

;# A special marker for AutoSplit.
1;
__END__

;# append(filename, string, string, ...);
;#	Append some data to specified file. This routine
;#	uses `plock' to lock output file.
;#
sub append (@) {
	local *FILE;
	my $file = shift;
	my $result =
		$file ne '' && ! -d $file	&&
		@_				&&
		plock("$file.LOCK")		&&
		open(FILE, ">>$file")		&&
		seek(FILE, 0, 2)		&&
		grep((print FILE), @_)		&&
		close(FILE) ? 1 : undef;
	unlink("$file.LOCK");
	$result;
}

;#
;# make directory hierachy
sub mkdirhier ($$) {
	my $dir = shift;
	my $mode = shift;
	my $d = $dir =~ s%^/+%% ? '' : '.';
	my $e;
	for $e (split('/', $dir)) {
		-d ($d .= '/'.$e) && next;
		unlink($d); # ignore result
		mkdir($d, $mode) || return undef;
	}
	1;
}

;# remove directory recursively
sub rmdirhier ($) {
	my $dir = shift;

	# force to remove even if target is not a directory.
	return unlink($dir) if -l $dir || ! -d _;

	# try to open the target directory, and...
	local *DIR;
	opendir(DIR, $dir) || return undef;

	# search directory entires in this directory.
	my $e;
	while (defined($e = readdir(DIR))) {
		# rmdirhier can remove non-directory file.
		rmdirhier("$dir/$e") if $e ne '.' && $e ne '..';
	}
	closedir(DIR);
	rmdir($dir); # the result value is that of rmdir.
}

;#
;# Usage: plog(level, string, string, ...);
;#
;#
sub plog ($@) {
	# determin logging level...
	my $level = shift;
	if ($level !~ /^\d+$/) {
		$level = &plog_level($level);
	}

	# calculate log mask.
	my $mask;
	{ # We can't use ${$string} in `use strict'.
		no strict 'refs';
		$mask = ${(caller)[$[].'::LOG'} || $LOG;
	}

	# only if specified log level is less or equal to mask.
	if ($level <= $mask) {
		local $_;	# used in grep
		grep((print STDERR $_), @_);
	}

	# always success
	1;
}

;# Convert log name to level
;# For example, plog_level('INFO') returns 6.
;#
sub plog_level ($) {
	my $lv = uc(shift);

	$lv =~ /^\d+$/ ? $lv :
		exists($plog_level{$lv}) ? $plog_level{$lv} : $LOG;
}

;# Setting up log masks for generic modules.
;# For example, plog_mask("FTP=7,TCP,Scan", 6) causes
;#	$FTP::LOG = 7;
;#	$TCP::LOG = 6;
;#	$Scan::LOG = 6;
;#
sub plog_mask ($;$) {
	my @packages = split(/[,\s]+/, shift);
	my $lv = @_ ? plog_level(shift): $LOG; # default is $LOG.
	for my $str (@packages) {
		my($pack, $level) = $str =~ /=/
			? ($`, plog_level($')) : ($str, $lv);
		if ($pack ne '') {
			no strict 'refs';
			${$pack."::LOG"} = $level;
		}
	}
}

;#
;# Usage: plock($filename, $timeout)
;#
;# An implementation of a lock mechanizem. `plock' uses `link'
;# function to lock a file, but uses no flock/lockf functions.
;# Second argument $timeout means how long seconds you may wait
;# until get lock. The default value of $timeout is 10[sec].
;#
sub plock ($;$) {
	my $file = shift;
	my $tt = @_ ? shift : 0;
	my $res = 0;
	local *FILE;

	;# generate temporary filename
	my $temp = $file;
	$temp =~ s,[^/]+$,.LOCK.$$, || return undef;

	;# check timeout value
	$tt = 10 if $tt < 1;

	;# make sure that temporary file does not exist
	for (; -e $temp && !unlink($temp) && $tt > 0; $tt--) {
		sleep(1);
	}

	;# create temporary file with process id
	$tt > 0 && open(FILE, ">$temp")
		&& (print FILE "$$\n")
		&& close(FILE)
		or unlink($temp), return undef;

	;# link it to target file
	for (; !($res = link($temp, $file)) && $tt > 0; $tt--) {
		my $pid;

		if (open(FILE, $file)
		     && chomp($pid = <FILE>)
		     && close(FILE)
		     && $pid =~ /^\d+$/) { # Got pid!
			if (kill(0, $pid)) { # Success to kill
				sleep(1); # wait a second
			} elsif (ESRCH != $!) {
				last; # permission denied? or other errors
			} else {
				unlink($file); sleep(1); # no need to sleep?
			}
		} else {
			unlink($file); sleep(1); # no need to sleep?
		}
	}

	;# unlink temporary file
	unlink($temp);

	;# result - success if link succeeded
	return $res;
}

;#
sub encode ($) {
	$_ = shift;
	s/./$escape{$&}/g;
	$_;
}

;#
sub decode ($) {
	$_ = shift;
	s/\+/ /go;
	s/%(..)/pack("H*", $1)/eg;
	$_;
}

;#
;# generate time string, like "12:34:56", for given UTC time.
;# If $time is omitted, `str4time' returns a time string for the
;# current time.
;#
sub str4time (;$) {
	sprintf("%02d:%02d:%02d", reverse((localtime(shift || time))[0..2]));
}

;#
;# Usage: &str4data($time);
;#
;# Generate date string, like "1993-03-14", for given UTC time.
;# If $time is omitted, `str4date' returns a data string for the
;# current time.
;#
sub str4date (;$) {
	my($d, $m, $y) = (localtime(shift || time))[3..5];
	sprintf("%04d-%02d-%02d", $y + 1900, $m + 1, $d);
}

;#
;# Usage: &timezone
;#
;# Find local timezone like "+0900" or "GMT".
;# To calculate timezone, we use UTC clock of `946684800'
;# which means "2000-01-01 00:00:00".
;#
sub timezone () {
	local($[); # for zero-based array
	my($sec, $min, $hour, $day, $mon, $year) = localtime(946684800);
	my $sign = '+';
	my $offset = $hour * 60 + $min;

	if ($year == 99) {
		$sign = '-';
		$offset = 24 * 60 - $offset;
	}
	$offset++ if $offset % 10;
	return 'GMT' if !$offset;
	return $sign.'2359' if $offset >= 24 * 60;
	$sign.sprintf("%02d%02d", $offset / 60, $offset % 60);
}

;#
;# Usage: isleap($year);
;#	where $year is optional.
;#
sub isleap (;$) {
	my($y) = @_ ? shift : (localtime)[5] + 1900;

	$y <= 1752 ? !($y % 4) : !($y % 4) && ($y % 100) || !($y % 400);
}

;#
;#
sub dayofyear ($$$) {
	my($day, $month, $year) = @_;
	my $i;

	$day++ if $month > 2 && &isleap($year);
	for ($i = 1; $i < $month; $i++) {
		$day += $daysofmonth[$i - 1];
	}
	$day;
}

;#
;#
sub days ($$$) {
	my($day, $month, $year) = @_;
	my $days = &dayofyear($day, $month, $year);
	my $y = $year - 1;
	my $leap_years = int($y / 4)
		- ($y > 1700 ? int($y / 100) - 17 : 0)
		+ ($y > 1600 ? int(($y - 1600) / 400) : 0);
	$days += $y * 365 + $leap_years;
}

;#
sub dayofweek ($$$) {
	my $yday = &days(@_);
	$yday < $black_hole_begin ? ($yday + 5) % 7 :
	$yday > $black_hole_end ? ($yday + 1) % 7 : 6;
}

;#
sub daysofmonth ($;$) {
	my $m = shift;
	my $y = shift;
	my $d = defined($daysofmonth[$m]) ? $daysofmonth[$m] : undef;
	$d++ if $y =~ /^\d+$/ && &isleap($y) && $m == 1;
	$d;
}

;#
sub nameofmonth ($) {
	my $m = shift;

	defined($nameofmonth[$m]) ? $nameofmonth[$m] : undef;
}

;#
;# lookup a pathname
;# convert:
;#	1. "abc//xyz" to "abc/xyz"
;#	2. "abc/./xyz" to "abc/xyz"
;#	3. "abc/foo/../xyz" to "abc/syz"
;# NOTES:
;#	This routine may be very slow... :-<
;#	Would anybody rewrite this code?
;#
sub lookup ($) {
	local $_ = shift;

	# null string is assumed as the current directory.
	$_ = '.' if $_ eq '';

	# most of simple case...
	return $_ if !/\//;

	# try to convert pathname.
	$_ .= '/';			# add trailing slash
	s|/+|/|go;			# foo//bar -> foo/bar
	my $absolute = s|^/||;		# 1 if $_ is a absolute path
	$_ = '/'.$_;			# for convinience
	1 while s|/\./|/|go;		# foo/./bar -> foo/bar

	# try main loop.
	my $tmp;
	do {	# xyz/foo/../bar -> xyz/bar
		$tmp = $_;
		s|([^/]+)/\.\./|$1 eq '..' ? '../../' : ''|geo;
	} while ($tmp ne $_) ;

	# aftercare
	s|^/|| if !$absolute;
	s|/+$|| if $_ ne '/';
	$_ = '.' if $_ eq '';
	$_;
}

;# end of Fan::Cool module