Fwd: Re: (RADIATOR) sub append (Util.pm, v 2.19.1)
Mike McCauley
mikem at open.com.au
Sun Apr 21 20:53:42 CDT 2002
Hello Sergey,
Thanks for the suggestion.
Attached is a new Util.pm that implements your suggestion both for LogFile
and for AcctLogFileName etc.
Please let me know if its OK for you and we wil roll it in to the next
release.
Cheers.
On Tue, 23 Apr 2002 01:54, Mike McCauley wrote:
> ---------- Forwarded Message ----------
>
> Subject: Re: (RADIATOR) sub append (Util.pm, v 2.19.1)
> Date: Sat, 20 Apr 2002 11:01:41 +1000
> From: Hugh Irvine <hugh at open.com.au>
> To: "Sergey Y. Afonin" <asy at kraft-s.ru>, <radiator at open.com.au>
> Cc: mikem at open.com.au
>
> Hello Sergey -
>
> Thanks for the suggestion.
>
> I have copied Mike on this mail and he will look at it next week.
>
> regards
>
> Hugh
>
> On Fri, 19 Apr 2002 22:27, Sergey Y. Afonin wrote:
> > Hello.
> >
> > What do you think about this replace for "append" ?
> >
> > sub append
> > {
> > my ($file, $line) = @_;
> >
> > if ( substr($file, 0, 1) eq "|" ) {
> > open(FILE, "$file") || return;
> > }
> > else {
> > open(FILE, ">>$file") || return;
> > }
> > print FILE $line;
> > close(FILE) || return;
> > return 1;
> > }
> >
> > It's allow write some logs to STDIN of external programs...
> > For example:
> > PasswordLogFileName |/etc/radiator/logpwd
--
Mike McCauley mikem at open.com.au
Open System Consultants Pty. Ltd Unix, Perl, Motif, C++, WWW
24 Bateman St Hampton, VIC 3188 Australia http://www.open.com.au
Phone +61 3 9598-0985 Fax +61 3 9598-0955
Radiator: the most portable, flexible and configurable RADIUS server
anywhere. SQL, proxy, DBM, files, LDAP, NIS+, password, NT, Emerald,
Platypus, Freeside, TACACS+, PAM, external, Active Directory etc etc
on Unix, Win95/8, 2000, NT, MacOS 9, MacOS X etc etc
-------------- next part --------------
# Util.pm
#
# Utility routines required by Radiator
# Author: Mike McCauley (mikem at open.com.au),
# strftime and friends based on code by David Muir Sharnoff
# <muir at idiom.com> in CTime.pm. Source code provided on request.
# $Id: Util.pm,v 1.25 2002/03/24 23:07:49 mikem Exp mikem $
package Radius::Util;
use Digest::MD5;
use Socket;
use File::Path;
use File::Basename;
use strict;
# This is the official Radiator version number:
$main::VERSION = '3.0';
# For md5crypt
my $magic = '$1$'; # The prefix that signals an md5 password
my @itoa64 = split(//,
'./0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz');
# Temp variables, used by format_special
my (@time, @ptime, $ptime, $cpacket, $rpacket);
# Private arrays for date calculations
my @DoW = qw(Sun Mon Tue Wed Thu Fri Sat);
my @DayOfWeek = qw(Sunday Monday Tuesday Wednesday Thursday
Friday Saturday);
my @MoY = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
my @MonthOfYear = qw(January February March April May June
July August September October November December);
my %tzn_cache;
# These are the conversion functions for format_special
my %conversions =
(
'%', sub { '%' },
'a', sub { return unless $rpacket;
$rpacket->getAttrByNum($Radius::Radius::FRAMED_IP_ADDRESS) },
'c', sub { return unless $cpacket;
my @l = Socket::unpack_sockaddr_in($cpacket->{RecvFrom});
Socket::inet_ntoa($l[1]) },
'C', sub { return unless $cpacket;
my @l = Socket::unpack_sockaddr_in($cpacket->{RecvFrom});
my $a = scalar gethostbyaddr($l[1], Socket::AF_INET);
return $a ? $a : Socket::inet_ntoa($l[1])},
'D', sub { $main::config->{DbDir} },
'h', sub { $main::hostname },
'L', sub { $main::config->{LogDir} },
'N', sub { return unless $cpacket; $cpacket->getNasId() },
'n', sub { return unless $cpacket; $cpacket->getAttrByNum($Radius::Radius::USER_NAME) },
'r', sub { "\n" },
'R', sub { return unless $cpacket; my @n = split(/@/, $cpacket->getAttrByNum($Radius::Radius::USER_NAME)); $n[1] },
'T', sub { return unless $cpacket; $cpacket->code },
'U', sub { return unless $cpacket; my @n = split(/@/,
$cpacket->getAttrByNum($Radius::Radius::USER_NAME)); $n[0] },
'u', sub { return unless $cpacket; $cpacket->{OriginalUserName} },
'P', sub { return unless $cpacket; $cpacket->decodedPassword() },
'z', sub { return unless $cpacket; MD5->hexhash($cpacket->getAttrByNum($Radius::Radius::USER_NAME))},
# From current time
'd', sub { @time = localtime(time) unless @time; sprintf("%02d", $time[3]) },
'H', sub { @time = localtime(time) unless @time; sprintf("%02d", $time[2]) },
'l', sub { scalar localtime(time)},
'm', sub { @time = localtime(time) unless @time; sprintf("%02d", $time[4]+1); },
'M', sub { @time = localtime(time) unless @time; sprintf("%02d", $time[1]) },
's', sub { require Time::HiRes; (&Time::HiRes::gettimeofday())[1] },
'S', sub { @time = localtime(time) unless @time; sprintf("%02d", $time[0]) },
't', sub { time },
'y', sub { @time = localtime(time) unless @time; sprintf("%02d", $time[5] % 100); },
'Y', sub { @time = localtime(time) unless @time; $time[5]+1900 }, # Correct Y2K behaviour for perl
'q', sub { @time = localtime(time) unless @time; $DoW[$time[6]] },
'Q', sub { @time = localtime(time) unless @time; $DayOfWeek[$time[6]] },
'v', sub { @time = localtime(time) unless @time; $MoY[$time[4]] },
'V', sub { @time = localtime(time) unless @time; $MonthOfYear[$time[4]] },
# Times from Timestamp in the current packet (if any)
'b', sub { $ptime },
'o', sub { return unless $ptime; scalar localtime($ptime)},
'e', sub { return unless $ptime; @ptime = localtime($ptime); sprintf("%02d", $ptime[5] % 100); },
'f', sub { return unless $ptime; @ptime = localtime($ptime); $ptime[5] + 1900 }, # Correct Y2K behaviour for perl
'g', sub { return unless $ptime; @ptime = localtime($ptime); sprintf("%02d", $ptime[4] + 1); },
'i', sub { return unless $ptime; @ptime = localtime($ptime); sprintf("%02d", $ptime[3]) },
'j', sub { return unless $ptime; @ptime = localtime($ptime); $ptime[2] },
'k', sub { return unless $ptime; @ptime = localtime($ptime); $ptime[1] },
'p', sub { return unless $ptime; @ptime = localtime($ptime); $ptime[0] },
);
my %strftime_conversion =
(
'%', sub { '%' },
'a', sub { $DoW[$time[6]] },
'A', sub { $DayOfWeek[$time[6]] },
'b', sub { $MoY[$time[4]] },
'B', sub { $MonthOfYear[$time[4]] },
'c', sub { asctime_n(@time, '') },
'd', sub { sprintf("%02d", $time[3]); },
'D', sub { sprintf("%02d/%02d/%02d", $time[4]+1, $time[3], $time[5]%100) },
'e', sub { sprintf("%2d", $time[3]); },
'h', sub { $MoY[$time[4]] },
'H', sub { sprintf("%02d", $time[2]) },
'I', sub { sprintf("%02d", $time[2] % 12 || 12) },
'j', sub { sprintf("%03d", $time[7] + 1) },
'k', sub { sprintf("%2d", $time[2]); },
'l', sub { sprintf("%2d", $time[2] % 12 || 12) },
'm', sub { sprintf("%02d", $time[4]+1); },
'M', sub { sprintf("%02d", $time[1]) },
'n', sub { "\n" },
'o', sub { sprintf("%d%s", $time[3], (($time[3] < 20 && $time[3] > 3) ? 'th' : ($time[3]%10 == 1 ? "st" : ($time[3]%10 == 2 ? "nd" : ($time[3]%10 == 3 ? "rd" : "th"))))) },
'p', sub { $time[2] > 11 ? "PM" : "AM" },
'r', sub { sprintf("%02d:%02d:%02d %s", $time[2] % 12 || 12, $time[1], $time[0], $time[2] > 11 ? 'PM' : 'AM') },
'R', sub { sprintf("%02d:%02d", $time[2], $time[1]) },
'S', sub { sprintf("%02d", $time[0]) },
't', sub { "\t" },
'T', sub { sprintf("%02d:%02d:%02d", $time[2], $time[1], $time[0]) },
'U', sub { wkyr(0, $time[6], $time[7])},
'w', sub { $time[6] },
'W', sub { wkyr(1, $time[6], $time[7]) },
'y', sub { $time[5]%100 },
'Y', sub { $time[5]%100 + ( $time[5]%100<70 ? 2000 : 1900) },
'x', sub { sprintf("%02d/%02d/%02d", $time[4] + 1, $time[3], $time[5] % 100) },
'X', sub { sprintf("%02d:%02d:%02d", $time[2], $time[1], $time[0]) },
'Z', sub { &tz2zone(undef,undef,$time[8]) }
);
# Converts a month name into a 0 based month number
my %months =
(
'Jan', 0, 'January', 0,
'Feb', 1, 'February', 1,
'Mar', 2, 'March', 2,
'Apr', 3, 'April', 3,
'May', 4,
'Jun', 5, 'June', 5,
'Jul', 6, 'July', 6,
'Aug', 7, 'August', 7,
'Sep', 8, 'September', 8,
'Oct', 9, 'October', 9,
'Nov', 10, 'November', 10,
'Dec', 11, 'December', 11,
);
#####################################################################
# This is an implementation of Linux compatible MD5 password encryption
# A transliterations of crypt(pw, salt) in crypt.c in libcrypt
sub md5crypt
{
my ($pw, $salt) = @_;
# If the salt is in an encrypted password, then
# extract the true salt from it
$salt = $1 if ($salt =~ /\$1\$([^\$]{0,8})\$(.*)/);
# Start with pw,magic,salt
my $s1 = $pw . $magic . $salt;
# Then just as many characters of the MD5(pw,salt,pw)
my $final = Digest::MD5::md5($pw . $salt . $pw);
my ($pl, $i, $s3);
for ($pl = length($pw); $pl > 0; $pl -= 16)
{
$s1 .= substr($final, 0, $pl > 16 ? 16 : $pl);
}
# Then something really weird...
for ($pl = length($pw); $pl; $pl >>=1)
{
$s1 .= substr($pl & 1 ? "\0" : $pw, 0, 1);
}
$final = Digest::MD5::md5($s1);
# This algorithm is deliberately slow :-(
for ($i = 0; $i < 1000; $i++)
{
$s3 = $i & 1 ? $pw : $final;
$s3 .= $salt if $i % 3;
$s3 .= $pw if $i % 7;
$s3 .= $i & 1 ? $final : $pw;
$final = Digest::MD5::md5($s3);
}
# Split $final into 16 bytes
my @final = unpack('C16', $final);
my $result = $magic . $salt . '$';
# Convert groups of 3 bytes into 4 ascii chars
$result .= &to64($final[0]<<16 | $final[6]<<8 | $final[12], 4);
$result .= &to64($final[1]<<16 | $final[7]<<8 | $final[13], 4);
$result .= &to64($final[2]<<16 | $final[8]<<8 | $final[14], 4);
$result .= &to64($final[3]<<16 | $final[9]<<8 | $final[15], 4);
$result .= &to64($final[4]<<16 | $final[10]<<8 | $final[5], 4);
$result .= &to64($final[11], 2);
return $result;
}
# Convert binary value into n chars from the set itoa64
sub to64
{
my ($value, $n) = @_;
my $result;
while (--$n >= 0)
{
$result .= $itoa64[$value & 0x3f];
$value >>= 6;
}
return $result;
}
#####################################################################
# Parse a date in the format Dec 04 1996, returns the time
# of midnight at the beginning of that day
sub parseDate
{
my ($date) = @_;
# print "parseDate: $date\n";
# It would be really cool to use the DateParse module here
# and accept lots of different formats (including relative)
if ($date =~ /([A-Za-z]{3})\s*(\d{1,2}),?\s+(\d{2,4})/)
{
# MMM dd yy(yy)
my $mon = $months{$1};
my $year = $3;
# Follow Perl standards for Y2K compliance
$year -= 1900 if $year > 1900;
$year += 100 if $year <= 37;
# Dates way in the future are clamped to perls limit
# of about 2037
$year = 137 if $year > 137;
return &main::timelocal(0, 0, 0, $2, $mon, $year);
}
elsif ($date =~ /(\d{4})-(\d{2})-(\d{2})/)
{
# yyyy-mm-dd
my $year = $1;
# Follow Perl standards for Y2K compliance
$year -= 1900 if $year > 1900;
$year += 100 if $year <= 37;
# Dates way in the future are clamped to perls limit
# of about 2037
$year = 137 if $year > 137;
# Gag: FreeTDS has a bug that sometimes causes days == 0
# eg, '12-31-1999 12:01:01.000' -> '2000-01-00 12:01:01',
my $day = $3;
$day = 1 if $day <= 0;
return &main::timelocal(0, 0, 0, $day, $2-1, $year);
}
elsif ($date =~ /(\d{2})\/(\d{2})\/(\d{2,4})/)
{
# dd/mm/yy(yy)
my $year = $3;
# Follow Perl standards for Y2K compliance
$year -= 1900 if $year > 1900;
$year += 100 if $year <= 37;
# Dates way in the future are clamped to perls limit
# of about 2037
$year = 137 if $year > 137;
return &main::timelocal(0, 0, 0, $1, $2-1, $year);
}
elsif ($date =~ /\d{9,10}/)
{
# Unix epoch seconds integer
return int $date;
}
else
{
&main::log($main::LOG_WARNING, "Bad date format: '$date'");
return 0;
}
}
#####################################################################
# Parse a time in the format 22:11 or 9:05 AM, returns the seconds
# since midnight of the time
sub parseTime
{
my ($time) = @_;
if ($time =~ /(\d{1,2}):(\d{1,2})\s*(.*)/)
{
my ($hours, $mins, $meridian) = ($1, $2, $3);
$hours += 12 if $meridian =~ /pm/i && $hours <= 11;
$hours -= 12 if $meridian =~ /am/i && $hours == 12;
return (($hours * 60) + $mins) * 60;
}
else
{
&main::log($main::LOG_WARNING, "Bad time format: '$time'");
return 0;
}
}
#####################################################################
# Format a string with a number of special replacements, useful for
# creating filenames at runtime.
# inspired by CTime.pm by David Muir Sharnoff <muir at idiom.com>.
# $dummy is an historical artifact, used to be the current reply packet
# which is now available in $current_packet->{rp}
# @extras will be available as %0, %1 etc
sub format_special
{
my ($s, $p, $dummy, @extras) = @_;
# Global variables so the conversion functions will see them
@time = @ptime = ();
$ptime = $rpacket = undef;
$cpacket = $p;
$rpacket = $p->{rp} if $p;
$ptime = $p->get_attr('Timestamp') if $p;
# Need to convert single character % formats _and_ positional args all
# in one go, else may get unpleasant interactions, especially when the
# the resulting string contains a %
$s =~ s/%([%abcCdDefghHijklLmMNopqQnPrRsStTUuvVyYz]|\d+)/{my $a = $1; $a =~ m@^\d@ ? $extras[$a] : &{$conversions{$a}}()}/egs;
$s =~ s/%\{GlobalVar:([^{]+)\}/{&main::getVariable($1)}/egs;
$s =~ s/%\{Reply:([^{]+)\}/{$rpacket ? $rpacket->get_attr($1) : ''}/egs;
$s =~ s/%\{Client:([^{]+)\}/{$p ? $p->{Client}{$1} : ''}/egs;
$s =~ s/%\{Handler:([^{]+)\}/{$p ? $p->{Handler}{$1} : ''}/egs;
$s =~ s/%\{Eval:([^{]+)\}/{eval($1)}/egs;
$s =~ s/%\{([^{]+)\}/{$p ? $p->get_attr($1) : ''}/egs;
return $s;
}
#####################################################################
# Format a date/time using conventional strftime
# conversions
sub tz2zone
{
my($TZ, $time, $isdst) = @_;
$TZ = defined($ENV{'TZ'}) ? ( $ENV{'TZ'} ? $ENV{'TZ'} : 'GMT' ) : ''
unless $TZ;
# Hack to deal with 'PST8PDT' format of TZ
# Note that this can't deal with all the esoteric forms, but it
# does recognize the most common: [:]STDoff[DST[off][,rule]]
if (! defined $isdst) {
my $j;
$time = time() unless $time;
($j, $j, $j, $j, $j, $j, $j, $j, $isdst) = localtime($time);
}
if (defined $tzn_cache{$TZ}->[$isdst]) {
return $tzn_cache{$TZ}->[$isdst];
}
if ($TZ =~ /^
( [^:\d+\-,] {3,} )
( [+-] ?
\d {1,2}
( : \d {1,2} ) {0,2}
)
( [^\d+\-,] {3,} )?
/x
) {
$TZ = $isdst ? $4 : $1;
$tzn_cache{$TZ} = [ $1, $4 ];
} else {
$tzn_cache{$TZ} = [ $TZ, $TZ ];
}
return $TZ;
}
sub asctime_n {
my($sec, $min, $hour, $mday, $mon, $year, $wday, $yday, $isdst, $TZname) = @_;
$year += ($year < 70) ? 2000 : 1900;
$TZname .= ' '
if $TZname;
sprintf("%s %s %2d %2d:%02d:%02d %s%4d",
$DoW[$wday], $MoY[$mon], $mday, $hour, $min, $sec, $TZname, $year);
}
sub wkyr
{
my($wstart, $wday, $yday) = @_;
$wday = ($wday + 7 - $wstart) % 7;
return int(($yday - $wday + 13) / 7 - 1);
}
sub strftime
{
my ($template, $time) = @_;
$time ||= time; # Defaults to current time
@time = localtime($time);
$template =~ s/%([%aAbBcdDehHIjklmMnopQrRStTUwWxXyYZ])/&{$strftime_conversion{$1}}()/egs;
return $template;
}
#####################################################################
# Write details of an accounting packet to a file
# $acctFileName is modified by special formatting
# $dummy is an historical artifact
sub logAccounting
{
my ($p, $dummy, $acctFileName, $format) = @_;
my $filename = &format_special($acctFileName, $p);
# Make sure the log file directory exists.
mkpath(dirname($filename), 0, 0755)
unless -d dirname($filename);
# Permit pipes
$filename = ">>$filename" unless $filename =~ /^\|/;
open(LOG, $filename)
|| &main::log($main::LOG_ERR, "Could not open accounting log file '$filename': $!", $p);
# This is where the packet is formatted into the log file.
# If you want a different accounting log file format, you can
# change this bit
if (defined $format)
{
# Format for accounting log file
print LOG &format_special($format, $p),"\n";
}
else
{
# No special format, do it in the standard radius log file
# format
print LOG scalar localtime(time) . "\n" . $p->format . "\n";
}
close(LOG)
|| &main::log($main::LOG_ERR, "Could not close accounting log file '$filename': $!", $p);
}
#####################################################################
# Compute a Hashed Message Authentication Code
# As per RFC2085, ftp://ftp.isi.edu/in-notes/rfc2085.txt
# basically MD5(K ^ opad, MD5(K ^ ipad), text)
# REVISIT: use the one in Digest-MD5 instead soon
sub hmac_md5
{
my ($K, $text) = @_;
my $ipad = chr(0x36) x 64;
my $opad = chr(0x5c) x 64;
# (1) append zeros to the end of K to create a 64 byte string
# (e.g., if K is of length 16 bytes it will be appended with 48
# zero bytes 0x00)
$K .= chr(0) x (64 - (length($K) % 64));
# (2) XOR (bitwise exclusive-OR) the 64 byte string computed in
# step (1) with ipad
my $x = $K ^ $ipad;
# (3) append the data stream 'text' to the 64 byte string resulting
# from step (2)
$x .= $text;
# (4) apply MD5 to the stream generated in step (3)
$x = Digest::MD5::md5($x);
# (5) XOR (bitwise exclusive-OR) the 64 byte string computed in
# step (1) with opad
my $y = $K ^ $opad;
# (6) append the MD5 result from step (4) to the 64 byte string
# resulting from step (5)
$y .= $x;
# (7) apply MD5 to the stream generated in step (6) and output
# the result
return Digest::MD5::md5($y);
}
#####################################################################
# Append a single line of text to a file.
# Current implementation opens, writes and closes
# Future implementations might hold the file open, and reopen on
# signal, or perhaps pipe to a daemon
# Return true if successful
sub append
{
my ($filename, $line) = @_;
# Permit pipes
$filename = ">>$filename" unless $filename =~ /^\|/;
open(FILE, $filename) || return;
print FILE $line;
close(FILE) || return;
return 1;
}
#####################################################################
# On platforms that support it, and when timeout is
# non-zero, execute the sub with a timeout.
# Dies with error 'timeout' of the timeout expires
sub exec_timeout
{
my ($timeout, $code) = @_;
my $skipit = $^O eq 'MSWin32' || !$timeout;
eval
{
local $SIG{ALRM} = sub {die "timeout"} unless $skipit;
alarm($timeout) unless $skipit;
&$code();
};
alarm(0) unless $skipit; # Cancel the alarm
}
#####################################################################
# Generate a random binary string $l octets long
# REVISIT: is there a faster way to do this?
sub random_string
{
my ($l) = @_;
my $ret;
while ($l-- > 0)
{
$ret .= chr(rand(255));
}
return $ret;
}
#####################################################################
# Take a comma separated list of attr=val and split it up
# into an array ([attr, val], [attr, val], ....)
sub splitAttrVals
{
my ($s) = @_;
my @ret;
$s =~ s/^\s*//; # Strip leading white space
$s =~ s/\s*$//; # Strip trailing white space
$s =~ s/^,*//; # Strip redundant leading commas
while ($s ne '')
{
if ($s =~ /^([^\s=]+)\s*=\s*"((\\"|[^"])*)",*/g)
{
# Quoted value
my ($attr, $value) = ($1, $2);
$value =~ s/\\"/"/g; # Unescape quotes
$value =~ s/\\(\d{3})/chr(oct($1))/ge; # Convert escaped octal
push(@ret, [ $attr, $value ]);
$s = substr($s, pos $s);
}
elsif ($s =~ /^([^\s=]+)\s*=\s*([^,]*),*/g)
{
# Unquoted value
push(@ret, [ $1, $2 ]);
$s = substr($s, pos $s);
}
else
{
&main::log($main::LOG_ERR, "Bad attribute=value pair: $s");
last;
}
$s =~ s/^\s*//; # Strip leading white space
}
return @ret;
}
#####################################################################
# Convert a numeric or symbolic UDP port into a port number
sub get_port
{
my ($p) = @_;
$p = &Radius::Util::format_special($p);
if ($p =~ /^\d+$/)
{
# Completely numeric, 0 is permitted
return $p;
}
else
{
my $ret = getservbyname($p, 'udp');
&main::log($main::LOG_WARNING, "Unknown service name $p")
unless $ret;
return $ret;
}
}
1;
More information about the radiator
mailing list