--- a/hlog.pl Tue Dec 29 13:50:05 2009 +0100
+++ b/hlog.pl Tue Dec 29 14:06:42 2009 +0100
@@ -72,185 +72,6 @@
# IO::Socket::SSL would (probably) require more coding and certainly more
# background knowledge and might not even address the problems we work around
# here
-{
-
- package IO::Socket::hlog;
-
- use IO::Socket::INET;
- use IO::Socket::SSL;
-
- our (@ISA, $DEBUG);
-
- sub new {
-
- my $class = shift;
-
- my %args = @_;
- my $ssl = delete $args{SSL};
-
- if ($ssl) {
-
- @ISA = qw(IO::Socket::SSL);
- $IO::Socket::SSL::DEBUG = $DEBUG ? 3 : 0;
-
- }
- else {
-
- %args = _delete_ssl_args(%args);
- @ISA = qw(IO::Socket::INET);
-
- }
-
- my $self;
- unless ($self = $class->SUPER::new(%args)) {
-
- return;
-
- }
-
- print "$class: $self created\n" if $DEBUG;
-
- return $self;
-
- }
-
- sub close {
-
- my $self = shift;
- print "$self: closing\n" if $DEBUG;
-
- my %args = @_;
-
- %args = _delete_ssl_args(%args) unless $self->_is_ssl;
-
- return $self->SUPER::close(%args);
-
- }
-
- sub errstr {
-
- return IO::Socket::SSL::errstr if _is_ssl();
-
- return $@;
-
- }
-
- sub _delete_ssl_args {
-
- my %args = @_;
- map { delete $args{$_} if /^SSL/; } keys %args;
- return %args;
-
- }
-
- sub _is_ssl {
-
- my $self = shift;
- return $ISA[0] eq "IO::Socket::SSL";
-
- }
-}
-
-{
-
- # authentication
- package Authen::hlog;
-
- use Crypt::PasswdMD5;
- use Digest::SHA1 qw(sha1_base64);
- use MIME::Base64 qw(decode_base64);
-
- sub new {
-
- my $class = shift;
-
- my $self = {@_};
-
- die "At least one of 'filename' or 'authdata' parameters is required"
- unless $self->{filename} || $self->{authdata};
-
- bless $self, $class;
- $self->authdata if $self->{filename};
-
- return $self;
-
- }
-
- sub verify_base64 {
-
- my $self = shift;
- return $self->verify(split /:/, decode_base64($_[0]));
-
- }
-
- sub verify {
-
- my $self = shift;
-
- my ($u, $p) = @_;
-
- my $hp = $self->{authdata}->{$u};
-
- # crypt?
- if (length $hp == 13) {
- return crypt($p, $hp) eq $hp;
-
- # apache md5?
- }
- elsif (length $hp == 37 && $hp =~ /^\$apr/) {
- return apache_md5_crypt($p, $hp) eq $hp;
- }
- elsif ($hp =~ s/^\{SHA\}//) {
-
- # remove trailing equality signs because sha1_base64 refuses to add any
- $hp =~ s/=*$//;
- return sha1_base64($p) eq $hp;
- }
- else {
- warn "unknown hash format: >>>$hp<<<";
- }
-
- return;
-
- }
-
- sub authdata {
-
- my $self = shift;
-
- my ($htpasswd) = @_ || $self->{filename} || die "Missing filename";
-
- $self->{authdata} = {};
-
- open H, "<$htpasswd" or die "Cant open '<$htpasswd': $!";
- while (my $line = <H>) {
-
- chomp $line;
-
- # htpasswd lines may have more than 2 fields
- my ($u, $p) = split /:/, $line, 3;
-
- unless ($u && $p) {
- warn "invalid htpasswd line in '$htpasswd' at line $.";
- next;
- }
-
- warn
-"duplicate user '$u' in '$htpasswd' at line $. - overriding previous record"
- if exists $self->{authdata}->{$u};
- $self->{authdata}->{$u} = $p;
-
- }
-
- close H or warn "Cant close '<$htpasswd': $!";
-
- warn "no authentication data found" unless %{ $self->{authdata} };
-
- return $self->{authdata};
-
- }
-}
-
END {
unlink $pidfile
if defined $pidfile
@@ -351,7 +172,9 @@
}
# start the listener
- my $listener = new IO::Socket::hlog(
+ my $listener =
+ $opt_ssl
+ ? new IO::Socket::SSL(
LocalAddr => $opt_addr,
LocalPort => $opt_port,
Proto => "tcp",
@@ -360,8 +183,16 @@
SSL => $opt_ssl,
SSL_key_file => $opt_ssl_key,
SSL_cert_file => $opt_ssl_cert,
- debug => $opt_debug
- ) or die "Can't create listener socket: ", IO::Socket::hlog::errstr, "\n";
+ #debug => $opt_debug
+ )
+ : new IO::Socket::INET(
+ LocalAddr => $opt_addr,
+ LocalPort => $opt_port,
+ Proto => "tcp",
+ Listen => 1,
+ ReuseAddr => 1,
+ #debug => $opt_debug,
+ );
# go daemon
chdir("/") or die "Can't chdir to /: $!\n";
@@ -630,6 +461,187 @@
__EOF
}
+# PACKAGES
+{
+
+ package IO::Socket::hlog;
+
+ use IO::Socket::INET;
+ use IO::Socket::SSL;
+
+ our (@ISA, $DEBUG);
+
+ sub new {
+
+ my $class = shift;
+
+ my %args = @_;
+ my $ssl = delete $args{SSL};
+
+ if ($ssl) {
+
+ @ISA = qw(IO::Socket::SSL);
+ $IO::Socket::SSL::DEBUG = $DEBUG ? 3 : 0;
+
+ }
+ else {
+
+ %args = _delete_ssl_args(%args);
+ @ISA = qw(IO::Socket::INET);
+
+ }
+
+ my $self;
+ unless ($self = $class->SUPER::new(%args)) {
+
+ return;
+
+ }
+
+ print "$class: $self created\n" if $DEBUG;
+
+ return $self;
+
+ }
+
+ sub close {
+
+ my $self = shift;
+ print "$self: closing\n" if $DEBUG;
+
+ my %args = @_;
+
+ %args = _delete_ssl_args(%args) unless $self->_is_ssl;
+
+ return $self->SUPER::close(%args);
+
+ }
+
+ sub errstr {
+
+ return IO::Socket::SSL::errstr if _is_ssl();
+
+ return $@;
+
+ }
+
+ sub _delete_ssl_args {
+
+ my %args = @_;
+ map { delete $args{$_} if /^SSL/; } keys %args;
+ return %args;
+
+ }
+
+ sub _is_ssl {
+
+ my $self = shift;
+ return $ISA[0] eq "IO::Socket::SSL";
+
+ }
+}
+
+{
+
+ # authentication
+ package Authen::hlog;
+
+ use Crypt::PasswdMD5;
+ use Digest::SHA1 qw(sha1_base64);
+ use MIME::Base64 qw(decode_base64);
+
+ sub new {
+
+ my $class = shift;
+
+ my $self = {@_};
+
+ die "At least one of 'filename' or 'authdata' parameters is required"
+ unless $self->{filename} || $self->{authdata};
+
+ bless $self, $class;
+ $self->authdata if $self->{filename};
+
+ return $self;
+
+ }
+
+ sub verify_base64 {
+
+ my $self = shift;
+ return $self->verify(split /:/, decode_base64($_[0]));
+
+ }
+
+ sub verify {
+
+ my $self = shift;
+
+ my ($u, $p) = @_;
+
+ my $hp = $self->{authdata}->{$u};
+
+ # crypt?
+ if (length $hp == 13) {
+ return crypt($p, $hp) eq $hp;
+
+ # apache md5?
+ }
+ elsif (length $hp == 37 && $hp =~ /^\$apr/) {
+ return apache_md5_crypt($p, $hp) eq $hp;
+ }
+ elsif ($hp =~ s/^\{SHA\}//) {
+
+ # remove trailing equality signs because sha1_base64 refuses to add any
+ $hp =~ s/=*$//;
+ return sha1_base64($p) eq $hp;
+ }
+ else {
+ warn "unknown hash format: >>>$hp<<<";
+ }
+
+ return;
+
+ }
+
+ sub authdata {
+
+ my $self = shift;
+
+ my ($htpasswd) = @_ || $self->{filename} || die "Missing filename";
+
+ $self->{authdata} = {};
+
+ open H, "<$htpasswd" or die "Cant open '<$htpasswd': $!";
+ while (my $line = <H>) {
+
+ chomp $line;
+
+ # htpasswd lines may have more than 2 fields
+ my ($u, $p) = split /:/, $line, 3;
+
+ unless ($u && $p) {
+ warn "invalid htpasswd line in '$htpasswd' at line $.";
+ next;
+ }
+
+ warn
+"duplicate user '$u' in '$htpasswd' at line $. - overriding previous record"
+ if exists $self->{authdata}->{$u};
+ $self->{authdata}->{$u} = $p;
+
+ }
+
+ close H or warn "Cant close '<$htpasswd': $!";
+
+ warn "no authentication data found" unless %{ $self->{authdata} };
+
+ return $self->{authdata};
+
+ }
+}
+
+
__END__
=head1 NAME