kill/getline
kill - do not use opt_auth/opt_ssl
getline - removed an early getline
--- a/hlog.pl Tue Dec 29 11:23:38 2009 +0100
+++ b/hlog.pl Tue Dec 29 13:50:05 2009 +0100
@@ -72,182 +72,185 @@
# 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;
+{
+
+ package IO::Socket::hlog;
+
+ use IO::Socket::INET;
+ use IO::Socket::SSL;
+
+ our (@ISA, $DEBUG);
-use IO::Socket::INET;
-use IO::Socket::SSL;
+ sub new {
+
+ my $class = shift;
-our (@ISA, $DEBUG);
+ my %args = @_;
+ my $ssl = delete $args{SSL};
-sub new {
+ if ($ssl) {
- my $class = shift;
+ @ISA = qw(IO::Socket::SSL);
+ $IO::Socket::SSL::DEBUG = $DEBUG ? 3 : 0;
- my %args = @_;
- my $ssl = delete $args{SSL};
+ }
+ else {
+
+ %args = _delete_ssl_args(%args);
+ @ISA = qw(IO::Socket::INET);
+
+ }
- if ($ssl) {
+ my $self;
+ unless ($self = $class->SUPER::new(%args)) {
+
+ return;
- @ISA = qw(IO::Socket::SSL);
- $IO::Socket::SSL::DEBUG = $DEBUG ? 3 : 0;
+ }
+
+ print "$class: $self created\n" if $DEBUG;
+
+ return $self;
}
- else {
+
+ sub close {
+
+ my $self = shift;
+ print "$self: closing\n" if $DEBUG;
+
+ my %args = @_;
+
+ %args = _delete_ssl_args(%args) unless $self->_is_ssl;
- %args = _delete_ssl_args(%args);
- @ISA = qw(IO::Socket::INET);
+ return $self->SUPER::close(%args);
+
+ }
+
+ sub errstr {
+
+ return IO::Socket::SSL::errstr if _is_ssl();
+
+ return $@;
}
- my $self;
- unless ($self = $class->SUPER::new(%args)) {
+ 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;
}
- print "$class: $self created\n" if $DEBUG;
-
- return $self;
-
-}
-
-sub close {
-
- my $self = shift;
- print "$self: closing\n" if $DEBUG;
-
- my %args = @_;
+ sub authdata {
- %args = _delete_ssl_args(%args) unless $self->_is_ssl;
-
- return $self->SUPER::close(%args);
-
-}
-
-sub errstr {
+ my $self = shift;
- return IO::Socket::SSL::errstr if _is_ssl();
-
- return $@;
-
-}
-
-sub _delete_ssl_args {
+ my ($htpasswd) = @_ || $self->{filename} || die "Missing filename";
- 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;
+ $self->{authdata} = {};
-use Crypt::PasswdMD5;
-use Digest::SHA1 qw(sha1_base64);
-use MIME::Base64 qw(decode_base64);
-
-sub new {
-
- my $class = shift;
+ open H, "<$htpasswd" or die "Cant open '<$htpasswd': $!";
+ while (my $line = <H>) {
- 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};
+ chomp $line;
- 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\}//) {
+ # htpasswd lines may have more than 2 fields
+ my ($u, $p) = split /:/, $line, 3;
- # 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;
+ unless ($u && $p) {
+ warn "invalid htpasswd line in '$htpasswd' at line $.";
+ next;
+ }
- my ($htpasswd) = @_ || $self->{filename} || die "Missing filename";
-
- $self->{authdata} = {};
-
- open H, "<$htpasswd" or die "Cant open '<$htpasswd': $!";
- while (my $line = <H>) {
+ warn
+"duplicate user '$u' in '$htpasswd' at line $. - overriding previous record"
+ if exists $self->{authdata}->{$u};
+ $self->{authdata}->{$u} = $p;
- 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};
}
-
- close H or warn "Cant close '<$htpasswd': $!";
-
- warn "no authentication data found" unless %{ $self->{authdata} };
-
- return $self->{authdata};
-
}
-# back to main package
-package main;
-
END {
unlink $pidfile
if defined $pidfile
@@ -290,6 +293,11 @@
$IO::Socket::hlog::DEBUG = $opt_debug;
+ if ($opt_kill) {
+ $opt_auth = 0;
+ $opt_ssl = 0;
+ }
+
$authdata = new Authen::hlog(filename => $opt_htpasswd, realm => $opt_realm)
if $opt_auth;
@@ -521,7 +529,8 @@
log_write($client->peerhost . ":" . $client->peerport . " $tag ($lines)");
seek($file{fh}, -($lines + 1) * $file{avglen}, 2);
- $file{fh}->getline;
+
+ # warum das? $file{fh}->getline;
$client->print(http "200 OK" => join "", <<__EOF, $file{fh}->getlines);
# Proof of concept ;-)