$epath =~ s/%7e/~/ig; # unescape ~
$epath =~ s/(%[\da-f]{2})/\U$1/ig; # capitalize escape digits
if ($url->scheme =~ /^(http|ftp)$/) {
- $epath =~ s:/\./:/:g; # safe?
- $epath =~ s://:/:g; # safe?
+ $epath =~ s:/\./:/:g; # safe?
+ $epath =~ s://:/:g; # safe?
}
$url->epath($epath);
BEGIN {
unless (URI::URL::implementor('cache_object')) {
- package cache_object;
- @cache_object::ISA = (URI::URL::implementor());
- URI::URL::implementor('cache_object', 'cache_object');
+ package cache_object;
+ @cache_object::ISA = (URI::URL::implementor());
+ URI::URL::implementor('cache_object', 'cache_object');
- sub default_port { 3128 }
+ sub default_port { 3128 }
}
}
open (ACCESS, "/opt/Squid/logs/useragent.0");
while (<ACCESS>) {
- ($host, $timestamp, $agent) =
- /^(\S+) \[(.+)\] \"(.+)\"\s/;
- if ($agent ne '-') {
- if ($opt_M) {
- $agent =~ tr/\// /;
- $agent =~ tr/\(/ /;
- }
- if ($opt_F) {
- next unless $seen{$agent}++;
- } else {
- @inline=split(/ /, $agent);
- next unless $seen{$inline[0]}++;
- }
- }
+ ($host, $timestamp, $agent) =
+ /^(\S+) \[(.+)\] \"(.+)\"\s/;
+ if ($agent ne '-') {
+ if ($opt_M) {
+ $agent =~ tr/\// /;
+ $agent =~ tr/\(/ /;
+ }
+ if ($opt_F) {
+ next unless $seen{$agent}++;
+ } else {
+ @inline=split(/ /, $agent);
+ next unless $seen{$inline[0]}++;
+ }
+ }
}
$total=0;
print "Summary of User-Agent Strings\n(greater than $opt_L percent)\n\n";
foreach $browser (keys(%seen)) {
- $total=$total+$seen{$browser};
+ $total=$total+$seen{$browser};
}
foreach $browser (sort keys(%seen)) {
- $percent=$seen{$browser}/$total*100;
- if ($percent >= $opt_L) { write; }
+ $percent=$seen{$browser}/$total*100;
+ if ($percent >= $opt_L) { write; }
}
print "\n\nTotal entries in log = $total\n";
$myip=(gethostbyname($me))[4];
die "socket: $!\n" unless
- socket (SOCK, &AF_INET, &SOCK_DGRAM, $proto);
+ socket (SOCK, &AF_INET, &SOCK_DGRAM, $proto);
while (<>) {
- chop;
- $request_template = 'CCnx4x8x4a4a' . length;
- $request = pack($request_template, 1, 1, 24 + length, $myip, $_);
- die "send: $!\n" unless
- send(SOCK, $request, 0, $them);
- die "recv: $!\n" unless
- recv(SOCK, $reply, 1024, 0);
- ($type,$ver,$len,$payload) = unpack('CCnx4x8x4A', $reply);
- print $CODES[$type] . " $_\n";
+ chop;
+ $request_template = 'CCnx4x8x4a4a' . length;
+ $request = pack($request_template, 1, 1, 24 + length, $myip, $_);
+ die "send: $!\n" unless
+ send(SOCK, $request, 0, $them);
+ die "recv: $!\n" unless
+ recv(SOCK, $reply, 1024, 0);
+ ($type,$ver,$len,$payload) = unpack('CCnx4x8x4A', $reply);
+ print $CODES[$type] . " $_\n";
}
$wh = "username";
if (scalar @ARGV >= 1) {
- $wh = $ARGV[0];
- shift @ARGV;
+ $wh = $ARGV[0];
+ shift @ARGV;
}
while (<>) {
- chomp;
- my $l = Squid::ParseLog::parse($_);
- if (! defined $u{$l->{$wh}}) {
- $u{$l->{$wh}}->{"traffic"} = 0;
- }
- $u{$l->{$wh}}->{"traffic"} += $l->{"size"};
+ chomp;
+ my $l = Squid::ParseLog::parse($_);
+ if (! defined $u{$l->{$wh}}) {
+ $u{$l->{$wh}}->{"traffic"} = 0;
+ }
+ $u{$l->{$wh}}->{"traffic"} += $l->{"size"};
}
foreach (keys %u) {
- printf "%s\t\t%lu\n", $_, $u{$_}->{"traffic"};
+ printf "%s\t\t%lu\n", $_, $u{$_}->{"traffic"};
}
#
# This is a simple module which takes in a Squid format logfile line and breaks it up into
# a perl hash.
-#
+#
# I'm not going to pretend this is 100% accurate just yet but its a start.
# I'm hoping that by placing it into the public domain it (and the other stuff
# I sneak in here) will be debugged and improved by others.
-#
+#
# Adrian Chadd <adrian@squid-cache.org>
-#
+#
# $Id: ParseLog.pm,v 1.1 2007/01/24 06:50:35 adrian Exp $
-#
+#
use strict;
package Squid::ParseLog;
sub parse($) {
- my ($line) = @_;
- my (%t);
- chomp $line;
-
- $line =~ m/^(.*?) (\d+?) (.*?) (.*?)\/(\d+?) (\d+?) (.*?) (.*?) (.*?) (.*?)\/(.*?) (.*)$/;
-
- $t{"timestamp"} = $1;
- $t{"reqtime"} = $2;
- $t{"clientip"} = $3;
- $t{"code"} = $4;
- $t{"httpcode"} = $5;
- $t{"size"} = $6;
- $t{"method"} = $7;
- $t{"url"} = $8;
- $t{"username"} = $9;
- $t{"fwdcode"} = $10;
- $t{"fwdip"} = $11;
- $t{"mime"} = $12;
-
- return \%t;
+ my ($line) = @_;
+ my (%t);
+ chomp $line;
+
+ $line =~ m/^(.*?) (\d+?) (.*?) (.*?)\/(\d+?) (\d+?) (.*?) (.*?) (.*?) (.*?)\/(.*?) (.*)$/;
+
+ $t{"timestamp"} = $1;
+ $t{"reqtime"} = $2;
+ $t{"clientip"} = $3;
+ $t{"code"} = $4;
+ $t{"httpcode"} = $5;
+ $t{"size"} = $6;
+ $t{"method"} = $7;
+ $t{"url"} = $8;
+ $t{"username"} = $9;
+ $t{"fwdcode"} = $10;
+ $t{"fwdip"} = $11;
+ $t{"mime"} = $12;
+
+ return \%t;
}
1;
##
#
# access-log-matrix.pl
-#
+#
# Duane Wessels, Dec 1995
-#
+#
# Stdin is a Harvest access log (in the old, non-common logfile format!).
# The output is a matrix of hostnames and log entry types, plus totals.
while (<>) {
- chop;
- @F = split;
- $when = $F[0];
- $first = $when unless ($first);
- $last = $when;
-
- $what = pop @F;
- $size = pop @F;
- $host = pop @F;
+ chop;
+ @F = split;
+ $when = $F[0];
+ $first = $when unless ($first);
+ $last = $when;
+
+ $what = pop @F;
+ $size = pop @F;
+ $host = pop @F;
+
+ $HOSTS{$host}++;
+ $HOSTS{'TOTAL'}++;
- $HOSTS{$host}++;
- $HOSTS{'TOTAL'}++;
-
- if ($what eq 'TCP_DONE') {
- $TCP_DONE{$host}++;
- $TCP_DONE{'TOTAL'}++;
- } elsif ($what eq 'TCP_HIT') {
- $TCP_HIT{$host}++;
- $TCP_HIT{'TOTAL'}++;
- } elsif ($what eq 'TCP_MISS') {
- $TCP_MISS{$host}++;
- $TCP_MISS{'TOTAL'}++;
- } elsif ($what eq 'TCP_MISS_TTL') {
- $TCP_MISS_TTL{$host}++;
- $TCP_MISS_TTL{'TOTAL'}++;
- } elsif ($what eq 'UDP_HIT') {
- $UDP_HIT{$host}++;
- $UDP_HIT{'TOTAL'}++;
- } elsif ($what eq 'UDP_MISS') {
- $UDP_MISS{$host}++;
- $UDP_MISS{'TOTAL'}++;
- } else {
- $OTHER{$host}++;
- $OTHER{'TOTAL'}++;
- }
+ if ($what eq 'TCP_DONE') {
+ $TCP_DONE{$host}++;
+ $TCP_DONE{'TOTAL'}++;
+ } elsif ($what eq 'TCP_HIT') {
+ $TCP_HIT{$host}++;
+ $TCP_HIT{'TOTAL'}++;
+ } elsif ($what eq 'TCP_MISS') {
+ $TCP_MISS{$host}++;
+ $TCP_MISS{'TOTAL'}++;
+ } elsif ($what eq 'TCP_MISS_TTL') {
+ $TCP_MISS_TTL{$host}++;
+ $TCP_MISS_TTL{'TOTAL'}++;
+ } elsif ($what eq 'UDP_HIT') {
+ $UDP_HIT{$host}++;
+ $UDP_HIT{'TOTAL'}++;
+ } elsif ($what eq 'UDP_MISS') {
+ $UDP_MISS{$host}++;
+ $UDP_MISS{'TOTAL'}++;
+ } else {
+ $OTHER{$host}++;
+ $OTHER{'TOTAL'}++;
+ }
}
print ' HOSTNAME: '. `hostname`;
print "\n";
printf ("%25.25s %5s %5s %5s %5s %5s %5s %5s %5s\n",
- '',
- 'TCP', 'TCP', 'TCP', 'TCP',
- 'UDP', 'UDP', '',
- '');
+ '',
+ 'TCP', 'TCP', 'TCP', 'TCP',
+ 'UDP', 'UDP', '',
+ '');
printf ("%25.25s %5s %5s %5s %5s %5s %5s %5s %5s\n",
- 'HOST',
- 'HIT', 'MISS', 'TTL', 'DONE',
- 'HIT', 'MISS', 'OTHER',
- 'TOTAL');
+ 'HOST',
+ 'HIT', 'MISS', 'TTL', 'DONE',
+ 'HIT', 'MISS', 'OTHER',
+ 'TOTAL');
printf ("%25.25s %5s %5s %5s %5s %5s %5s %5s %5s\n",
- '-'x25,
- '-'x5, '-'x5, '-'x5, '-'x5, '-'x5, '-'x5, '-'x5, '-'x5);
+ '-'x25,
+ '-'x5, '-'x5, '-'x5, '-'x5, '-'x5, '-'x5, '-'x5, '-'x5);
foreach $h (sort totalcmp keys %HOSTS) {
- next if ($h eq 'TOTAL');
- ($a1,$a2,$a3,$a4) = split('\.', $h);
- ($fqdn, @F) = gethostbyaddr(pack('C4',$a1,$a2,$a3,$a4),2);
- $fqdn = $h unless ($fqdn ne '');
+ next if ($h eq 'TOTAL');
+ ($a1,$a2,$a3,$a4) = split('\.', $h);
+ ($fqdn, @F) = gethostbyaddr(pack('C4',$a1,$a2,$a3,$a4),2);
+ $fqdn = $h unless ($fqdn ne '');
- printf "%25.25s %5d %5d %5d %5d %5d %5d %5d %5d\n",
- $fqdn,
- $TCP_HIT{$h},
- $TCP_MISS{$h},
- $TCP_MISS_TTL{$h},
- $TCP_DONE{$h},
- $UDP_HIT{$h},
- $UDP_MISS{$h},
- $OTHER{$h},
- $HOSTS{$h};
+ printf "%25.25s %5d %5d %5d %5d %5d %5d %5d %5d\n",
+ $fqdn,
+ $TCP_HIT{$h},
+ $TCP_MISS{$h},
+ $TCP_MISS_TTL{$h},
+ $TCP_DONE{$h},
+ $UDP_HIT{$h},
+ $UDP_MISS{$h},
+ $OTHER{$h},
+ $HOSTS{$h};
}
printf ("%25.25s %5s %5s %5s %5s %5s %5s %5s %5s\n",
- '-'x25,
- '-'x5, '-'x5, '-'x5, '-'x5, '-'x5, '-'x5, '-'x5, '-'x5);
+ '-'x25,
+ '-'x5, '-'x5, '-'x5, '-'x5, '-'x5, '-'x5, '-'x5, '-'x5);
printf "%25.25s %5d %5d %5d %5d %5d %5d %5d %5d\n",
- 'TOTAL',
- $TCP_HIT{'TOTAL'},
- $TCP_MISS{'TOTAL'},
- $TCP_MISS_TTL{'TOTAL'},
- $TCP_DONE{'TOTAL'},
- $UDP_HIT{'TOTAL'},
- $UDP_MISS{'TOTAL'},
- $OTHER{'TOTAL'},
- $HOSTS{'TOTAL'};
+ 'TOTAL',
+ $TCP_HIT{'TOTAL'},
+ $TCP_MISS{'TOTAL'},
+ $TCP_MISS_TTL{'TOTAL'},
+ $TCP_DONE{'TOTAL'},
+ $UDP_HIT{'TOTAL'},
+ $UDP_MISS{'TOTAL'},
+ $OTHER{'TOTAL'},
+ $HOSTS{'TOTAL'};
exit 0;
sub hostcmp {
- $a cmp $b
+ $a cmp $b
}
sub totalcmp {
- $HOSTS{$b} <=> $HOSTS{$a}
+ $HOSTS{$b} <=> $HOSTS{$a}
}
# Adds or adjusts the source file boilerplate, such as a Copyright statement.
# The boilerplate is meant to remain constant from one source file to another.
#
-# The old boilerplate is assumed to be the first /* comment */ in a source
+# The old boilerplate is assumed to be the first /* comment */ in a source
# file, before the first #include statement other than #include "squid.h".
# Common old boilerplates are removed, with copyright-related claims contained
# in them logged on stdout for recording in CONTRIBUTORS or some such.
my ($BoilerName, @FileNames) = @ARGV;
my $CorrectBoiler = `cat $BoilerName` or
- die("cannot load boilerplate from $BoilerName: $!, stopped");
+ die("cannot load boilerplate from $BoilerName: $!, stopped");
$CorrectBoiler = &trimL(&trimR($CorrectBoiler)) . "\n\n";
# the first /* comment */
my $reComment = qr{
- /\*.*?\*/
+ /\*.*?\*/
}xs;
# Debugging section inside a boilerplate comment.
my $reDebug = qr{
- ^[\s*]*(DEBUG:.*?)$
+ ^[\s*]*(DEBUG:.*?)$
}mx;
# Same as $reDebug, but does not match empty DEBUG: statements.
my $reDebugFull = qr{
- ^[\s*]*(DEBUG:[^\S\n]*\S.*?)\s*$
+ ^[\s*]*(DEBUG:[^\S\n]*\S.*?)\s*$
}mx;
# Copyright-related claims inside a boilerplate comment
my $reClaims = qr{
- (
- (?:
- AUTHOR\b(?:.|\n)*?\*[/\s]*$| # all authors until an "empty" line
- ORIGINAL\s+AUTHOR\b| # or not the latest author
- COPYRIGHT\b(?!\sfile)| # or copyright (except "COPYRIGHT file")
- Portions\scopyright| # or partial copyright
- (?<!Squid.is.Copyrighted.)\(C\)\s| # or (C) (except "Squid is ...")
- Based.upon.original.+code.by\s*\n| # or this common pearl
- Modified\sby\s| # or this
- BASED\sON:\s # or this
- )
- .*? # and the claim content itself
- )$
+ (
+ (?:
+ AUTHOR\b(?:.|\n)*?\*[/\s]*$| # all authors until an "empty" line
+ ORIGINAL\s+AUTHOR\b| # or not the latest author
+ COPYRIGHT\b(?!\sfile)| # or copyright (except "COPYRIGHT file")
+ Portions\scopyright| # or partial copyright
+ (?<!Squid.is.Copyrighted.)\(C\)\s| # or (C) (except "Squid is ...")
+ Based.upon.original.+code.by\s*\n| # or this common pearl
+ Modified\sby\s| # or this
+ BASED\sON:\s # or this
+ )
+ .*? # and the claim content itself
+ )$
}xmi;
# removes common claim prefixes to minimize claim noise
my $reClaimPrefix = qr{
- (?:ORIGINAL\s)?AUTHOR:?|
- based\son\s|
- based\supon\s|
- Portions\s
+ (?:ORIGINAL\s)?AUTHOR:?|
+ based\son\s|
+ based\supon\s|
+ Portions\s
}xi;
# We have persmission to move these frequent claims to CONTRIBUTORS.
my $reClaimsOkToMove = qr{
- Robert.Collins|<robertc\@squid-cache.org>|<rbtcollins\@hotmail.com>|
+ Robert.Collins|<robertc\@squid-cache.org>|<rbtcollins\@hotmail.com>|
- Duane.Wessels|
+ Duane.Wessels|
- Francesco.Chemolli|<kinkie\@squid-cache.org>|<kinkie\@kame.usr.dsi.unimi.it>|
+ Francesco.Chemolli|<kinkie\@squid-cache.org>|<kinkie\@kame.usr.dsi.unimi.it>|
-
Amos.Jeffries|<amosjeffries\@squid-cache.org>|<squid3\@treenet.co.nz>|
- Treehouse.Networks.Ltd.|
- GPL.version.2,..C.2007-2013|
+ Amos.Jeffries|<amosjeffries\@squid-cache.org>|<squid3\@treenet.co.nz>|
+ Treehouse.Networks.Ltd.|
+ GPL.version.2,..C.2007-2013|
- Henrik.Nordstrom|<henrik\@henriknordstrom.net>|
- MARA.Systems.AB|
+ Henrik.Nordstrom|<henrik\@henriknordstrom.net>|
+ MARA.Systems.AB|
- Guido.Serassio|<serassio\@squid-cache.org>|<guido.serassio\@acmeconsulting.it>|
+ Guido.Serassio|<serassio\@squid-cache.org>|<guido.serassio\@acmeconsulting.it>|
}xi;
# inspirations are not copyright claims but should be preserved
my $reInspiration = qr/^[\s*]*(inspired by previous work.*?)$/mi;
# The most common GPL text, with some address variations.
-my $strGpl =
- "This program is free software; you can redistribute it and/or modify".
- "([^*]|[*][^/])+". # not a /* comment */ closure
- "Foundation, Inc., [^\\n]+MA\\s+[-\\d]+, USA\\.";
+my $strGpl =
+ "This program is free software; you can redistribute it and/or modify".
+ "([^*]|[*][^/])+". # not a /* comment */ closure
+ "Foundation, Inc., [^\\n]+MA\\s+[-\\d]+, USA\\.";
my $reGpl = qr{$strGpl}s;
# Two most common Squid (C) statements.
my $strSqCopyStart1 =
- "SQUID Web Proxy Cache\\s+http://www.squid-cache.org/";
+ "SQUID Web Proxy Cache\\s+http://www.squid-cache.org/";
my $strSqCopyStart2 =
- "SQUID Internet Object Cache\\s+http://squid.nlanr.net/Squid/";
+ "SQUID Internet Object Cache\\s+http://squid.nlanr.net/Squid/";
my $strSqCopyEnd =
- "([^*]|[*][^/])+".
- "numerous individuals".
- "([^*]|[*][^/])+".
- "file for full details.";
+ "([^*]|[*][^/])+".
+ "numerous individuals".
+ "([^*]|[*][^/])+".
+ "file for full details.";
my $reSquidCopy = qr{($strSqCopyStart1|$strSqCopyStart2)$strSqCopyEnd}s;
# process each file in-place; do not touch files on known failures
foreach my $fname (@FileNames) {
- $FileName = $fname;
- my $code = &readFile($fname) or next;
- my $virginCode = $code;
-
- &WarnQuiet("Correct boilerplate already present, skipping:", $code), next if
- $code =~ /\Q$CorrectBoiler\E/s;
-
- my $boiler;
-
- if ($code =~ m/$reComment/) {
- my $beforeComment = $`;
- my $comment = $&;
-
- # Is the matched comment a boilerplate?
- if ($comment !~ m/\n/) {
- # A single line comment is not a boilerplate.
- } elsif ($beforeComment =~ m/^\s*\#\s*include\s+(?!"squid.h")/m) {
- # A comment after include is not a boilerplate,
- # but we make an exception for #include "squid.h" common in lib/
- } elsif ($comment =~ m@^/\*\*\s@){
- # A Doxygen comment is not a boilerplate.
- } elsif ($comment =~ m/internal declarations|stub file|unit test/i) {
- # These relatively common comments are not boilerplates.
- } elsif (&digestable($comment)) {
- # Something we can safely replace.
- $boiler = $comment;
- } else {
- &Warn("Unrecognized boilerplate, skipping:", $comment);
- next;
- }
- }
-
- my $extras = ''; # DEBUG section, inspired by ..., etc.
-
- if (defined $boiler) {
- my $copyClaims = ''; # formatted Copyright claims extraced from sources
- my $preserveClaims = 0; # whether to preserve them or not
-
- if (my @rawClaims = ($boiler =~ m/$reClaims/g)) {
- my @claims = map { &claimList($_) } @rawClaims;
- my $count = 0;
- foreach my $claim (@claims) {
- $claim =~ s/\n+/ /gs; # streamline multiline claims
- $claim =~ s@\*/?@ @g; # clean comment leftovers
- $claim =~ s/$reClaimPrefix/ /g; # remove common prefixes
- # this one is sucked in from the old standard boilerplate
- $claim =~ s/by the Regents of the University of//;
- $claim =~ s/\s\s+/ /gs; # clean excessive whitespace
- $claim =~ s/^\s+|\s+$//gs; # remove excessive whitespace
- next unless length $claim;
-
- # preserve Copyright claims
- if ($claim =~ m/Copyright|\(c\)/i) {
- $copyClaims .= sprintf(" * %s\n", $claim);
-
- # Ignore certain claims, assuming we have their permission.
- my $c = $claim;
- $c =~ s/^\s*(Copyright)?[:\s]*([(c)]+)?\s*([0-9,-]+)?\s*(by)?\s*//i; # prefix
- $c =~ s/$reClaimsOkToMove/ /g;
- $c =~ s/[,]//g; # markup leftovers
-
- # But if one claim is preserved, all must be preserved.
- $preserveClaims = 1 if $c =~ /\S/;
-warn($c) if $c =~ /\S/;
- }
-
- next if exists $ReportedClaims{$claim};
- print("$fname: INFO: Found new claim(s):\n") unless $count++;
- print("Claim: $claim\n");
- $ReportedClaims{$claim} = $fname;
- }
- }
-
- if ($preserveClaims) {
- die("Internal error: $copyClaims") unless length($copyClaims);
- my $prefix = " * Portions of this code are copyrighted and released under GPLv2+ by:";
- my $suffix = " * Please add new claims to the CONTRIBUTORS file instead.";
- $extras .= sprintf("/*\n%s\n%s%s\n */\n\n",
- $prefix, $copyClaims, $suffix);
- }
-
- if ($boiler =~ m/$reInspiration/) {
- $extras .= sprintf("/* %s */\n\n", ucfirst($1));
- }
-
- if ($boiler =~ m/$reDebugFull/) {
- $extras .= "/* $1 */\n\n";
- }
-
- $code =~ s/\s*$reComment\s*/\n\n/ or
- die("internal error: failed to remove expected comment, stopped");
- &digestable($&) or
- die("internal error: unsafe comment removal, stopped");
-
- } else { # no boilerplate found
- #&Warn("Cannot find old boilerplate, adding new boilerplate.", $code);
- }
-
- # Some files have license declarations way down in the code so we may not
- # find a boilerplate at all or find an "empty" boilerplate preceeding them.
- my $license =
- "Copyright|".
- "This program is free software|".
- "Permission to use|".
- "Redistribution and use";
- if ($code =~ m@/\*.*?($license).*?\*/@is) {
- # If we replaced what we thought is an old boiler, do not use $` for
- # context because it is based on modified $code and will often mislead.
- my $context = defined $boiler ? $& : ($` . $&);
- &Warn("Suspected boilerplate in an unusual location, skipping:",
- $context);
- next;
- }
-
- $code = $CorrectBoiler . $extras . &trimL($code);
- &writeFile($fname, $code) unless $code eq $virginCode;
- undef $FileName;
+ $FileName = $fname;
+ my $code = &readFile($fname) or next;
+ my $virginCode = $code;
+
+ &WarnQuiet("Correct boilerplate already present, skipping:", $code), next if
+ $code =~ /\Q$CorrectBoiler\E/s;
+
+ my $boiler;
+
+ if ($code =~ m/$reComment/) {
+ my $beforeComment = $`;
+ my $comment = $&;
+
+ # Is the matched comment a boilerplate?
+ if ($comment !~ m/\n/) {
+ # A single line comment is not a boilerplate.
+ } elsif ($beforeComment =~ m/^\s*\#\s*include\s+(?!"squid.h")/m) {
+ # A comment after include is not a boilerplate,
+ # but we make an exception for #include "squid.h" common in lib/
+ } elsif ($comment =~ m@^/\*\*\s@){
+ # A Doxygen comment is not a boilerplate.
+ } elsif ($comment =~ m/internal declarations|stub file|unit test/i) {
+ # These relatively common comments are not boilerplates.
+ } elsif (&digestable($comment)) {
+ # Something we can safely replace.
+ $boiler = $comment;
+ } else {
+ &Warn("Unrecognized boilerplate, skipping:", $comment);
+ next;
+ }
+ }
+
+ my $extras = ''; # DEBUG section, inspired by ..., etc.
+
+ if (defined $boiler) {
+ my $copyClaims = ''; # formatted Copyright claims extracted from sources
+ my $preserveClaims = 0; # whether to preserve them or not
+
+ if (my @rawClaims = ($boiler =~ m/$reClaims/g)) {
+ my @claims = map { &claimList($_) } @rawClaims;
+ my $count = 0;
+ foreach my $claim (@claims) {
+ $claim =~ s/\n+/ /gs; # streamline multiline claims
+ $claim =~ s@\*/?@ @g; # clean comment leftovers
+ $claim =~ s/$reClaimPrefix/ /g; # remove common prefixes
+ # this one is sucked in from the old standard boilerplate
+ $claim =~ s/by the Regents of the University of//;
+ $claim =~ s/\s\s+/ /gs; # clean excessive whitespace
+ $claim =~ s/^\s+|\s+$//gs; # remove excessive whitespace
+ next unless length $claim;
+
+ # preserve Copyright claims
+ if ($claim =~ m/Copyright|\(c\)/i) {
+ $copyClaims .= sprintf(" * %s\n", $claim);
+
+ # Ignore certain claims, assuming we have their permission.
+ my $c = $claim;
+ $c =~ s/^\s*(Copyright)?[:\s]*([(c)]+)?\s*([0-9,-]+)?\s*(by)?\s*//i; # prefix
+ $c =~ s/$reClaimsOkToMove/ /g;
+ $c =~ s/[,]//g; # markup leftovers
+
+ # But if one claim is preserved, all must be preserved.
+ $preserveClaims = 1 if $c =~ /\S/;
+ warn($c) if $c =~ /\S/;
+ }
+
+ next if exists $ReportedClaims{$claim};
+ print("$fname: INFO: Found new claim(s):\n") unless $count++;
+ print("Claim: $claim\n");
+ $ReportedClaims{$claim} = $fname;
+ }
+ }
+
+ if ($preserveClaims) {
+ die("Internal error: $copyClaims") unless length($copyClaims);
+ my $prefix = " * Portions of this code are copyrighted and released under GPLv2+ by:";
+ my $suffix = " * Please add new claims to the CONTRIBUTORS file instead.";
+ $extras .= sprintf("/*\n%s\n%s%s\n */\n\n",
+ $prefix, $copyClaims, $suffix);
+ }
+
+ if ($boiler =~ m/$reInspiration/) {
+ $extras .= sprintf("/* %s */\n\n", ucfirst($1));
+ }
+
+ if ($boiler =~ m/$reDebugFull/) {
+ $extras .= "/* $1 */\n\n";
+ }
+
+ $code =~ s/\s*$reComment\s*/\n\n/ or
+ die("internal error: failed to remove expected comment, stopped");
+ &digestable($&) or
+ die("internal error: unsafe comment removal, stopped");
+
+ } else { # no boilerplate found
+ #&Warn("Cannot find old boilerplate, adding new boilerplate.", $code);
+ }
+
+ # Some files have license declarations way down in the code so we may not
+ # find a boilerplate at all or find an "empty" boilerplate preceding them.
+ my $license =
+ "Copyright|".
+ "This program is free software|".
+ "Permission to use|".
+ "Redistribution and use";
+ if ($code =~ m@/\*.*?($license).*?\*/@is) {
+ # If we replaced what we thought is an old boiler, do not use $` for
+ # context because it is based on modified $code and will often mislead.
+ my $context = defined $boiler ? $& : ($` . $&);
+ &Warn("Suspected boilerplate in an unusual location, skipping:",
+ $context);
+ next;
+ }
+
+ $code = $CorrectBoiler . $extras . &trimL($code);
+ &writeFile($fname, $code) unless $code eq $virginCode;
+ undef $FileName;
}
exit(0);
sub readFile() {
- my ($fname) = @_;
-
- if (!-f $fname) {
- &Warn("Skipping directory or a special file.");
- return undef();
- }
-
- my $code = '';
- open(IF, "<$fname") or die("cannot open $fname: $!, stopped");
- while (<IF>) {
- $code .= $_;
- }
- close(IF);
-
- &Warn("empty file") unless length $code;
- return $code;
+ my ($fname) = @_;
+
+ if (!-f $fname) {
+ &Warn("Skipping directory or a special file.");
+ return undef();
+ }
+
+ my $code = '';
+ open(IF, "<$fname") or die("cannot open $fname: $!, stopped");
+ while (<IF>) {
+ $code .= $_;
+ }
+ close(IF);
+
+ &Warn("empty file") unless length $code;
+ return $code;
}
sub writeFile() {
- my ($fname, $code) = @_;
- open(OF, ">$fname") or die("cannot open $fname for writing: $!, stopped");
+ my ($fname, $code) = @_;
+ open(OF, ">$fname") or die("cannot open $fname for writing: $!, stopped");
- print(OF $code) or die("cannot write to $fname: $!, stopped");
+ print(OF $code) or die("cannot write to $fname: $!, stopped");
- close(OF) or die("cannot finish updating $fname: $!, stopped");
+ close(OF) or die("cannot finish updating $fname: $!, stopped");
}
# split multiclaim claims into an array of single claims
sub claimList() {
- my $multiClaim = shift;
+ my $multiClaim = shift;
- $multiClaim =~ s/$reDebug//g; # may pretend to continue AUTHORs list
- $multiClaim =~ s/$reInspiration//g; # does not affect (C) claims
+ $multiClaim =~ s/$reDebug//g; # may pretend to continue AUTHORs list
+ $multiClaim =~ s/$reInspiration//g; # does not affect (C) claims
- # remove \n that is not used to separate two claims
- $multiClaim =~ s/(Based.upon.original.+code.by\s*)\n/$1 /g;
+ # remove \n that is not used to separate two claims
+ $multiClaim =~ s/(Based.upon.original.+code.by\s*)\n/$1 /g;
- return split(/\n/, $multiClaim);
- # return grep { /\S/ } split($reClaimSplitter, $multiClaim);
+ return split(/\n/, $multiClaim);
+ # return grep { /\S/ } split($reClaimSplitter, $multiClaim);
}
# checks whether a comment contains nothing but the stuff we can either
# safely remove, replace, or move (e.g., DEBUG sections and copyright claims)
sub digestable() {
- my $comment = shift;
-
- # Remove common text to detect an otherwise empty boilerplate.
- $comment =~ s/$reDebug//;
- $comment =~ s/$reClaims//g;
- $comment =~ s/^[\s*]*(Created on.*?)$//mig;
- $comment =~ s/^[\s*]*(Windows support\s*)$//mig;
- $comment =~ s/^[\s*]*(History added by .*)$//mig;
- $comment =~ s/$reGpl//;
- $comment =~ s/$reSquidCopy//;
- $comment =~ s/$reInspiration//g;
- $comment =~ s/\* Stubs for.*?$//m; # e.g., Stubs for calls to stuff defined in...
- $comment =~ s/\$Id(:.*)?\$//g; # CVS tags
- $comment =~ s/-{60,}//g; # decorations such as -----------...---------
- $comment =~ s/\b\w+\.(h|c|cc|cci)\b//; # Next to last step: a file name.
- $comment =~ s@[\s*/]@@sg; # Last step: whitespace and comment characters.
- return !length($comment);
+ my $comment = shift;
+
+ # Remove common text to detect an otherwise empty boilerplate.
+ $comment =~ s/$reDebug//;
+ $comment =~ s/$reClaims//g;
+ $comment =~ s/^[\s*]*(Created on.*?)$//mig;
+ $comment =~ s/^[\s*]*(Windows support\s*)$//mig;
+ $comment =~ s/^[\s*]*(History added by .*)$//mig;
+ $comment =~ s/$reGpl//;
+ $comment =~ s/$reSquidCopy//;
+ $comment =~ s/$reInspiration//g;
+ $comment =~ s/\* Stubs for.*?$//m; # e.g., Stubs for calls to stuff defined in...
+ $comment =~ s/\$Id(:.*)?\$//g; # CVS tags
+ $comment =~ s/-{60,}//g; # decorations such as -----------...---------
+ $comment =~ s/\b\w+\.(h|c|cc|cci)\b//; # Next to last step: a file name.
+ $comment =~ s@[\s*/]@@sg; # Last step: whitespace and comment characters.
+ return !length($comment);
}
# removes all opening whitespace
sub trimL() {
- my ($code) = @_;
- $code =~ s/^\n[\n\s]*//s;
- return $code;
+ my ($code) = @_;
+ $code =~ s/^\n[\n\s]*//s;
+ return $code;
}
# removes all trailing whitespace
sub trimR() {
- my ($code) = @_;
- $code =~ s/\n[\n\s]*$//s;
- return $code;
+ my ($code) = @_;
+ $code =~ s/\n[\n\s]*$//s;
+ return $code;
}
sub Warn() {
- my ($msg, $context) = @_;
-
- if (defined $context) {
- my $MaxLen = 1000;
- $context =~ s/$reGpl/... [GPL] .../;
- $context =~ s/$reSquidCopy/... [Standard Squid "numerous individuals" text] .../;
- $context = substr($context, 0, $MaxLen);
- $context = &trimR($context);
- $context .= "\n\n";
- } else {
- $context = '';
- }
- $msg = sprintf("%s: WARNING: %s\n%s", $FileName, $msg, $context) if defined $FileName;
- warn($msg);
+ my ($msg, $context) = @_;
+
+ if (defined $context) {
+ my $MaxLen = 1000;
+ $context =~ s/$reGpl/... [GPL] .../;
+ $context =~ s/$reSquidCopy/... [Standard Squid "numerous individuals" text] .../;
+ $context = substr($context, 0, $MaxLen);
+ $context = &trimR($context);
+ $context .= "\n\n";
+ } else {
+ $context = '';
+ }
+ $msg = sprintf("%s: WARNING: %s\n%s", $FileName, $msg, $context) if defined $FileName;
+ warn($msg);
}
sub WarnQuiet() {
- my ($msg, $context) = @_;
+ my ($msg, $context) = @_;
- $msg = sprintf("%s: WARNING: %s\n", $FileName, $msg) if defined $FileName;
- warn($msg);
+ $msg = sprintf("%s: WARNING: %s\n", $FileName, $msg) if defined $FileName;
+ warn($msg);
}
@getfrom = ('SOURCE', 'localhost:3128', 'bo:3128');
require 'sys/socket.ph';
-$gettimeofday = 1128; # cheating, should use require syscall.ph
+$gettimeofday = 1128; # cheating, should use require syscall.ph
while (<>) {
- chop ($url = $_);
- print "$url:\n";
-
- foreach $k (@getfrom) {
- printf "%30.30s:\t", $k;
- if ($k eq 'SOURCE') {
- ($b_sec,$b_usec) = &gettimeofday;
- $n = &get_from_source($url);
- ($e_sec,$e_usec) = &gettimeofday;
- } else {
- ($host,$port) = split (':', $k);
- ($b_sec,$b_usec) = &gettimeofday;
- $n = &get_from_cache($host,$port,$url);
- ($e_sec,$e_usec) = &gettimeofday;
- }
- next unless ($n > 0);
- $d = ($e_sec - $b_sec) * 1000000 + ($e_usec - $b_usec);
- $d /= 1000000;
- $r = $n / $d;
- printf "%8.1f b/s (%7d bytes, %7.3f sec)\n",
- $r, $n, $d;
- $bps_sum{$k} += $r;
- $bps_n{$k}++;
- $bytes_sum{$k} += $n;
- $sec_sum{$k} += $d;
- }
+ chop ($url = $_);
+ print "$url:\n";
+
+ foreach $k (@getfrom) {
+ printf "%30.30s:\t", $k;
+ if ($k eq 'SOURCE') {
+ ($b_sec,$b_usec) = &gettimeofday;
+ $n = &get_from_source($url);
+ ($e_sec,$e_usec) = &gettimeofday;
+ } else {
+ ($host,$port) = split (':', $k);
+ ($b_sec,$b_usec) = &gettimeofday;
+ $n = &get_from_cache($host,$port,$url);
+ ($e_sec,$e_usec) = &gettimeofday;
+ }
+ next unless ($n > 0);
+ $d = ($e_sec - $b_sec) * 1000000 + ($e_usec - $b_usec);
+ $d /= 1000000;
+ $r = $n / $d;
+ printf "%8.1f b/s (%7d bytes, %7.3f sec)\n",
+ $r, $n, $d;
+ $bps_sum{$k} += $r;
+ $bps_n{$k}++;
+ $bytes_sum{$k} += $n;
+ $sec_sum{$k} += $d;
+ }
}
print "AVERAGE b/s rates:\n";
- foreach $k (@getfrom) {
- printf "%30.30s:\t%8.1f b/s (Alt: %8.1f b/s)\n",
- $k,
- $bps_sum{$k} / $bps_n{$k},
- $bytes_sum{$k} / $sec_sum{$k};
+foreach $k (@getfrom) {
+ printf "%30.30s:\t%8.1f b/s (Alt: %8.1f b/s)\n",
+ $k,
+ $bps_sum{$k} / $bps_n{$k},
+ $bytes_sum{$k} / $sec_sum{$k};
}
exit 0;
sub get_from_source {
- local($url) = @_;
- local($bytes) = 0;
- unless ($url =~ m!([a-z]+)://([^/]+)(.*)$!) {
- printf "get_from_source: bad URL\n";
- return 0;
- }
- $proto = $1;
- $host = $2;
- $url_path = $3;
- unless ($proto eq 'http') {
- printf "get_from_source: I only do HTTP\n";
- return 0;
- }
- $port = 80;
- if ($host =~ /([^:]+):(\d+)/) {
- $host = $1;
- $port = $2;
- }
- return 0 unless ($SOCK = &client_socket($host,$port));
- print $SOCK "GET $url_path HTTP/1.0\r\nAccept */*\r\n\r\n";
- $bytes += $n while (($n = read(SOCK,$_,4096)) > 0);
- close $SOCK;
- return $bytes;
+ local($url) = @_;
+ local($bytes) = 0;
+ unless ($url =~ m!([a-z]+)://([^/]+)(.*)$!) {
+ printf "get_from_source: bad URL\n";
+ return 0;
+ }
+ $proto = $1;
+ $host = $2;
+ $url_path = $3;
+ unless ($proto eq 'http') {
+ printf "get_from_source: I only do HTTP\n";
+ return 0;
+ }
+ $port = 80;
+ if ($host =~ /([^:]+):(\d+)/) {
+ $host = $1;
+ $port = $2;
+ }
+ return 0 unless ($SOCK = &client_socket($host,$port));
+ print $SOCK "GET $url_path HTTP/1.0\r\nAccept */*\r\n\r\n";
+ $bytes += $n while (($n = read(SOCK,$_,4096)) > 0);
+ close $SOCK;
+ return $bytes;
}
sub get_from_cache {
- local($host,$port,$url) = @_;
- local($bytes) = 0;
- return 0 unless ($SOCK = &client_socket($host,$port));
- print $SOCK "GET $url HTTP/1.0\r\nAccept */*\r\n\r\n";
- $bytes += $n while (($n = read(SOCK,$_,4096)) > 0);
- close $SOCK;
- return $bytes;
+ local($host,$port,$url) = @_;
+ local($bytes) = 0;
+ return 0 unless ($SOCK = &client_socket($host,$port));
+ print $SOCK "GET $url HTTP/1.0\r\nAccept */*\r\n\r\n";
+ $bytes += $n while (($n = read(SOCK,$_,4096)) > 0);
+ close $SOCK;
+ return $bytes;
}
sub client_socket {
- local ($host, $port) = @_;
- local ($sockaddr) = 'S n a4 x8';
- local ($name, $aliases, $proto) = getprotobyname('tcp');
- local ($connected) = 0;
-
- # Lookup addresses for remote hostname
- #
- local($w,$x,$y,$z,@thataddrs) = gethostbyname($host);
- unless (@thataddrs) {
- printf "Unknown Host: $host\n";
- return ();
- }
-
- # bind local socket to INADDR_ANY
- #
- local ($thissock) = pack($sockaddr, &AF_INET, 0, "\0\0\0\0");
- unless (socket (SOCK, &AF_INET, &SOCK_STREAM, $proto)) {
- printf "socket: $!\n";
- return ();
- }
- unless (bind (SOCK, $thissock)) {
- printf "bind: $!\n";
- return ();
- }
-
- # Try all addresses
- #
- foreach $thataddr (@thataddrs) {
- local ($that) = pack($sockaddr, &AF_INET, $port, $thataddr);
- if (connect (SOCK, $that)) {
- $connected = 1;
- last;
- }
+ local ($host, $port) = @_;
+ local ($sockaddr) = 'S n a4 x8';
+ local ($name, $aliases, $proto) = getprotobyname('tcp');
+ local ($connected) = 0;
+
+ # Lookup addresses for remote hostname
+ #
+ local($w,$x,$y,$z,@thataddrs) = gethostbyname($host);
+ unless (@thataddrs) {
+ printf "Unknown Host: $host\n";
+ return ();
+ }
+
+ # bind local socket to INADDR_ANY
+ #
+ local ($thissock) = pack($sockaddr, &AF_INET, 0, "\0\0\0\0");
+ unless (socket (SOCK, &AF_INET, &SOCK_STREAM, $proto)) {
+ printf "socket: $!\n";
+ return ();
+ }
+ unless (bind (SOCK, $thissock)) {
+ printf "bind: $!\n";
+ return ();
+ }
+
+ # Try all addresses
+ #
+ foreach $thataddr (@thataddrs) {
+ local ($that) = pack($sockaddr, &AF_INET, $port, $thataddr);
+ if (connect (SOCK, $that)) {
+ $connected = 1;
+ last;
}
- unless ($connected) {
- printf "$host:$port: $!\n";
- return ();
- }
-
- # Set socket to flush-after-write and return it
- #
- select (SOCK); $| = 1;
- select (STDOUT);
- return (SOCK);
+ }
+ unless ($connected) {
+ printf "$host:$port: $!\n";
+ return ();
+ }
+
+ # Set socket to flush-after-write and return it
+ #
+ select (SOCK); $| = 1;
+ select (STDOUT);
+ return (SOCK);
}
sub gettimeofday {
- $tvp="\0\0\0\0\0\0\0\0";
- syscall($gettimeofday, $tvp, $tz);
- return unpack('ll', $tvp);
+ $tvp="\0\0\0\0\0\0\0\0";
+ syscall($gettimeofday, $tvp, $tz);
+ return unpack('ll', $tvp);
}
sub try_http_11 {
- local($url) = @_;
- local($path) = undef;
-
- $source = $1 if ($url =~ /^[^:]+:\/\/([^:\/]+)/);
-
- die "socket: $!\n" unless
- socket (SOCK, &AF_INET, &SOCK_STREAM, $proto);
- die "bind: $!\n" unless
- bind (SOCK, $thissock);
- die "$proxy:$port: $!\n" unless
- connect (SOCK, $that);
- select (SOCK); $| = 1;
- select (STDOUT);
- print SOCK "TRACE $url HTTP/1.1\r\nHost: $host\r\nAccept: */*\r\n\r\n";
- while (<SOCK>) {
- s/\r//g;
- s/\n//g;
- $code = $1 if (/^HTTP\/\d\.\d (\d+)/);
- $server = $1 if (/^Server:\s*(.*)$/);
- $path = $1 if (/^Via:\s*(.*)$/);
- }
- return 0 unless ($path && $code == 200);
- print "Received TRACE reply from $source\n";
- @F = split(',', $path);
- $i = 0;
- foreach $n (@F) {
- $n =~ s/^\s+//;
- printf " %2d %s\n", ++$i, $n;
- }
- printf " %2d %s (%s)\n", ++$i, $source, $server;
- 1;
+ local($url) = @_;
+ local($path) = undef;
+
+ $source = $1 if ($url =~ /^[^:]+:\/\/([^:\/]+)/);
+
+ die "socket: $!\n" unless
+ socket (SOCK, &AF_INET, &SOCK_STREAM, $proto);
+ die "bind: $!\n" unless
+ bind (SOCK, $thissock);
+ die "$proxy:$port: $!\n" unless
+ connect (SOCK, $that);
+ select (SOCK); $| = 1;
+ select (STDOUT);
+ print SOCK "TRACE $url HTTP/1.1\r\nHost: $host\r\nAccept: */*\r\n\r\n";
+ while (<SOCK>) {
+ s/\r//g;
+ s/\n//g;
+ $code = $1 if (/^HTTP\/\d\.\d (\d+)/);
+ $server = $1 if (/^Server:\s*(.*)$/);
+ $path = $1 if (/^Via:\s*(.*)$/);
+ }
+ return 0 unless ($path && $code == 200);
+ print "Received TRACE reply from $source\n";
+ @F = split(',', $path);
+ $i = 0;
+ foreach $n (@F) {
+ $n =~ s/^\s+//;
+ printf " %2d %s\n", ++$i, $n;
+ }
+ printf " %2d %s (%s)\n", ++$i, $source, $server;
+ 1;
}
+
#
# Author: Tsantilas Christos
# (C) 2010 The Measurement Factory
-#
-# Usage:
+#
+# Usage:
# calc-must-ids.pl file1 file2 ...
# Compute the ids of Must expressions of the given files.
# It returns one line per Must expression in the form:
my($n) = 0;
my(@na) = split(//, $name);
for($j=0; $j < @na; $j++) {
- $n = $n ^ (271 * ord($na[$j]));
+ $n = $n ^ (271 * ord($na[$j]));
}
return $n ^ ($j *271);
}
$id += ERR_DETAIL_EXCEPTION_START;
# print "$file:$.: $id $line";
printf "%s:%d: 0x%X %s", $file, $., $id, $line;
- }
- }
+ }
+ }
close(IN);
}
## Please see the COPYING and CONTRIBUTORS files for details.
##
-# check_cache.pl
+# check_cache.pl
#
# Squid-1.0 version by martin hamilton <m.t.hamilton@lut.ac.uk>
# Squid-1.1 version by Bertold Kolics <bertold@tohotom.vein.hu>
require "getopts.pl";
&Getopts("c:drt:vh");
-# -c : the full path to squid.conf
-# -d : turn on debugging
-# -r : actually remove stale files
-# -t tmpdir : temporary directory
-# -v : list stale files
-# -h : print the help
+# -c : the full path to squid.conf
+# -d : turn on debugging
+# -r : actually remove stale files
+# -t tmpdir : temporary directory
+# -v : list stale files
+# -h : print the help
if ($opt_h) {
- print "Usage: check_cache.pl -drvh -c squid.conf\n";
- print "\t-c the full path to squid.conf\n";
- print "\t-d turn on debugging\n";
- print "\t-r actually remove stale files\n";
- print "\t-t temporary directory\n";
- print "\t-v list stale files\n";
- print "\t-h print the help\n";
- exit;
+ print "Usage: check_cache.pl -drvh -c squid.conf\n";
+ print "\t-c the full path to squid.conf\n";
+ print "\t-d turn on debugging\n";
+ print "\t-r actually remove stale files\n";
+ print "\t-t temporary directory\n";
+ print "\t-v list stale files\n";
+ print "\t-h print the help\n";
+ exit;
}
$squidconf = $opt_c || "/usr/local/squid/etc/squid.conf";
$level1dirno = 16;
$level2dirno = 256;
while (<squidconf>) {
- chop;
- if (/^cache_dir\s+(.*)/) {
- push (@cachedir, $1);
- } elsif (/cache_swap_log\s+(.*)/) {
- $swaplog = $1;
- } elsif (/swap_level1_dirs/) {
- $level1dirno = $1;
- } elsif (/swap_level21_dirs/) {
- $level2dirno = $1;
- }
+ chop;
+ if (/^cache_dir\s+(.*)/) {
+ push (@cachedir, $1);
+ } elsif (/cache_swap_log\s+(.*)/) {
+ $swaplog = $1;
+ } elsif (/swap_level1_dirs/) {
+ $level1dirno = $1;
+ } elsif (/swap_level21_dirs/) {
+ $level2dirno = $1;
+ }
}
close (squidconf);
push (@cachedir, '/usr/local/squid/cache') unless ($#cachedir > $[-1);
# get list of files in cache & sort em
for ($i = 0 ; $i < $no_cachedir; $i++) {
- chdir($cachedir[i]);
- system("find ./ -print -type f > $tmpdir/fp$$");
- chdir($tmpdir);
+ chdir($cachedir[i]);
+ system("find ./ -print -type f > $tmpdir/fp$$");
+ chdir($tmpdir);
# this cut prints only the lines with 4 fields so unnecessary lines
-# are supressed
- system("cut -d'/' -f4 -s fp$$ >> cd$$ ; rm fp$$")
+# are suppressed
+ system("cut -d'/' -f4 -s fp$$ >> cd$$ ; rm fp$$")
}
system("sort -T $tmpdir cd$$ >scd$$; rm cd$$");
open(IN, "comm$$") || die "Can't open temporary file $tmpdir/comm$$: $!";
unlink("comm$$");
while(<IN>) {
- chop;
- $filename = $_;
+ chop;
+ $filename = $_;
# calculate the full path of the current filename
- $fileno = hex($filename);
- $dirno = $fileno % $no_cachedir;
- $a = $fileno / $no_cachedir;
- $level1 = sprintf("%02X", $a % $level1dirno);
- $level2 = sprintf("%02X", $a / $level1dirno % $level2dirno);
- $filename = "$cachedir[dirno]/$level1/$level2/$filename";
+ $fileno = hex($filename);
+ $dirno = $fileno % $no_cachedir;
+ $a = $fileno / $no_cachedir;
+ $level1 = sprintf("%02X", $a % $level1dirno);
+ $level2 = sprintf("%02X", $a / $level1dirno % $level2dirno);
+ $filename = "$cachedir[dirno]/$level1/$level2/$filename";
- next if -d "$filename"; # don't want directories
+ next if -d "$filename"; # don't want directories
- print "$filename\n" if $opt_v; # print filename if asked
+ print "$filename\n" if $opt_v; # print filename if asked
- # skip if cached file appeared since script started running
- if (-M $filename < 0) {
- print STDERR "skipping $filename\n" if $opt_d;
- next;
- }
- print "Orphan: $filename\n";
- unlink($filename) if $opt_r; # only remove if asked!
+ # skip if cached file appeared since script started running
+ if (-M $filename < 0) {
+ print STDERR "skipping $filename\n" if $opt_d;
+ next;
+ }
+ print "Orphan: $filename\n";
+ unlink($filename) if $opt_r; # only remove if asked!
}
close(IN);
## Please see the COPYING and CONTRIBUTORS files for details.
##
-# Convert hexadecimal cache file numbers (from swap log) into full pathnames.
+# Convert hexadecimal cache file numbers (from swap log) into full pathnames.
# Duane Wessels 6/30/97
# 2001-12-18 Adapted for squid-2.x Alain Thivillon <at@rominet.net>
my $ncache_dirs = 0;
while (<CF>) {
- # Squid 2.3 ===>
- # cache_dir ufs path size L1 L2
- if (/^cache_dir\s+(\S+)\s+(\S+)\s+\d+\s+(\S+)\s+(\S+)/i) {
- $CD[$ncache_dirs] = $2;
- $L1[$ncache_dirs] = $3;
- $L2[$ncache_dirs++] = $4;
- }
+ # Squid 2.3 ===>
+ # cache_dir ufs path size L1 L2
+ if (/^cache_dir\s+(\S+)\s+(\S+)\s+\d+\s+(\S+)\s+(\S+)/i) {
+ $CD[$ncache_dirs] = $2;
+ $L1[$ncache_dirs] = $3;
+ $L2[$ncache_dirs++] = $4;
+ }
}
close(CF);
if ($ncache_dirs == 0) {
- print STDERR "No proper cache_dir line found\n";
- exit 2;
+ print STDERR "No proper cache_dir line found\n";
+ exit 2;
}
while (<>) {
- chop;
- print &storeSwapFullPath(hex($_)), "\n";
+ chop;
+ print &storeSwapFullPath(hex($_)), "\n";
}
sub storeSwapFullPath {
- my($fn) = @_;
+ my($fn) = @_;
- my $dirn = ($fn >> $SWAP_DIR_SHIFT) % $ncache_dirs;
- my $filn = $fn & $SWAP_FILE_MASK;
+ my $dirn = ($fn >> $SWAP_DIR_SHIFT) % $ncache_dirs;
+ my $filn = $fn & $SWAP_FILE_MASK;
- sprintf "%s/%02X/%02X/%08X",
- $CD[$dirn],
- (($fn / $L2[$dirn]) / $L2[$dirn]) % $L1[$dirn],
- ($fn / $L2[$dirn]) % $L2[$dirn],
- $fn;
+ sprintf "%s/%02X/%02X/%08X",
+ $CD[$dirn],
+ (($fn / $L2[$dirn]) / $L2[$dirn]) % $L1[$dirn],
+ ($fn / $L2[$dirn]) % $L2[$dirn],
+ $fn;
}
sub usage {
- print STDERR "usage: $0 -c config\n";
- print STDERR "hexadecimal file numbers are read from stdin\n";
- exit 1;
+ print STDERR "usage: $0 -c config\n";
+ print STDERR "hexadecimal file numbers are read from stdin\n";
+ exit 1;
}
# We try to do that now (see "guessing ..." below), but it does
# not always work.
my %Pairs = (
- AsyncCall => [
- 'AsyncCall.* constructed, this=(\S+)',
- 'AsyncCall.* destruct.*, this=(\S+)',
- ],
- HttpHeaderEntry => [
- '\bHttpHeaderEntry.* created HttpHeaderEntry (\S+)',
- '\bHttpHeaderEntry.* destroying entry (\S+)',
- ],
- ClientSocketContext => [
- '\bClientSocketContext constructing, this=(\S+)',
- '\bClientSocketContext destructed, this=(\S+)',
- ],
- ICAP => [
- '(?:ICAP|Icap).* constructed, this=(\S+)',
- '(?:ICAP|Icap).* destruct.*, this=(\S+)',
- ],
- IcapModXact => [
- 'Adaptation::Icap::ModXact.* constructed, this=(\S+)',
- 'Adaptation::Icap::ModXact.* destruct.*, this=(\S+)',
- ],
- ICAPClientReqmodPrecache => [
- 'ICAPClientReqmodPrecache constructed, this=(\S+)',
- 'ICAPClientReqmodPrecache destruct.*, this=(\S+)',
- ],
- HttpStateData => [
- 'HttpStateData (\S+) created',
- 'HttpStateData (\S+) destroyed',
- ],
- cbdata => [
- 'cbdataInternalAlloc: Allocating (\S+)',
- 'cbdataRealFree: Freeing (\S+)',
- ],
- FD => [
- 'fd_open.*\sFD (\d+)',
- 'fd_close\s+FD (\d+)',
- ],
- IpcStoreMapEntry => [
- 'StoreMap.* opened .*entry (\d+) for \S+ (\S+)',
- 'StoreMap.* closed .*entry (\d+) for \S+ (\S+)',
- ],
- sh_page => [
- 'PageStack.* pop: (sh_page\S+) at',
- 'PageStack.* push: (sh_page\S+) at',
- ],
-);
+ AsyncCall => [
+ 'AsyncCall.* constructed, this=(\S+)',
+ 'AsyncCall.* destruct.*, this=(\S+)',
+ ],
+ HttpHeaderEntry => [
+ '\bHttpHeaderEntry.* created HttpHeaderEntry (\S+)',
+ '\bHttpHeaderEntry.* destroying entry (\S+)',
+ ],
+ ClientSocketContext => [
+ '\bClientSocketContext constructing, this=(\S+)',
+ '\bClientSocketContext destructed, this=(\S+)',
+ ],
+ ICAP => [
+ '(?:ICAP|Icap).* constructed, this=(\S+)',
+ '(?:ICAP|Icap).* destruct.*, this=(\S+)',
+ ],
+ IcapModXact => [
+ 'Adaptation::Icap::ModXact.* constructed, this=(\S+)',
+ 'Adaptation::Icap::ModXact.* destruct.*, this=(\S+)',
+ ],
+ ICAPClientReqmodPrecache => [
+ 'ICAPClientReqmodPrecache constructed, this=(\S+)',
+ 'ICAPClientReqmodPrecache destruct.*, this=(\S+)',
+ ],
+ HttpStateData => [
+ 'HttpStateData (\S+) created',
+ 'HttpStateData (\S+) destroyed',
+ ],
+ cbdata => [
+ 'cbdataInternalAlloc: Allocating (\S+)',
+ 'cbdataRealFree: Freeing (\S+)',
+ ],
+ FD => [
+ 'fd_open.*\sFD (\d+)',
+ 'fd_close\s+FD (\d+)',
+ ],
+ IpcStoreMapEntry => [
+ 'StoreMap.* opened .*entry (\d+) for \S+ (\S+)',
+ 'StoreMap.* closed .*entry (\d+) for \S+ (\S+)',
+ ],
+ sh_page => [
+ 'PageStack.* pop: (sh_page\S+) at',
+ 'PageStack.* push: (sh_page\S+) at',
+ ],
+ );
if (!$Pairs{$Thing}) {
warn("guessing construction/destruction pattern for $Thing\n");
$Pairs{$Thing} = [
- "\\b$Thing construct.*, this=(\\S+)",
- "\\b$Thing destruct.*, this=(\\S+)",
- ];
+ "\\b$Thing construct.*, this=(\\S+)",
+ "\\b$Thing destruct.*, this=(\\S+)",
+ ];
}
die("unsupported Thing, stopped") unless $Pairs{$Thing};
my %AliveImage = ();
my $Count = 0;
while (<STDIN>) {
- if (my @conIds = (/$reConstructor/)) {
- my $id = join(':', @conIds);
- #die($_) if $Alive{$id};
- $AliveImage{$id} = $_;
- ++$Count unless $AliveCount{$id}++;
- }
- elsif (my @deIds = (/$reDestructor/)) {
- my $id = join(':', @deIds);
- if ($AliveCount{$id}) {
- $AliveImage{$id} = undef() unless --$AliveCount{$id};
- } else {
- #warn("unborn: $_");
- # do nothing; we are probably looking at a partial log
- }
- }
+ if (my @conIds = (/$reConstructor/)) {
+ my $id = join(':', @conIds);
+ #die($_) if $Alive{$id};
+ $AliveImage{$id} = $_;
+ ++$Count unless $AliveCount{$id}++;
+ }
+ elsif (my @deIds = (/$reDestructor/)) {
+ my $id = join(':', @deIds);
+ if ($AliveCount{$id}) {
+ $AliveImage{$id} = undef() unless --$AliveCount{$id};
+ } else {
+ #warn("unborn: $_");
+ # do nothing; we are probably looking at a partial log
+ }
+ }
}
printf(STDERR "Found %d %s\n", $Count, $Thing);
my $aliveCount = 0;
foreach my $alive (sort grep { defined($_) } values %AliveImage) {
- next unless defined $alive;
- printf("Alive: %s", $alive);
- ++$aliveCount;
+ next unless defined $alive;
+ printf("Alive: %s", $alive);
+ ++$aliveCount;
}
printf(STDERR "found %d still-alive %s\n", $aliveCount, $Thing);
# -d -> turn on debugging output
# pass filenames on command line or via STDIN
-@things = $#ARGV >= 0 ? @ARGV : <STDIN>;
+@things = $#ARGV >= 0 ? @ARGV : <STDIN>;
$total_objects = 0, $content_length = 0;
# iterate through them
foreach $thing (@things) {
- chop $thing;
+ chop $thing;
- $opt_d && (print STDERR ">> inspecting: $thing\n");
- next if -d "$thing"; # don't want directories
+ $opt_d && (print STDERR ">> inspecting: $thing\n");
+ next if -d "$thing"; # don't want directories
- $size = (stat($thing))[$ST_SIZE]||next;
- $opt_d && (print STDERR ">> stat: $size\n");
- print "$thing\n", next if ($size == 0);
+ $size = (stat($thing))[$ST_SIZE]||next;
+ $opt_d && (print STDERR ">> stat: $size\n");
+ print "$thing\n", next if ($size == 0);
- $total_objects++;
+ $total_objects++;
- $count = 0, $expected = 0;
- open(IN, "$thing") || die "Can't open cached object $thing: $!";
- while(<IN>) {
- $count += length($_);
- chop;
- print STDERR ">> inspecting $_\n" if $opt_d;
- last if /^(\s+|)$/; # drop out after the end of the HTTP headers
+ $count = 0, $expected = 0;
+ open(IN, "$thing") || die "Can't open cached object $thing: $!";
+ while(<IN>) {
+ $count += length($_);
+ chop;
+ print STDERR ">> inspecting $_\n" if $opt_d;
+ last if /^(\s+|)$/; # drop out after the end of the HTTP headers
- # skip if cached file appeared since script started running
- if (-M $_ < 0) {
- print STDERR ">> skipping $_\n" if $opt_d;
- next;
- }
-
- if (/^Content-length:\s+(\d+)/i) {
- $expected = $1;
- $content_length++;
+ # skip if cached file appeared since script started running
+ if (-M $_ < 0) {
+ print STDERR ">> skipping $_\n" if $opt_d;
+ next;
+ }
+
+ if (/^Content-length:\s+(\d+)/i) {
+ $expected = $1;
+ $content_length++;
+ }
}
- }
- close(IN);
+ close(IN);
- next if $opt_c;
- next if $expected == 0; # no Content-length header
+ next if $opt_c;
+ next if $expected == 0; # no Content-length header
- # looked at the headers now
- $difference = $size - $count;
- $opt_d && print STDERR ">> real: ", $difference, ", expected: $expected\n";
- if ($difference != $expected) {
- print "$thing (expected: $expected, got: $difference)\n";
- }
+ # looked at the headers now
+ $difference = $size - $count;
+ $opt_d && print STDERR ">> real: ", $difference, ", expected: $expected\n";
+ if ($difference != $expected) {
+ print "$thing (expected: $expected, got: $difference)\n";
+ }
}
print "$content_length out of $total_objects had Content-length: header\n"
- if $opt_c;
+ if $opt_c;
my $out = shift @ARGV;
#read options, currently no options available
while($out eq "" || $out =~ /^-\w+$/){
- if($out eq "-h") {
+ if($out eq "-h") {
usage($0);
exit 0;
- }
- else {
- usage($0);
- exit -1;
- }
+ } else {
+ usage($0);
+ exit -1;
+ }
}
while($out){
if( $out !~ /\.cc$|\.cci$|\.h$|\.c$/) {
- print "Unknown suffix for file $out, ignoring....\n";
- $out = shift @ARGV;
- next;
+ print "Unknown suffix for file $out, ignoring....\n";
+ $out = shift @ARGV;
+ next;
}
my $in= "$out.astylebak";
my($new_in) = $in;
my($i) = 0;
while(-e $new_in) {
- $new_in=$in.".".$i;
- $i++;
+ $new_in=$in.".".$i;
+ $i++;
}
$in=$new_in;
rename($out, $in);
-
+
local (*FROM_ASTYLE, *TO_ASTYLE);
my $pid_style=open2(\*FROM_ASTYLE, \*TO_ASTYLE, $ASTYLE_BIN);
-
+
if(!$pid_style){
print "An error while open2\n";
exit -1;
my $pid;
if($pid=fork()){
- #do parrent staf
- close(FROM_ASTYLE);
-
- if(!open(IN, "<$in")){
- print "Can not open input file: $in\n";
- exit -1;
- }
- my($line) = '';
- while(<IN>){
- $line=$line.$_;
- if(input_filter(\$line)==0){
- next;
- }
- print TO_ASTYLE $line;
- $line = '';
- }
- if($line){
- print TO_ASTYLE $line;
- }
- close(TO_ASTYLE);
- waitpid($pid,0);
+ #do parent staf
+ close(FROM_ASTYLE);
+
+ if (!open(IN, "<$in")) {
+ print "Can not open input file: $in\n";
+ exit -1;
+ }
+ my $line = '';
+ while (<IN>) {
+ $line=$line.$_;
+ if (input_filter(\$line)==0) {
+ next;
+ }
+ print TO_ASTYLE $line;
+ $line = '';
+ }
+ if ($line) {
+ print TO_ASTYLE $line;
+ }
+ close(TO_ASTYLE);
+ waitpid($pid,0);
}
else{
- # child staf
- close(TO_ASTYLE);
-
- if(!open(OUT,">$out")){
- print "Can't open output file: $out\n";
- exit -1;
- }
- my($line)='';
- while(<FROM_ASTYLE>){
- $line = $line.$_;
- if(output_filter(\$line)==0){
- next;
- }
- print OUT $line;
- $line = '';
- }
- if($line){
- print OUT $line;
- }
- close(OUT);
- exit 0;
+ # child staf
+ close(TO_ASTYLE);
+
+ if(!open(OUT,">$out")){
+ print "Can't open output file: $out\n";
+ exit -1;
+ }
+ my($line)='';
+ while(<FROM_ASTYLE>){
+ $line = $line.$_;
+ if(output_filter(\$line)==0){
+ next;
+ }
+ print OUT $line;
+ $line = '';
+ }
+ if($line){
+ print OUT $line;
+ }
+ close(OUT);
+ exit 0;
}
$out = shift @ARGV;
sub input_filter{
my($line)=@_;
- #if we have integer declaration, get it all before processing it..
+ #if we have integer declaration, get it all before processing it..
if($$line =~/\s+int\s+.*/s || $$line=~ /\s+unsigned\s+.*/s ||
- $$line =~/^int\s+.*/s || $$line=~ /^unsigned\s+.*/s
- ){
- if( $$line =~ /(\(|,|\)|\#|typedef)/s ){
- #excluding int/unsigned appeared inside function prototypes,typedefs etc....
- return 1;
- }
-
- if(index($$line,";") == -1){
-# print "Getting one more for \"".$$line."\"\n";
- return 0;
- }
-
- if($$line =~ /(.*)\s*int\s+([^:]*):\s*(\w+)\s*\;(.*)/s){
-# print ">>>>> ".$$line." ($1)\n";
+ $$line =~/^int\s+.*/s || $$line=~ /^unsigned\s+.*/s
+ ) {
+ if( $$line =~ /(\(|,|\)|\#|typedef)/s ){
+ # excluding int/unsigned appeared inside function prototypes,
+ # typedefs etc....
+ return 1;
+ }
+
+ if(index($$line,";") == -1){
+ # print "Getting one more for \"".$$line."\"\n";
+ return 0;
+ }
+
+ if($$line =~ /(.*)\s*int\s+([^:]*):\s*(\w+)\s*\;(.*)/s){
+ # print ">>>>> ".$$line." ($1)\n";
my ($prx,$name,$val,$extra)=($1,$2,$3,$4);
$prx =~ s/\s*$//g;
- $$line= $prx." int ".$name."__FORASTYLE__".$val.";".$extra;
-# print "----->".$$line."\n";
- }
- elsif($$line =~ /\s*unsigned\s+([^:]*):\s*(\w+)\s*\;(.*)/s){
-# print ">>>>> ".$$line." ($1)\n";
+ $$line= $prx." int ".$name."__FORASTYLE__".$val.";".$extra;
+ # print "----->".$$line."\n";
+ }
+ elsif($$line =~ /\s*unsigned\s+([^:]*):\s*(\w+)\s*\;(.*)/s){
+ # print ">>>>> ".$$line." ($1)\n";
my ($name,$val,$extra)=($1,$2,$3);
my $prx =~ s/\s*$//g;
- $$line= "unsigned ".$name."__FORASTYLE__".$val.";".$extra;
-# print "----->".$$line."\n";
- }
- return 1;
+ $$line= "unsigned ".$name."__FORASTYLE__".$val.";".$extra;
+ # print "----->".$$line."\n";
+ }
+ return 1;
}
if($$line =~ /\#endif/ ||
- $$line =~ /\#else/ ||
- $$line =~ /\#if/
- ){
- $$line =$$line."//__ASTYLECOMMENT__\n";
- return 1;
+ $$line =~ /\#else/ ||
+ $$line =~ /\#if/
+ ) {
+ $$line =$$line."//__ASTYLECOMMENT__\n";
+ return 1;
}
return 1;
# collapse multiple empty lines onto the first one
if($$line =~ /^\s*$/){
- if ($last_line_was_empty==1) {
- $$line="";
- return 0;
- } else {
- $last_line_was_empty=1;
- return 1;
- }
+ if ($last_line_was_empty==1) {
+ $$line="";
+ return 0;
+ } else {
+ $last_line_was_empty=1;
+ return 1;
+ }
} else {
- $last_line_was_empty=0;
+ $last_line_was_empty=0;
}
if($$line =~ s/\s*\/\/__ASTYLECOMMENT__//) {
- chomp($$line);
+ chomp($$line);
}
-
- # "The "unsigned int:1; case ....."
- $$line =~ s/__FORASTYLE__/:/;
- return 1;
+ # "The "unsigned int:1; case ....."
+ $$line =~ s/__FORASTYLE__/:/;
+
+ return 1;
}
sub usage{
## Please see the COPYING and CONTRIBUTORS files for details.
##
-# icp-test.pl
+# icp-test.pl
#
# Duane Wessels, Nov 1996
#
"UDP_DENIED",
"UDP_HIT_OBJ",
"ICP_END"
-);
+ );
require 'sys/socket.ph';
$myip=(gethostbyname($me))[4];
die "socket: $!\n" unless
- socket (SOCK, &AF_INET, &SOCK_DGRAM, $proto);
+ socket (SOCK, &AF_INET, &SOCK_DGRAM, $proto);
$flags = 0;
$flags |= 0x80000000;
$flags = ~0;
while ($ARGV[0] =~ /([^:]+):(\d+)/) {
- $host = $1;
- $port = $2;
- ($fqdn, $aliases, $type, $len, $themaddr) = gethostbyname($host);
- $ADDR{$host} = pack('Sna4x8', &AF_INET, $port, $themaddr);
- $ip = join('.', unpack('C4', $themaddr));
- $FQDN{$ip} = $fqdn;
- shift;
+ $host = $1;
+ $port = $2;
+ ($fqdn, $aliases, $type, $len, $themaddr) = gethostbyname($host);
+ $ADDR{$host} = pack('Sna4x8', &AF_INET, $port, $themaddr);
+ $ip = join('.', unpack('C4', $themaddr));
+ $FQDN{$ip} = $fqdn;
+ shift;
}
$rn = 0;
while (<>) {
- print;
- chop;
- $len = length($_) + 1;
- $request_template = sprintf 'CCnNNa4a4x4a%d', $len;
- $request = pack($request_template,
- 1, # C opcode
- 2, # C version
- 24 + $len, # n length
- ++$rn, # N reqnum
- $flags, # N flags
- '', # a4 pad
- $myip, # a4 shostid
- $_); # a%d payload
- $n = 0;
- foreach $host (keys %ADDR) {
- $port = $PORT{$host};
- @ip = split('\.', $IP{$host});
- $them = pack('SnC4x8', &AF_INET, $port, @ip);
- ($sport,@IP) = unpack('x2nC4x8', $ADDR{$host});
- die "send: $!\n" unless send(SOCK, $request, 0, $ADDR{$host});
- $n++;
- }
- while ($n > 0) {
- $rin = '';
- vec($rin,fileno(SOCK),1) = 1;
- ($nfound,$timeleft) = select($rout=$rin, undef, undef, 2.0);
- last if ($nfound == 0);
- die "recv: $!\n" unless
- $theiraddr = recv(SOCK, $reply, 1024, 0);
- ($junk, $junk, $sourceaddr, $junk) = unpack($sockaddr, $theiraddr);
- $ip = join('.', unpack('C4', $sourceaddr));
- ($type,$ver,$len,$flag,$p1,$p2,$payload) = unpack('CCnx4Nnnx4A', $reply);
- printf "\t%-20.20s %-10.10s",
- $FQDN{$ip},
- $CODES[$type];
- print " hop=$p1" if ($opt_n);
- print " rtt=$p2" if ($opt_n);
- print "\n";
- $n--;
- }
+ print;
+ chop;
+ $len = length($_) + 1;
+ $request_template = sprintf 'CCnNNa4a4x4a%d', $len;
+ $request = pack($request_template,
+ 1, # C opcode
+ 2, # C version
+ 24 + $len, # n length
+ ++$rn, # N reqnum
+ $flags, # N flags
+ '', # a4 pad
+ $myip, # a4 shostid
+ $_); # a%d payload
+ $n = 0;
+ foreach $host (keys %ADDR) {
+ $port = $PORT{$host};
+ @ip = split('\.', $IP{$host});
+ $them = pack('SnC4x8', &AF_INET, $port, @ip);
+ ($sport,@IP) = unpack('x2nC4x8', $ADDR{$host});
+ die "send: $!\n" unless send(SOCK, $request, 0, $ADDR{$host});
+ $n++;
+ }
+ while ($n > 0) {
+ $rin = '';
+ vec($rin,fileno(SOCK),1) = 1;
+ ($nfound,$timeleft) = select($rout=$rin, undef, undef, 2.0);
+ last if ($nfound == 0);
+ die "recv: $!\n" unless
+ $theiraddr = recv(SOCK, $reply, 1024, 0);
+ ($junk, $junk, $sourceaddr, $junk) = unpack($sockaddr, $theiraddr);
+ $ip = join('.', unpack('C4', $sourceaddr));
+ ($type,$ver,$len,$flag,$p1,$p2,$payload) = unpack('CCnx4Nnnx4A', $reply);
+ printf "\t%-20.20s %-10.10s",
+ $FQDN{$ip},
+ $CODES[$type];
+ print " hop=$p1" if ($opt_n);
+ print " rtt=$p2" if ($opt_n);
+ print "\n";
+ $n--;
+ }
}
# by looking at CERN or Netscape style cache directory $cachedir
#
# martin hamilton <m.t.hamilton@lut.ac.uk>
-# Id: icpserver,v 1.11 1995/11/24 16:20:13 martin Exp martin
+# Id: icpserver,v 1.11 1995/11/24 16:20:13 martin Exp martin
# usage: icpserver [-c cachedir] [-n] [-p port] [multicast_group]
#
$CACHEDIR=$opt_c||"/usr/local/www/cache";
$PORT=$opt_p||3130;
$SERVER=$ARGV[0]||"0.0.0.0";
-$SERVERIP= ($SERVER =~ m!\d+.\d+.\d+.\d+!) ?
- pack("C4", split(/\./, $SERVER)) : (gethostbyname($SERVER))[4]; # lazy!
+$SERVERIP= ($SERVER =~ m!\d+.\d+.\d+.\d+!) ?
+ pack("C4", split(/\./, $SERVER)) : (gethostbyname($SERVER))[4]; # lazy!
$SOCKADDR = 'S n a4 x8';
#bind(S, $us2) || die "Couldn't bind socket: $!";
if ($SERVER ne "0.0.0.0") { # i.e. multicast
- $whoami = (`uname -a`)[0];
- $IP_ADD_MEMBERSHIP=5;
- $whoami =~ /SunOS [^\s]+ 5/ && ($IP_MULTICAST_TTL=19);
- $whoami =~ /IRIX [^\s]+ 5/ && ($IP_MULTICAST_TTL=23);
- $whoami =~ /OSF1/ && ($IP_MULTICAST_TTL=12);
- # any more funnies ?
-
- setsockopt(S, 0, $IP_ADD_MEMBERSHIP, $SERVERIP."\0\0\0\0")
- || die "Couldn't join multicast group $SERVER: $!";
+ $whoami = (`uname -a`)[0];
+ $IP_ADD_MEMBERSHIP=5;
+ $whoami =~ /SunOS [^\s]+ 5/ && ($IP_MULTICAST_TTL=19);
+ $whoami =~ /IRIX [^\s]+ 5/ && ($IP_MULTICAST_TTL=23);
+ $whoami =~ /OSF1/ && ($IP_MULTICAST_TTL=12);
+ # any more funnies ?
+
+ setsockopt(S, 0, $IP_ADD_MEMBERSHIP, $SERVERIP."\0\0\0\0")
+ || die "Couldn't join multicast group $SERVER: $!";
}
# Common header for ICP datagrams ... (size in bytes - total 20)
# Might be fast enough to get away without forking or non-blocking I/O ... ?
while(1) {
- $theiraddr = recv(S, $ICP_request, 1024, 0);
- ($junk, $junk, $sourceaddr, $junk) = unpack($SOCKADDR, $theiraddr);
- @theirip = unpack('C4', $sourceaddr);
-
- $URL_length = length($ICP_request) - 24;
- $request_template = 'CCnx4x8x4a4a' . $URL_length;
- ($type, $version, $length, $requester, $URL) =
- unpack($request_template, $ICP_request);
-
- $URL =~ s/\.\.\///g; # be cautious - any others to watch out for ?
-
- # lookup object in cache
- $hitmisserr = 3;
- if ($type eq 1 && $URL =~ m!^([^:]+):/?/?([^/]+)/(.*)!) {
- $scheme = $1; $hostport = $2; $path = $3;
- if ($path eq "") { $path = "index.html"; }
-
- if ($opt_n) {
- ($host, $port) = split(/:/, $hostport); # strip off port number
- $port = ":$port" if ($port);
- $match = "";
- foreach (split(/\./, $hostport)) {
- $match = "$_/$match"; # little-endian -> big-endian conversion
- }
- $match = "$CACHEDIR/hosts/$match$scheme$port.urls"; # full path
- if (-f "$match") {
- #### optimize! ####
- open(IN, "$match") && do {
- while(<IN>) { /^$URL / && ($hitmisserr = 2, last); }
- close(IN);
+ $theiraddr = recv(S, $ICP_request, 1024, 0);
+ ($junk, $junk, $sourceaddr, $junk) = unpack($SOCKADDR, $theiraddr);
+ @theirip = unpack('C4', $sourceaddr);
+
+ $URL_length = length($ICP_request) - 24;
+ $request_template = 'CCnx4x8x4a4a' . $URL_length;
+ ($type, $version, $length, $requester, $URL) =
+ unpack($request_template, $ICP_request);
+
+ $URL =~ s/\.\.\///g; # be cautious - any others to watch out for ?
+
+ # lookup object in cache
+ $hitmisserr = 3;
+ if ($type eq 1 && $URL =~ m!^([^:]+):/?/?([^/]+)/(.*)!) {
+ $scheme = $1; $hostport = $2; $path = $3;
+ if ($path eq "") { $path = "index.html"; }
+
+ if ($opt_n) {
+ ($host, $port) = split(/:/, $hostport); # strip off port number
+ $port = ":$port" if ($port);
+ $match = "";
+ foreach (split(/\./, $hostport)) {
+ $match = "$_/$match"; # little-endian -> big-endian conversion
+ }
+ $match = "$CACHEDIR/hosts/$match$scheme$port.urls"; # full path
+ if (-f "$match") {
+ #### optimize! ####
+ open(IN, "$match") && do {
+ while(<IN>) { /^$URL / && ($hitmisserr = 2, last); }
+ close(IN);
+ }
+ }
+ } else {
+ $hitmisserr = 2 if -f "$CACHEDIR/$scheme/$hostport/$path";
}
- }
- } else {
- $hitmisserr = 2 if -f "$CACHEDIR/$scheme/$hostport/$path";
}
- }
-
- print "$type $hitmisserr ", join(".", @theirip), " $URL\n" if $opt_v;
-
- $response_template = 'CCnx4x8x4A' . length($URL);
- $ICP_response =
- pack($response_template, $hitmisserr, 2, 20 + length($URL), $URL);
- send(S, $ICP_response, 0, $theiraddr) || die "Couldn't send request: $!";
+
+ print "$type $hitmisserr ", join(".", @theirip), " $URL\n" if $opt_v;
+
+ $response_template = 'CCnx4x8x4A' . length($URL);
+ $ICP_response =
+ pack($response_template, $hitmisserr, 2, 20 + length($URL), $URL);
+ send(S, $ICP_response, 0, $theiraddr) || die "Couldn't send request: $!";
}
sub filename($)
{
- my ($name) = @_;
- return $path . "/" . $name . ".txt";
+ my ($name) = @_;
+ return $path . "/" . $name . ".txt";
}
my ($in) = new IO::File;
while(<>) {
if (/^NAME: (.*)/) {
- my (@aliases) = split(/ /, $1);
- my ($name) = shift @aliases;
- $in->open(filename($name), "r") || die "Couldn't open ".filename($name).":$!\n";
- while(<$in>) {
- print $_;
- }
- $in->close();
+ my (@aliases) = split(/ /, $1);
+ my ($name) = shift @aliases;
+ $in->open(filename($name), "r") || die "Couldn't open ".filename($name).":$!\n";
+ while(<$in>) {
+ print $_;
+ }
+ $in->close();
} else {
- print $_;
+ print $_;
}
}
undef $in;
#
# Author: Tsantilas Christos
# (C) 2011 The Measurement Factory
-#
-# Usage:
+#
+# Usage:
# mk-error-details-po.pl error-details.txt
#
# This script read the error-details.txt error details template, and prints to the
my $File;
my $mode;
-$File = shift @ARGV or
+$File = shift @ARGV or
die "Usage: \n ".$0." error-detail-file\n\n";
open(IN, "<$File") or
$rec = $rec.$line;
$line = <IN>;
$lineOffset++;
- } while($line && $line !~ /^\s*$/);
+ } while($line && $line !~ /^\s*$/);
processRecord(\@PO_RECORDS, $rec, $lineNumber);
$lineNumber= $lineNumber + $lineOffset;
}
my (%poRecDetail, %poRecDescr);
-
+
$poRecDetail{"comment"} = "#: $File+".$currentRec{"name"}.".detail:$lnumber\n";
$poRecDetail{"msgid"} = $currentRec{"detail"};
merge(\@$RECS, \%poRecDetail);
#
# This tool helps to sort the #include directives in a c or c++ source file
# according to the Squid Coding guidelines.
-#
+#
# The output of the tool is a source file where each block of consecutive
# include directives for project-specific files (#include "header.h")
# is sorted with this specification: squid.h (if present) is alwasy first,
my %Seen = (); # preprocessor #include lines, indexed by file name
while (<>) {
- if (/^\s*#\s*include\s*"(.+?)"/) {
- my $fname = $1;
- # skip repeated file names that have identical #include lines
- if (defined $Seen{$fname}) {
- next if $Seen{$fname} eq $_;
- warn("$ARGV:$.: Warning: inconsistent $fname #include lines:\n");
- warn(" $Seen{$fname}");
- warn(" $_");
- # fall through to preserve every unique #include line
+ if (/^\s*#\s*include\s*"(.+?)"/) {
+ my $fname = $1;
+ # skip repeated file names that have identical #include lines
+ if (defined $Seen{$fname}) {
+ next if $Seen{$fname} eq $_;
+ warn("$ARGV:$.: Warning: inconsistent $fname #include lines:\n");
+ warn(" $Seen{$fname}");
+ warn(" $_");
+ # fall through to preserve every unique #include line
+ }
+ $Seen{$fname} = $_;
+ } else {
+ &dumpSeen();
+ print;
}
- $Seen{$fname} = $_;
- } else {
- &dumpSeen();
- print;
- }
}
&dumpSeen();
sub dumpSeen {
- my $alwaysFirst = 'squid.h';
- if (defined $Seen{$alwaysFirst}) {
- print $Seen{$alwaysFirst};
- delete $Seen{$alwaysFirst};
- }
- print sort { lc($a) cmp lc($b) } values %Seen;
- %Seen = ();
+ my $alwaysFirst = 'squid.h';
+ if (defined $Seen{$alwaysFirst}) {
+ print $Seen{$alwaysFirst};
+ delete $Seen{$alwaysFirst};
+ }
+ print sort { lc($a) cmp lc($b) } values %Seen;
+ %Seen = ();
}
my $top = dirname($0);
GetOptions(
- 'verbose' => \$verbose, 'v' => \$verbose,
- 'out=s' => \$path,
- );
+ 'verbose' => \$verbose, 'v' => \$verbose,
+ 'out=s' => \$path,
+ );
sub filename($)
{
- my ($name) = @_;
- return $path . "/" . $name . ".txt";
+ my ($name) = @_;
+ return $path . "/" . $name . ".txt";
}
$index->open(filename("0-index"), "w") || die "Couldn't open ".filename("0-index").": $!\n";
while (<>) {
- chomp;
- print $index $_."\n" if !defined $name;
- last if (/^EOF$/);
- if ($_ =~ /^NAME: (.*)$/) {
- print "DEBUG: new option: $name\n" if $verbose;
+ chomp;
+ print $index $_."\n" if !defined $name;
+ last if (/^EOF$/);
+ if ($_ =~ /^NAME: (.*)$/) {
+ print "DEBUG: new option: $name\n" if $verbose;
- my (@aliases) = split(/ /, $1);
- $name = shift @aliases;
+ my (@aliases) = split(/ /, $1);
+ $name = shift @aliases;
- $out->open(filename($name), "w") || die "Couldn't open ".filename($name).": $!\n";
- }
- print $out $_."\n" if defined $name;
+ $out->open(filename($name), "w") || die "Couldn't open ".filename($name).": $!\n";
+ }
+ print $out $_."\n" if defined $name;
- if ($_ =~ /^DOC_END/ ||
- $_ =~ /^DOC_NONE/) {
- $out->close();
- undef $name;
- }
+ if ($_ =~ /^DOC_END/ ||
+ $_ =~ /^DOC_NONE/) {
+ $out->close();
+ undef $name;
+ }
}
undef $out;
$index->close;
## Please see the COPYING and CONTRIBUTORS files for details.
##
-# tcp-banger.pl
+# tcp-banger.pl
#
# Duane Wessels, Dec 1995
#
$that = pack($sockaddr, &AF_INET, $port, $thataddr);
while (<>) {
- chop ($url = $_);
-
- die "socket: $!\n" unless
- socket (SOCK, &AF_INET, &SOCK_STREAM, $proto);
- die "bind: $!\n" unless
- bind (SOCK, $thissock);
- die "$host:$port: $!\n" unless
- connect (SOCK, $that);
- select (SOCK); $| = 1;
- select (STDOUT);
-
- print SOCK "GET $url HTTP/1.0\r\nAccept: */*\r\n\r\n";
- $_ = <SOCK>;
- ($ver,$code,$junk) = split;
- printf "%s %s\n", $code ? $code : 'FAIL', $url;
- 1 while (read(SOCK,$_,4096));
- close SOCK;
+ chop ($url = $_);
+
+ die "socket: $!\n" unless
+ socket (SOCK, &AF_INET, &SOCK_STREAM, $proto);
+ die "bind: $!\n" unless
+ bind (SOCK, $thissock);
+ die "$host:$port: $!\n" unless
+ connect (SOCK, $that);
+ select (SOCK); $| = 1;
+ select (STDOUT);
+
+ print SOCK "GET $url HTTP/1.0\r\nAccept: */*\r\n\r\n";
+ $_ = <SOCK>;
+ ($ver,$code,$junk) = split;
+ printf "%s %s\n", $code ? $code : 'FAIL', $url;
+ 1 while (read(SOCK,$_,4096));
+ close SOCK;
}
#
# Currently, the script reads and remembers many irrelevant lines because it
# does not know which one should be tracked in advance.
-#
+#
use strict;
use warnings;
my $DEB;
while (<STDIN>) {
- my $line = $_;
- #$DEB = 1 if /16:53:44.632/;
+ my $line = $_;
+ #$DEB = 1 if /16:53:44.632/;
- ($Kid) = (/(kid\d+)[|]/);
- $Kid = 'kid0' unless defined $Kid;
+ ($Kid) = (/(kid\d+)[|]/);
+ $Kid = 'kid0' unless defined $Kid;
- &enterBlock($., $_) if
- (/[|:] entering\b/ && !/Port::noteRead/) ||
+ &enterBlock($., $_) if
+ (/[|:] entering\b/ && !/Port::noteRead/) ||
(/Port::noteRead/ && /handling/);
- next unless $Inside{$Kid};
+ next unless $Inside{$Kid};
- while ($line =~ s@\b(entry) (\d+) .*?(\S*_map)@ @) {
- &processEntryPartId("$3.$1", $2);
- }
+ while ($line =~ s@\b(entry) (\d+) .*?(\S*_map)@ @) {
+ &processEntryPartId("$3.$1", $2);
+ }
- while ($line =~ s@\b(slice|slot) (\d+)@ @) {
- &processEntryPartId($1, $2);
- }
+ while ($line =~ s@\b(slice|slot) (\d+)@ @) {
+ &processEntryPartId($1, $2);
+ }
- #while ($line =~ s@\b(page) (\w+)@ @) {
- # &processEntryPartId($1, $2);
- #}
+ #while ($line =~ s@\b(page) (\w+)@ @) {
+ # &processEntryPartId($1, $2);
+ #}
- while ($line =~ s@\b(key) '?(\w+)@ @) {
- &processEntryPartId($1, $2);
- }
+ while ($line =~ s@\b(key) '?(\w+)@ @) {
+ &processEntryPartId($1, $2);
+ }
- while ($line =~ s@\b([A-Z0-9]{32})\b@ @) {
- &processEntryPartId('key', $1);
- }
+ while ($line =~ s@\b([A-Z0-9]{32})\b@ @) {
+ &processEntryPartId('key', $1);
+ }
- while ($line =~ s@\be:\S*?/(0x\w+)@ @ || $line =~ s@\bStoreEntry\s+(0x\w+)@ @) {
- &processEntryPartId('pointer', $1);
- }
+ while ($line =~ s@\be:\S*?/(0x\w+)@ @ || $line =~ s@\bStoreEntry\s+(0x\w+)@ @) {
+ &processEntryPartId('pointer', $1);
+ }
- if ($line ne $_ || /[|:] leaving\b/) {
- if (my $entry = $CurrentEntries{$Kid}) {
- &updateEntry($entry, $Entering{$Kid}) if exists $Entering{$Kid};
- delete $Entering{$Kid};
- &updateEntry($entry, &historyLine($., $_));
- }
- }
+ if ($line ne $_ || /[|:] leaving\b/) {
+ if (my $entry = $CurrentEntries{$Kid}) {
+ &updateEntry($entry, $Entering{$Kid}) if exists $Entering{$Kid};
+ delete $Entering{$Kid};
+ &updateEntry($entry, &historyLine($., $_));
+ }
+ }
- &leaveBlock() if
- (/[|:] leaving\b/ && !/Port::noteRead/) ||
+ &leaveBlock() if
+ (/[|:] leaving\b/ && !/Port::noteRead/) ||
(/Port::noteRead/ && /handled/);
}
# merge same entries
my %cleanEntries = ();
foreach my $id (sort { $a <=> $b } keys %Entries) {
- my $entry = $Entries{$id};
+ my $entry = $Entries{$id};
- next unless &mergeAllLinkedEntries($entry);
+ next unless &mergeAllLinkedEntries($entry);
- $entry->{id} = 1 + scalar keys %cleanEntries;
- $cleanEntries{$entry->{id}} = $entry;
+ $entry->{id} = 1 + scalar keys %cleanEntries;
+ $cleanEntries{$entry->{id}} = $entry;
}
%Entries = %cleanEntries;
printf("Saw %d entries\n", scalar keys %Entries);
if (!@InterestingEntries) { # print all entries
- foreach my $id (sort { $a <=> $b } keys %Entries) {
- my $entry = $Entries{$id};
- reportEntry($entry, 1);
- }
+ foreach my $id (sort { $a <=> $b } keys %Entries) {
+ my $entry = $Entries{$id};
+ reportEntry($entry, 1);
+ }
} else {
- foreach my $description (@InterestingEntries) {
- my ($part, $id) = ($description =~ /(\w+)\s+(\w+)/);
- my $entry = &getExistingEntry($part, $id);
- reportEntry($entry, 1);
- }
+ foreach my $description (@InterestingEntries) {
+ my ($part, $id) = ($description =~ /(\w+)\s+(\w+)/);
+ my $entry = &getExistingEntry($part, $id);
+ reportEntry($entry, 1);
+ }
}
exit(0);
sub enterBlock {
- my ($lineNo, $lineText) = @_;
+ my ($lineNo, $lineText) = @_;
- $Entering{$Kid} = &historyLine($., $_);
- die("double entrance, stopped") if $Inside{$Kid};
- $Inside{$Kid} = 1;
+ $Entering{$Kid} = &historyLine($., $_);
+ die("double entrance, stopped") if $Inside{$Kid};
+ $Inside{$Kid} = 1;
}
sub leaveBlock {
- $CurrentEntries{$Kid} = undef();
- delete $Entering{$Kid};
- $Inside{$Kid} = 0;
+ $CurrentEntries{$Kid} = undef();
+ delete $Entering{$Kid};
+ $Inside{$Kid} = 0;
}
sub processEntryPartId {
- my ($part, $id) = @_;
-
- #warn("XXX1: $Kid| part.id: $part.$id\n") if $DEB;
-
- my $entry;
- my $curEntry = $CurrentEntries{$Kid};
- my $oldEntry = &getExistingEntry($part, $id);
- if ($curEntry && $oldEntry && $curEntry->{id} != $oldEntry->{id}) {
- &linkEntries($curEntry, $oldEntry, "$part.$id");
- $entry = $curEntry;
- } else {
- $entry = $curEntry ? $curEntry : $oldEntry;
- }
- $entry = &getEntry($part, $id) unless defined $entry;
- $CurrentEntries{$Kid} = $entry;
-
- $entry->{parts}->{$part} = {} unless exists $entry->{parts}->{$part};
- $entry->{parts}->{$part}->{$id} = $_ unless exists $entry->{parts}->{$part}->{$id};
+ my ($part, $id) = @_;
+
+ #warn("XXX1: $Kid| part.id: $part.$id\n") if $DEB;
+
+ my $entry;
+ my $curEntry = $CurrentEntries{$Kid};
+ my $oldEntry = &getExistingEntry($part, $id);
+ if ($curEntry && $oldEntry && $curEntry->{id} != $oldEntry->{id}) {
+ &linkEntries($curEntry, $oldEntry, "$part.$id");
+ $entry = $curEntry;
+ } else {
+ $entry = $curEntry ? $curEntry : $oldEntry;
+ }
+ $entry = &getEntry($part, $id) unless defined $entry;
+ $CurrentEntries{$Kid} = $entry;
+
+ $entry->{parts}->{$part} = {} unless exists $entry->{parts}->{$part};
+ $entry->{parts}->{$part}->{$id} = $_ unless exists $entry->{parts}->{$part}->{$id};
}
sub historyLine {
- my ($lineCount, $line) = @_;
- return sprintf("#%06d %s", $lineCount, $line);
+ my ($lineCount, $line) = @_;
+ return sprintf("#%06d %s", $lineCount, $line);
}
sub updateEntry {
- my ($entry, $historyLine) = @_;
+ my ($entry, $historyLine) = @_;
- $entry->{history} .= $historyLine;
+ $entry->{history} .= $historyLine;
}
sub linkEntries {
- my ($e1, $e2, $ctx) = @_;
+ my ($e1, $e2, $ctx) = @_;
- $e1->{sameAs}->{$e2->{id}} = 1;
- $e2->{sameAs}->{$e1->{id}} = 1;
+ $e1->{sameAs}->{$e2->{id}} = 1;
+ $e2->{sameAs}->{$e1->{id}} = 1;
}
sub mergeAllLinkedEntries {
- my ($entry) = @_;
+ my ($entry) = @_;
- #warn(sprintf("merging %d <-- * %s\n", $entry->{id}, $entry->{merged} ? "skipped" : ""));
+#warn(sprintf("merging %d <-- * %s\n", $entry->{id}, $entry->{merged} ? "skipped" : ""));
- return 0 if $entry->{merged};
- $entry->{merged} = 1;
+ return 0 if $entry->{merged};
+ $entry->{merged} = 1;
- foreach my $otherId (keys %{$entry->{sameAs}}) {
- my $otherE = $Entries{$otherId};
- die("missing internal entry$otherId, stopped") unless $otherE;
- next if $otherE->{merged};
- &mergeAllLinkedEntries($otherE);
- &mergeOneEntry($entry, $otherE);
- $otherE->{merged} = 1;
- }
+ foreach my $otherId (keys %{$entry->{sameAs}}) {
+ my $otherE = $Entries{$otherId};
+ die("missing internal entry$otherId, stopped") unless $otherE;
+ next if $otherE->{merged};
+ &mergeAllLinkedEntries($otherE);
+ &mergeOneEntry($entry, $otherE);
+ $otherE->{merged} = 1;
+ }
- return 1;
+ return 1;
}
sub mergeOneEntry {
- my ($entry, $otherE) = @_;
+ my ($entry, $otherE) = @_;
- #warn(sprintf("merging %d <-- %d\n", $entry->{id}, $otherE->{id}));
+ #warn(sprintf("merging %d <-- %d\n", $entry->{id}, $otherE->{id}));
- foreach my $part (keys %{$otherE->{parts}}) {
+ foreach my $part (keys %{$otherE->{parts}}) {
foreach my $id (keys %{$otherE->{parts}->{$part}}) {
$entry->{parts}->{$part}->{$id} = $otherE->{parts}->{$part}->{$id};
- }
- }
+ }
+ }
- $entry->{history} .= $otherE->{history};
+ $entry->{history} .= $otherE->{history};
}
sub getExistingEntry {
- my ($part, $id) = @_;
+ my ($part, $id) = @_;
- return $EntriesByPartId{$part}->{$id} if exists $EntriesByPartId{$part};
- return undef();
+ return $EntriesByPartId{$part}->{$id} if exists $EntriesByPartId{$part};
+ return undef();
}
sub getEntry {
- my ($part, $id) = @_;
-
- $EntriesByPartId{$part} = {} unless exists $EntriesByPartId{$part};
- my $entry = $EntriesByPartId{$part}->{$id};
- return $entry if $entry;
-
- $entry = {
- id => ++$LastEntryId,
-
- parts => {},
-
- history => '',
-
- reported => 0,
- };
-
- $entry->{parts}->{$part} = {};
- $EntriesByPartId{$part}->{$id} = $entry;
- $Entries{$LastEntryId} = $entry;
- return $entry;
+ my ($part, $id) = @_;
+
+ $EntriesByPartId{$part} = {} unless exists $EntriesByPartId{$part};
+ my $entry = $EntriesByPartId{$part}->{$id};
+ return $entry if $entry;
+
+ $entry = {
+ id => ++$LastEntryId,
+ parts => {},
+ history => '',
+ reported => 0,
+ };
+
+ $entry->{parts}->{$part} = {};
+ $EntriesByPartId{$part}->{$id} = $entry;
+ $Entries{$LastEntryId} = $entry;
+ return $entry;
}
sub reportEntry {
- my ($entry, $recursive) = @_;
+ my ($entry, $recursive) = @_;
- return if $entry->{reported};
- $entry->{reported} = 1;
+ return if $entry->{reported};
+ $entry->{reported} = 1;
- printf("entry%d:\n", $entry->{id});
+ printf("entry%d:\n", $entry->{id});
- foreach my $part (keys %{$entry->{parts}}) {
- printf("\t%s(s):", $part);
- foreach my $id (keys %{$entry->{parts}->{$part}}) {
- printf(" %s", $id);
- }
- print("\n");
- }
+ foreach my $part (keys %{$entry->{parts}}) {
+ printf("\t%s(s):", $part);
+ foreach my $id (keys %{$entry->{parts}->{$part}}) {
+ printf(" %s", $id);
+ }
+ print("\n");
+ }
- &reportEntryHistory($entry);
+ &reportEntryHistory($entry);
}
sub reportEntryParam {
- my ($entry, $name, $value) = @_;
+ my ($entry, $name, $value) = @_;
- $value = $entry->{$name} if @_ < 3;
- $value = '?' unless defined $value;
- $value = "\n$value" if $value =~ /\n/m;
- printf("\t%s: %s\n", $name, $value);
+ $value = $entry->{$name} if @_ < 3;
+ $value = '?' unless defined $value;
+ $value = "\n$value" if $value =~ /\n/m;
+ printf("\t%s: %s\n", $name, $value);
}
sub reportEntryHistory {
- my ($entry) = @_;
-
- my $history = $entry->{history};
- my @lines = split(/\n/, $history);
- &reportEntryParam($entry, 'history', (scalar @lines) . " lines");
-
- my $lastKid = '';
- foreach my $line (sort @lines) {
- my ($kid) = ($line =~ /(kid\d+)[|]/);
- $kid = 'kid0' unless defined $kid;
-
- print "\n" if $lastKid ne $kid;
- print "$line\n";
- $lastKid = $kid;
- }
- print "\n" if @lines;
+ my ($entry) = @_;
+
+ my $history = $entry->{history};
+ my @lines = split(/\n/, $history);
+ &reportEntryParam($entry, 'history', (scalar @lines) . " lines");
+
+ my $lastKid = '';
+ foreach my $line (sort @lines) {
+ my ($kid) = ($line =~ /(kid\d+)[|]/);
+ $kid = 'kid0' unless defined $kid;
+
+ print "\n" if $lastKid ne $kid;
+ print "$line\n";
+ $lastKid = $kid;
+ }
+ print "\n" if @lines;
}
##
# Reads cache.log and displays lines that correspond to a given async job.
-#
+#
# If job entering/exiting line format changes, the script must be updated.
# Keep the old RE around for a while because they may be handy for working
# with folks running older Squids.
my $entering;
while (<>) {
- $entering = $_ if !$inside && /[|:] entering\b/;
- undef $entering if /[|:] leaving\b/;
-
- # if (!$inside && /\bcalled\b.*\b$XactId\b/o) {
- if (!$inside && /\bstatus in\b.*\b$XactId\b/o) {
- print $entering if defined $entering;
- $inside = 1;
- }
-
- my $external = !$inside && /\b$XactId\b/o;
-
- print $_ if $inside || $external;
- print "\n" if $external;
-
- next unless $inside;
-
- # if (/\bended\b.*\b$XactId\b/o || /\bswan\s+sang\b.*\b$XactId\b/o) {
- # if (/\bstatus out\b.*\b$XactId\b/o || /\bswan\s+sang\b.*\b$XactId\b/o ||
- if (/[|:] leaving\b/) {
- print "\n";
- $inside = 0;
- }
+ $entering = $_ if !$inside && /[|:] entering\b/;
+ undef $entering if /[|:] leaving\b/;
+
+ # if (!$inside && /\bcalled\b.*\b$XactId\b/o) {
+ if (!$inside && /\bstatus in\b.*\b$XactId\b/o) {
+ print $entering if defined $entering;
+ $inside = 1;
+ }
+
+ my $external = !$inside && /\b$XactId\b/o;
+
+ print $_ if $inside || $external;
+ print "\n" if $external;
+
+ next unless $inside;
+
+ # if (/\bended\b.*\b$XactId\b/o || /\bswan\s+sang\b.*\b$XactId\b/o) {
+ # if (/\bstatus out\b.*\b$XactId\b/o || /\bswan\s+sang\b.*\b$XactId\b/o ||
+ if (/[|:] leaving\b/) {
+ print "\n";
+ $inside = 0;
+ }
}
exit(0);
my $IncludePrefix = 0; # include initial kidless lines
my $IncludeMentions = 0; # include other kid references to the targeted kid
GetOptions(
- "prefix!" => \$IncludePrefix,
+ "prefix!" => \$IncludePrefix,
"mentions!" => \$IncludeMentions,
-) or die(usage());
+ ) or die(usage());
my $Kid = shift or die(usage());
die("$0: error: expecting an integer kid ID but got $Kid\n")
- unless $Kid =~ /^\d+$/;
+ unless $Kid =~ /^\d+$/;
my $lastKid;
while (<>) {
- my ($currentKid) = (/^\d[^a-z]+? kid(\d+)[|]/);
- $lastKid = $currentKid if defined $currentKid;
+ my ($currentKid) = (/^\d[^a-z]+? kid(\d+)[|]/);
+ $lastKid = $currentKid if defined $currentKid;
- if (!defined($currentKid) && !defined($lastKid)) { # kidless prefix
- print $_ if $IncludePrefix;
- next;
- }
+ if (!defined($currentKid) && !defined($lastKid)) { # kidless prefix
+ print $_ if $IncludePrefix;
+ next;
+ }
- # targeted kid output or kidless output by, hopefully, the targeted kid
- if (defined $lastKid && $lastKid == $Kid) {
- print $_;
- next;
- }
+ # targeted kid output or kidless output by, hopefully, the targeted kid
+ if (defined $lastKid && $lastKid == $Kid) {
+ print $_;
+ next;
+ }
- if (defined $currentKid) { # wrong kid output
- # print lines mentioning our kid if requested, isolating each such line
- print "\n$_\n" if $IncludeMentions && /\bkid(:\s*)?$Kid\b/o;
- next;
- }
+ if (defined $currentKid) { # wrong kid output
+ # print lines mentioning our kid if requested, isolating each such line
+ print "\n$_\n" if $IncludeMentions && /\bkid(:\s*)?$Kid\b/o;
+ next;
+ }
- # ignore kidless output produced by, hopefully, wrong kids
+ # ignore kidless output produced by, hopefully, wrong kids
}
exit(0);
sub usage() {
- return <<"USAGE";
+ return <<"USAGE";
usage: $0 [option...] <kid ID> [log file...]
options:
--prefix include initial kidless lines
# Currently, the script reads and remembers all master transactions because it
# does not know which one should be tracked in advance. Eventually, we may
# have a more efficient way of tying master transaction to a job.
-#
+#
use strict;
my $entering;
while (<STDIN>) {
- $entering = $_ if !$inside && /[|:] entering\b/;
- undef $entering if /[|:] leaving\b/;
-
- if (!$inside && /\bstatus in\b.*\b(?:async|job|icapx)(\d+)\b/o) {
- $inside = $1;
- &enterJob($inside);
- &updateJob($inside, $entering) if defined $entering;
- undef $entering;
- }
- elsif (!$inside && /\b(?:async|job|icapx)(\d+)\b/o) {
- updateJob($1, "$_\n"); # isolated line
- }
-
- next unless $inside;
-
- &updateJob($inside, $_);
-
- if (/AsyncJob constructed.*\[\S+?(\d+)\]/) {
- &linkJobs($inside, $1, $_);
- }
-
- if (/[|:] leaving\b/) {
- $inside = 0;
- }
+ $entering = $_ if !$inside && /[|:] entering\b/;
+ undef $entering if /[|:] leaving\b/;
+
+ if (!$inside && /\bstatus in\b.*\b(?:async|job|icapx)(\d+)\b/o) {
+ $inside = $1;
+ &enterJob($inside);
+ &updateJob($inside, $entering) if defined $entering;
+ undef $entering;
+ }
+ elsif (!$inside && /\b(?:async|job|icapx)(\d+)\b/o) {
+ updateJob($1, "$_\n"); # isolated line
+ }
+
+ next unless $inside;
+
+ &updateJob($inside, $_);
+
+ if (/AsyncJob constructed.*\[\S+?(\d+)\]/) {
+ &linkJobs($inside, $1, $_);
+ }
+
+ if (/[|:] leaving\b/) {
+ $inside = 0;
+ }
}
foreach my $id (@InterestingJobs) {
- # Squid uses asyncNNN, jobNNN, icapxNNN for the same job/transaction
- $id =~ s/^(?:async|job|icapx)(\d+)$/$1/;
- reportJob($id, 1);
+ # Squid uses asyncNNN, jobNNN, icapxNNN for the same job/transaction
+ $id =~ s/^(?:async|job|icapx)(\d+)$/$1/;
+ reportJob($id, 1);
}
exit(0);
-
sub enterJob {
- my ($id) = @_;
- my $job = &getJob($id);
+ my ($id) = @_;
+ my $job = &getJob($id);
}
sub updateJob {
- my ($id, $line) = @_;
+ my ($id, $line) = @_;
- my $job = &getJob($id);
- $job->{history} .= $line;
+ my $job = &getJob($id);
+ $job->{history} .= $line;
- if ($line =~ /\bFD (\d+)/) {
- $job->{fds}->{$1} = 1;
- }
+ if ($line =~ /\bFD (\d+)/) {
+ $job->{fds}->{$1} = 1;
+ }
}
sub linkJobs {
- my ($parentId, $kidId, $line) = @_;
+ my ($parentId, $kidId, $line) = @_;
- my $parent = $Jobs{$parentId} or die("missing linked job $parentId");
- push @{$parent->{kids}}, $kidId;
-
- my $kid = &getJob($kidId);
- die("two parents for $kidId: ". $kid->{parent}. " and $parentId") if $kid->{parent};
- $kid->{parent} = $parentId;
+ my $parent = $Jobs{$parentId} or die("missing linked job $parentId");
+ push @{$parent->{kids}}, $kidId;
- $kid->{history} .= $line; # birth
+ my $kid = &getJob($kidId);
+ die("two parents for $kidId: ". $kid->{parent}. " and $parentId") if $kid->{parent};
+ $kid->{parent} = $parentId;
+
+ $kid->{history} .= $line; # birth
}
sub getJob {
- my $id = shift;
-
- my $job = $Jobs{$id};
- return $job if $job;
-
- $job = {
- id => $id,
- kids => [],
- fds => {},
- parent => undef(),
-
- start => undef(),
- history => '',
-
- reported => 0,
- };
-
- $Jobs{$id} = $job;
- return $job;
+ my $id = shift;
+
+ my $job = $Jobs{$id};
+ return $job if $job;
+
+ $job = {
+ id => $id,
+ kids => [],
+ fds => {},
+ parent => undef(),
+ start => undef(),
+ history => '',
+ reported => 0,
+ };
+
+ $Jobs{$id} = $job;
+ return $job;
}
sub reportJob {
- my ($id, $recursive) = @_;
+ my ($id, $recursive) = @_;
- my $job = $Jobs{$id} or die("Did not see job$id\n");
+ my $job = $Jobs{$id} or die("Did not see job$id\n");
- # several kids may try to report their common parent
- return if $job->{reported};
- $job->{reported} = 1;
+ # several kids may try to report their common parent
+ return if $job->{reported};
+ $job->{reported} = 1;
- &reportJob($job->{parent}, 0) if $job->{parent};
+ &reportJob($job->{parent}, 0) if $job->{parent};
- &reportJobParam($id, 'parent');
- &reportJobParam($id, 'kids', join(', ', @{$job->{kids}}));
- &reportJobParam($id, 'FDs', join(', ', keys %{$job->{fds}}));
- &reportJobHistory($id);
+ &reportJobParam($id, 'parent');
+ &reportJobParam($id, 'kids', join(', ', @{$job->{kids}}));
+ &reportJobParam($id, 'FDs', join(', ', keys %{$job->{fds}}));
+ &reportJobHistory($id);
- return unless $recursive;
+ return unless $recursive;
- foreach my $kidId (@{$job->{kids}}) {
- &reportJob($kidId, $recursive);
- }
+ foreach my $kidId (@{$job->{kids}}) {
+ &reportJob($kidId, $recursive);
+ }
}
sub reportJobParam {
- my ($id, $name, $value) = @_;
- my $job = $Jobs{$id} or die;
+ my ($id, $name, $value) = @_;
+ my $job = $Jobs{$id} or die;
- $value = $job->{$name} if @_ < 3;
- $value = '?' unless defined $value;
- $value = "\n$value" if $value =~ /\n/m;
- printf("job%d %s: %s\n", $id, $name, $value);
+ $value = $job->{$name} if @_ < 3;
+ $value = '?' unless defined $value;
+ $value = "\n$value" if $value =~ /\n/m;
+ printf("job%d %s: %s\n", $id, $name, $value);
}
sub reportJobHistory {
- my ($id) = @_;
- my $job = $Jobs{$id} or die;
+ my ($id) = @_;
+ my $job = $Jobs{$id} or die;
- my $history = $job->{history};
- my @lines = split(/\n/, $history);
- &reportJobParam($id, 'history', (scalar @lines) . " entries");
+ my $history = $job->{history};
+ my @lines = split(/\n/, $history);
+ &reportJobParam($id, 'history', (scalar @lines) . " entries");
- foreach my $line (@lines) {
- print "$line\n";
- print "\n" if $line =~ /[|:] leaving\b/;
- }
+ foreach my $line (@lines) {
+ print "$line\n";
+ print "\n" if $line =~ /[|:] leaving\b/;
+ }
}
## Please see the COPYING and CONTRIBUTORS files for details.
##
-# udp-banger.pl
+# udp-banger.pl
#
# Duane Wessels, Dec 1995
#
"UDP_DENIED",
"UDP_HIT_OBJ",
"ICP_END"
-);
+ );
$sock = IO::Socket::INET->new(PeerAddr => "$host:$port", Proto => 'udp');
die "socket: $!\n" unless defined($sock);
$flags = fcntl ($sock, &F_GETFL, 0);
$flags |= &O_NONBLOCK;
die "fcntl O_NONBLOCK: $!\n" unless
- fcntl ($sock, &F_SETFL, $flags);
+ fcntl ($sock, &F_SETFL, $flags);
$flags = 0;
$flags |= 0x80000000;
$start = time;
while (<>) {
- chop;
+ chop;
- if ($opt_l) { # it's a Squid log file
- @stuff = split(/\s+/, $_);
- $_ = $stuff[6];
- }
+ if ($opt_l) { # it's a Squid log file
+ @stuff = split(/\s+/, $_);
+ $_ = $stuff[6];
+ }
- $len = length($_) + 1;
- $request_template = sprintf 'CCnNNa4a4x4a%d', $len;
- $request = pack($request_template,
- 1, # C opcode
- 2, # C version
- 24 + $len, # n length
- ++$rn, # N reqnum
- $flags, # N flags
- '', # a4 pad
- $myip, # a4 shostid
- $_); # a%d payload
- die "send: $!\n" unless
- send($sock, $request, 0);
- $nsent++;
- $rin = '';
- vec($rin,fileno($sock),1) = 1;
- ($nfound,$timeleft) = select($rout=$rin, undef, undef, 2.0);
- next if ($nfound == 0);
- while (1) {
- last unless ($theiraddr = recv($sock, $reply, 1024, 0));
- next if $opt_q; # quietly carry on
- $nrecv++;
- if ($opt_r) {
- # only print send/receive rates
- if (($nsent & 0xFF) == 0) {
- $dt = time - $start;
- printf "SENT %d %f/sec; RECV %d %f/sec\n",
- $nsent,
- $nsent / $dt,
- $nrecv,
- $nrecv / $dt;
- }
- } else {
- # print the whole reply
- ($junk, $junk, $sourceaddr, $junk) = unpack($sockaddr, $theiraddr);
- @theirip = unpack('C4', $sourceaddr);
- ($type,$ver,$len,$flag,$p1,$p2,$payload) = unpack('CCnx4Nnnx4A', $reply);
- print join('.', @theirip) . ' ' . $CODES[$type] . " $_";
- print " hop=$p1" if ($opt_n);
- print " rtt=$p2" if ($opt_n);
- print "\n";
- }
+ $len = length($_) + 1;
+ $request_template = sprintf 'CCnNNa4a4x4a%d', $len;
+ $request = pack($request_template,
+ 1, # C opcode
+ 2, # C version
+ 24 + $len, # n length
+ ++$rn, # N reqnum
+ $flags, # N flags
+ '', # a4 pad
+ $myip, # a4 shostid
+ $_); # a%d payload
+ die "send: $!\n" unless
+ send($sock, $request, 0);
+ $nsent++;
+ $rin = '';
+ vec($rin,fileno($sock),1) = 1;
+ ($nfound,$timeleft) = select($rout=$rin, undef, undef, 2.0);
+ next if ($nfound == 0);
+ while (1) {
+ last unless ($theiraddr = recv($sock, $reply, 1024, 0));
+ next if $opt_q; # quietly carry on
+ $nrecv++;
+ if ($opt_r) {
+ # only print send/receive rates
+ if (($nsent & 0xFF) == 0) {
+ $dt = time - $start;
+ printf "SENT %d %f/sec; RECV %d %f/sec\n",
+ $nsent,
+ $nsent / $dt,
+ $nrecv,
+ $nrecv / $dt;
+ }
+ } else {
+ # print the whole reply
+ ($junk, $junk, $sourceaddr, $junk) = unpack($sockaddr, $theiraddr);
+ @theirip = unpack('C4', $sourceaddr);
+ ($type,$ver,$len,$flag,$p1,$p2,$payload) = unpack('CCnx4Nnnx4A', $reply);
+ print join('.', @theirip) . ' ' . $CODES[$type] . " $_";
+ print " hop=$p1" if ($opt_n);
+ print " rtt=$p2" if ($opt_n);
+ print "\n";
}
+ }
}
$NEW_SWAP_DIRECTORIES_L1 = 16;
$NEW_SWAP_DIRECTORIES_L2 = 256;
-$EEXIST = 17; # check your /usr/include/errno.h
+$EEXIST = 17; # check your /usr/include/errno.h
print <<EOF;
This script converts Squid 1.0 cache directories to the Squid 1.1
# make new directories
foreach $c (@cachedirs) {
- $cn = "$c.new";
- &my_mkdir ($cn);
- foreach $d1 (0..($NEW_SWAP_DIRECTORIES_L1-1)) {
- $p1 = sprintf ("$cn/%02X", $d1);
- &my_mkdir ($p1);
- foreach $d2 (0..($NEW_SWAP_DIRECTORIES_L2-1)) {
- $p2 = sprintf ("$p1/%02X", $d2);
- &my_mkdir ($p2);
- }
- }
+ $cn = "$c.new";
+ &my_mkdir ($cn);
+ foreach $d1 (0..($NEW_SWAP_DIRECTORIES_L1-1)) {
+ $p1 = sprintf ("$cn/%02X", $d1);
+ &my_mkdir ($p1);
+ foreach $d2 (0..($NEW_SWAP_DIRECTORIES_L2-1)) {
+ $p2 = sprintf ("$p1/%02X", $d2);
+ &my_mkdir ($p2);
+ }
+ }
}
$newlog = "$swaplog.1.1";
open (newlog, ">$newlog") || die "$newlog: $!\n";
select(newlog); $|=1; select(STDOUT);
-open (swaplog) || die "$swaplog: $!\n";
+open (swaplog) || die "$swaplog: $!\n";
$count = 0;
while (<swaplog>) {
- chop;
- ($file,$url,$expires,$timestamp,$size) = split;
- @F = split('/', $file);
- $oldfileno = pop @F;
- $oldpath = &old_fileno_to_path($oldfileno);
- unless (@S = stat($oldpath)) {
- print "$oldpath: $!\n";
- next;
- }
- unless ($S[7] == $size) {
- print "$oldpath: Wrong Size.\n";
- next;
- }
- $newpath = &new_fileno_to_path($oldfileno);
- next unless &my_link($oldpath,$newpath);
- printf newlog "%08x %08x %08x %08x %9d %s\n",
- $oldfileno,
- $timestamp,
- $expires,
- $timestamp, # lastmod
- $size,
- $url;
- $count++;
+ chop;
+ ($file,$url,$expires,$timestamp,$size) = split;
+ @F = split('/', $file);
+ $oldfileno = pop @F;
+ $oldpath = &old_fileno_to_path($oldfileno);
+ unless (@S = stat($oldpath)) {
+ print "$oldpath: $!\n";
+ next;
+ }
+ unless ($S[7] == $size) {
+ print "$oldpath: Wrong Size.\n";
+ next;
+ }
+ $newpath = &new_fileno_to_path($oldfileno);
+ next unless &my_link($oldpath,$newpath);
+ printf newlog "%08x %08x %08x %08x %9d %s\n",
+ $oldfileno,
+ $timestamp,
+ $expires,
+ $timestamp, # lastmod
+ $size,
+ $url;
+ $count++;
}
sub old_fileno_to_path {
- local($fn) = @_;
- sprintf ("%s/%02d/%d",
- $cachedirs[$fn % $ncache_dirs],
- ($fn / $ncache_dirs) % $OLD_SWAP_DIRECTORIES,
- $fn);
+ local($fn) = @_;
+ sprintf ("%s/%02d/%d",
+ $cachedirs[$fn % $ncache_dirs],
+ ($fn / $ncache_dirs) % $OLD_SWAP_DIRECTORIES,
+ $fn);
}
sub new_fileno_to_path {
- local($fn) = @_;
- sprintf ("%s.new/%02X/%02X/%08X",
- $cachedirs[$fn % $ncache_dirs],
- ($fn / $ncache_dirs) % $NEW_SWAP_DIRECTORIES_L1,
- ($fn / $ncache_dirs) / $NEW_SWAP_DIRECTORIES_L1 % $NEW_SWAP_DIRECTORIES_L2,
- $fn);
+ local($fn) = @_;
+ sprintf ("%s.new/%02X/%02X/%08X",
+ $cachedirs[$fn % $ncache_dirs],
+ ($fn / $ncache_dirs) % $NEW_SWAP_DIRECTORIES_L1,
+ ($fn / $ncache_dirs) / $NEW_SWAP_DIRECTORIES_L1 % $NEW_SWAP_DIRECTORIES_L2,
+ $fn);
}
sub my_mkdir {
- local($p) = @_;
- print "Making $p...\n";
- return if ($dry_run);
- unless (mkdir ($p, 0755)) {
- return 1 if ($! == $EEXIST);
- die "$p: $!\n";
- }
+ local($p) = @_;
+ print "Making $p...\n";
+ return if ($dry_run);
+ unless (mkdir ($p, 0755)) {
+ return 1 if ($! == $EEXIST);
+ die "$p: $!\n";
+ }
}
sub my_link {
- local($f,$t) = @_;
- print "$f --> $t\n";
- return 1 if ($dry_run);
- unlink($t);
- $rc = link ($f,$t);
- warn "$t: $!\n" unless ($rc);
- $rc;
+ local($f,$t) = @_;
+ print "$f --> $t\n";
+ return 1 if ($dry_run);
+ unlink($t);
+ $rc = link ($f,$t);
+ warn "$t: $!\n" unless ($rc);
+ $rc;
}
}
foreach $lang (@ARGV) {
- foreach $page (@pages) {
- undef %codes;
- open(IN, "<$lang/$page") || die;
- $file = join("", <IN>);
- close(IN);
- $file =~ s/%(.)/$codes{$1}++/ge;
- foreach $code (keys %codes, keys %{$english{$page}}) {
- if ($codes{$code} ne $english{$page}{$code}) {
- print("$lang/$page %$code mismatch (found $codes{$code}, expected $english{$page}{$code})\n");
- }
+ foreach $page (@pages) {
+ undef %codes;
+ open(IN, "<$lang/$page") || die;
+ $file = join("", <IN>);
+ close(IN);
+ $file =~ s/%(.)/$codes{$1}++/ge;
+ foreach $code (keys %codes, keys %{$english{$page}}) {
+ if ($codes{$code} ne $english{$page}{$code}) {
+ print("$lang/$page %$code mismatch (found $codes{$code}, expected $english{$page}{$code})\n");
+ }
+ }
}
- }
}
# XXX a configuration index entry for each, linking back to the one entry.
# XXX I'll probably just choose the first entry in the list.
-#
+#
# This code is ugly, but meh. We'll keep reading, line by line, and appending
# lines into 'state' variables until the next NAME comes up. We'll then
# shuffle everything off to a function to generate the page.
my $top = dirname($0);
GetOptions(
- 'verbose' => \$verbose, 'v' => \$verbose,
- 'out=s' => \$path,
- 'version=s' => \$version,
- 'format=s' => \$format
- );
+ 'verbose' => \$verbose, 'v' => \$verbose,
+ 'out=s' => \$path,
+ 'version=s' => \$version,
+ 'format=s' => \$format
+ );
if ($format eq "splithtml") {
$pagetemplate = "template.html";
# XXX should implement this!
sub uriescape($)
{
- my ($line) = @_;
- return $line;
+ my ($line) = @_;
+ return $line;
}
sub filename($)
{
- my ($name) = @_;
- return $path . "/" . $name . ".html";
+ my ($name) = @_;
+ return $path . "/" . $name . ".html";
}
sub htmlescape($)
{
- my ($line) = @_;
- return "" if !defined $line;
- $line =~ s/&/\&/g;
- $line =~ s/</\</g;
- $line =~ s/>/\>/g;
- $line =~ s/[^\x{20}-\x{7e}\s]/sprintf ("&#%d;", ord ($1))/ge;
- return $line;
+ my ($line) = @_;
+ return "" if !defined $line;
+ $line =~ s/&/\&/g;
+ $line =~ s/</\</g;
+ $line =~ s/>/\>/g;
+ $line =~ s/[^\x{20}-\x{7e}\s]/sprintf ("&#%d;", ord ($1))/ge;
+ return $line;
}
sub section_link($)
#
sub generate_page($$)
{
- my ($template, $data) = @_;
- my $fh;
- my $fh_open = 0;
- # XXX should make sure the config option is a valid unix filename!
- if ($format eq "splithtml") {
- my ($fn) = filename($data->{'name'});
- $fh = new IO::File;
- $fh->open($fn, "w") || die "Couldn't open $fn: $!\n";
- $fh_open = 1;
- } else {
- $fh = $index;
- }
-
- $data->{"ifdef"} = $defines{$data->{"ifdef"}} if (exists $data->{"ifdef"} && exists $defines{$data->{"ifdef"}});
-
- my ($th) = new IO::File;
- $th->open($template, "r") || die "Couldn't open $template: $!\n";
-
- # add in the local variables
- $data->{"title"} = $data->{"name"};
- $data->{"ldoc"} = $data->{"doc"};
- $data->{"toc_link"} = toc_link($data->{"name"});
- $data->{"alpha_link"} = alpha_link($data->{"name"});
- if (exists $data->{"aliases"}) {
- $data->{"aliaslist"} = join(", ", @{$data->{"aliases"}});
- }
- # XXX can't do this and then HTML escape..
-
# $data->{"ldoc"} =~ s/\n\n/<\/p>\n<p>\n/;
- # XXX and the end-of-line formatting to turn single \n's into <BR>\n's.
-
- while (<$th>) {
- # Do variable substitution
- s/%(.*?)%/htmlescape($data->{$1})/ge;
- print $fh $_;
- }
- close $th;
- undef $th;
-
- if ($fh_open) {
- close $fh;
- undef $fh;
- }
+ my ($template, $data) = @_;
+ my $fh;
+ my $fh_open = 0;
+ # XXX should make sure the config option is a valid unix filename!
+ if ($format eq "splithtml") {
+ my ($fn) = filename($data->{'name'});
+ $fh = new IO::File;
+ $fh->open($fn, "w") || die "Couldn't open $fn: $!\n";
+ $fh_open = 1;
+ } else {
+ $fh = $index;
+ }
+
+ $data->{"ifdef"} = $defines{$data->{"ifdef"}} if (exists $data->{"ifdef"} && exists $defines{$data->{"ifdef"}});
+
+ my ($th) = new IO::File;
+ $th->open($template, "r") || die "Couldn't open $template: $!\n";
+
+ # add in the local variables
+ $data->{"title"} = $data->{"name"};
+ $data->{"ldoc"} = $data->{"doc"};
+ $data->{"toc_link"} = toc_link($data->{"name"});
+ $data->{"alpha_link"} = alpha_link($data->{"name"});
+ if (exists $data->{"aliases"}) {
+ $data->{"aliaslist"} = join(", ", @{$data->{"aliases"}});
+ }
+ # XXX can't do this and then HTML escape..
+ # $data->{"ldoc"} =~ s/\n\n/<\/p>\n<p>\n/;
+ # XXX and the end-of-line formatting to turn single \n's into <BR>\n's.
+
+ while (<$th>) {
+ # Do variable substitution
+ s/%(.*?)%/htmlescape($data->{$1})/ge;
+ print $fh $_;
+ }
+ close $th;
+ undef $th;
+
+ if ($fh_open) {
+ close $fh;
+ undef $fh;
+ }
}
$index->open(filename("index"), "w") || die "Couldn't open ".filename("index").": $!\n" if ($format eq "splithtml");
</head>
<body>
EOF
-;
+ ;
my ($name, $data);
{
my ($name, $type) = @_;
if (!$in_options) {
- print $index "<ul>\n";
- $in_options = 1;
+ $in_options = 1;
}
return if $type eq "obsolete";
print $index ' <li><a href="' . htmlescape(section_link($name)) . '" name="toc_' . htmlescape($name) . '">' . htmlescape($name) . "</a></li>\n";
}
sub section_heading($)
{
- my ($comment) = @_;
-
print $index "<pre>\n";
- print $index $comment;
- print $index "</pre>\n";
+ my ($comment) = @_;
+ print $index "<pre>\n";
+ print $index $comment;
+ print $index "</pre>\n";
}
sub update_defaults()
{
- if (defined($data->{"default_doc"})) {
- # default text description masks out the default value display
- if($data->{"default_doc"} ne "") {
- print "REPLACE: default '". $data->{"default"} ."' with '" . $data->{"default_doc"} . "'\n" if $verbose;
- $data->{"default"} = $data->{"default_doc"};
- }
- }
- # when we have no predefined default use the DEFAULT_IF_NONE
- if (defined($data->{"default_if_none"})) {
- print "REPLACE: default '". $data->{"default"} ."' with '" . $data->{"default_if_none"} . "'\n" if $verbose && $data->{"default"} eq "";
- $data->{"default"} = $data->{"default_if_none"} if $data->{"default"} eq "";
- }
+ if (defined($data->{"default_doc"})) {
+ # default text description masks out the default value display
+ if($data->{"default_doc"} ne "") {
+ print "REPLACE: default '". $data->{"default"} ."' with '" . $data->{"default_doc"} . "'\n" if $verbose;
+ $data->{"default"} = $data->{"default_doc"};
+ }
+ }
+ # when we have no predefined default use the DEFAULT_IF_NONE
+ if (defined($data->{"default_if_none"})) {
+ print "REPLACE: default '". $data->{"default"} ."' with '" . $data->{"default_if_none"} . "'\n" if $verbose && $data->{"default"} eq "";
+ $data->{"default"} = $data->{"default_if_none"} if $data->{"default"} eq "";
+ }
}
while (<>) {
- chomp;
- last if (/^EOF$/);
- if ($_ =~ /^NAME: (.*)$/) {
- my (@aliases) = split(/ /, $1);
- $data = {};
- $data->{'version'} = $version;
- foreach (@aliases) {
- $all_names{$_} = $data;
- }
-
- $name = shift @aliases;
-
- $option{$name} = $data;
- $data->{'name'} = $name;
- $data->{'aliases'} = \@aliases;
- $data->{'default'} = "";
- $data->{'default_doc'} = "";
- $data->{'default_if_none'} = "";
-
- print "DEBUG: new option: $name\n" if $verbose;
- next;
- } elsif ($_ =~ /^COMMENT: (.*)$/) {
- $data->{"comment"} = $1;
- } elsif ($_ =~ /^TYPE: (.*)$/) {
- $data->{"type"} = $1;
- start_option($data->{"name"}, $data->{"type"});
- } elsif ($_ =~ /^DEFAULT: (.*)$/) {
- if ($1 eq "none") {
- $data->{"default"} = "$1\n";
- } else {
- $data->{"default"} .= "$name $1\n";
- }
- } elsif ($_ =~ /^DEFAULT_DOC: (.*)$/) {
- $data->{"default_doc"} .= "$1\n";
- } elsif ($_ =~ /^DEFAULT_IF_NONE: (.*)$/) {
- $data->{"default_if_none"} .= "$1\n";
- } elsif ($_ =~ /^LOC:(.*)$/) {
- $data->{"loc"} = $1;
- $data->{"loc"} =~ s/^[\s\t]*//;
- } elsif ($_ =~ /^DOC_START$/) {
- update_defaults;
- $state = "doc";
- } elsif ($_ =~ /^DOC_END$/) {
- $state = "";
- my $othername;
- foreach $othername (@chained) {
- $option{$othername}{'doc'} = $data->{'doc'};
- }
- undef @chained;
- } elsif ($_ =~ /^DOC_NONE$/) {
- update_defaults;
- push(@chained, $name);
- } elsif ($_ =~ /^NOCOMMENT_START$/) {
- $state = "nocomment";
- } elsif ($_ =~ /^NOCOMMENT_END$/) {
- $state = "";
- } elsif ($_ =~ /^IFDEF: (.*)$/) {
- $data->{"ifdef"} = $1;
- } elsif ($_ =~ /^#/ && $state eq "doc") {
- $data->{"config"} .= $_ . "\n";
- } elsif ($state eq "nocomment") {
- $data->{"config"} .= $_ . "\n";
- } elsif ($state eq "doc") {
- $data->{"doc"} .= $_ . "\n";
- } elsif ($_ =~ /^COMMENT_START$/) {
- end_options;
- $state = "comment";
- $comment = "";
- } elsif ($_ =~ /^COMMENT_END$/) {
- section_heading($comment);
- } elsif ($state eq "comment") {
- $comment .= $_ . "\n";
- } elsif (/^#/) {
- next;
- } elsif ($_ ne "") {
- print "NOTICE: unknown line '$_'\n";
- }
+ chomp;
+ last if (/^EOF$/);
+ if ($_ =~ /^NAME: (.*)$/) {
+ my (@aliases) = split(/ /, $1);
+ $data = {};
+ $data->{'version'} = $version;
+ foreach (@aliases) {
+ $all_names{$_} = $data;
+ }
+
+ $name = shift @aliases;
+
+ $option{$name} = $data;
+ $data->{'name'} = $name;
+ $data->{'aliases'} = \@aliases;
+ $data->{'default'} = "";
+ $data->{'default_doc'} = "";
+ $data->{'default_if_none'} = "";
+
+ print "DEBUG: new option: $name\n" if $verbose;
+ next;
+ } elsif ($_ =~ /^COMMENT: (.*)$/) {
+ $data->{"comment"} = $1;
+ } elsif ($_ =~ /^TYPE: (.*)$/) {
+ $data->{"type"} = $1;
+ start_option($data->{"name"}, $data->{"type"});
+ } elsif ($_ =~ /^DEFAULT: (.*)$/) {
+ if ($1 eq "none") {
+ $data->{"default"} = "$1\n";
+ } else {
+ $data->{"default"} .= "$name $1\n";
+ }
+ } elsif ($_ =~ /^DEFAULT_DOC: (.*)$/) {
+ $data->{"default_doc"} .= "$1\n";
+ } elsif ($_ =~ /^DEFAULT_IF_NONE: (.*)$/) {
+ $data->{"default_if_none"} .= "$1\n";
+ } elsif ($_ =~ /^LOC:(.*)$/) {
+ $data->{"loc"} = $1;
+ $data->{"loc"} =~ s/^[\s\t]*//;
+ } elsif ($_ =~ /^DOC_START$/) {
+ update_defaults;
+ $state = "doc";
+ } elsif ($_ =~ /^DOC_END$/) {
+ $state = "";
+ my $othername;
+ foreach $othername (@chained) {
+ $option{$othername}{'doc'} = $data->{'doc'};
+ }
+ undef @chained;
+ } elsif ($_ =~ /^DOC_NONE$/) {
+ update_defaults;
+ push(@chained, $name);
+ } elsif ($_ =~ /^NOCOMMENT_START$/) {
+ $state = "nocomment";
+ } elsif ($_ =~ /^NOCOMMENT_END$/) {
+ $state = "";
+ } elsif ($_ =~ /^IFDEF: (.*)$/) {
+ $data->{"ifdef"} = $1;
+ } elsif ($_ =~ /^#/ && $state eq "doc") {
+ $data->{"config"} .= $_ . "\n";
+ } elsif ($state eq "nocomment") {
+ $data->{"config"} .= $_ . "\n";
+ } elsif ($state eq "doc") {
+ $data->{"doc"} .= $_ . "\n";
+ } elsif ($_ =~ /^COMMENT_START$/) {
+ end_options;
+ $state = "comment";
+ $comment = "";
+ } elsif ($_ =~ /^COMMENT_END$/) {
+ section_heading($comment);
+ } elsif ($state eq "comment") {
+ $comment .= $_ . "\n";
+ } elsif (/^#/) {
+ next;
+ } elsif ($_ ne "") {
+ print "NOTICE: unknown line '$_'\n";
+ }
}
end_options;
print $index "<p><a href=\"index_all.html\">Alphabetic index</a></p>\n" if $format eq "splithtml";
# and now, build the option pages
my (@names) = keys %option;
foreach $name (@names) {
- next if $option{$name}->{'type'} eq "obsolete";
- generate_page("${top}/${pagetemplate}", $option{$name});
+ next if $option{$name}->{'type'} eq "obsolete";
+ generate_page("${top}/${pagetemplate}", $option{$name});
}
# and now, the alpabetic index file!
<div id="logo">
<h1><a href="http://www.squid-cache.org/"><span>Squid-</span>Cache.org</a></h1>
<h2>Optimising Web Delivery</h2>
- </div>
+ </div>
</div>
<p>| <a href="index.html">Table of contents</a> |</p>
<h1>Alphabetic index of all options</h1>
EOF
-;
+ ;
} elsif ($format eq "singlehtml") {
$fh = $index;
print $fh "<h2><a name=\"index\">Alphabetic index of all options</a></h2>\n";
print $fh "<ul>\n";
foreach $name (sort keys %all_names) {
- my ($data) = $all_names{$name};
- next if $data->{'type'} eq "obsolete";
-
print $fh ' <li><a href="' . uriescape($data->{'name'}) . '.html" name="toc_' . htmlescape($name) . '">' . htmlescape($name) . "</a></li>\n";
+ my ($data) = $all_names{$name};
+ next if $data->{'type'} eq "obsolete";
+ print $fh ' <li><a href="' . uriescape($data->{'name'}) . '.html" name="toc_' . htmlescape($name) . '">' . htmlescape($name) . "</a></li>\n";
}
print $fh "</ul>\n";
if ($fh_open) {
-print $fh <<EOF
+ print $fh <<EOF
<p>| <a href="index.html">Table of contents</a> |</p>
</body>
</html>
EOF
-;
-$fh->close;
+ ;
+ $fh->close;
}
undef $fh;
</body>
</html>
EOF
-;
+ ;
$index->close;
undef $index;
=item B<--persist>
-Keep a persistent database connection open between queries.
+Keep a persistent database connection open between queries.
=item B<--debug>
my $debug = 0;
GetOptions(
- 'dsn=s' => \$dsn,
- 'user=s' => \$db_user,
- 'password=s' => \$db_passwd,
- 'table=s' => \$db_table,
- 'uidcol=s' => \$db_uidcol,
- 'usercol=s' => \$db_usercol,
- 'tagcol=s' => \$db_tagcol,
- 'cond=s' => \$db_cond,
- 'persist' => \$persist,
- 'debug' => \$debug,
- );
+ 'dsn=s' => \$dsn,
+ 'user=s' => \$db_user,
+ 'password=s' => \$db_passwd,
+ 'table=s' => \$db_table,
+ 'uidcol=s' => \$db_uidcol,
+ 'usercol=s' => \$db_usercol,
+ 'tagcol=s' => \$db_tagcol,
+ 'cond=s' => \$db_cond,
+ 'persist' => \$persist,
+ 'debug' => \$debug,
+ );
my ($_dbh, $_sth);
return $_sth if defined $_sth;
$_dbh = DBI->connect($dsn, $db_user, $db_passwd);
if (!defined $_dbh) {
- warn ("Could not connect to $dsn\n");
- return undef;
+ warn ("Could not connect to $dsn\n");
+ return undef;
}
$_sth = $_dbh->prepare("SELECT $db_usercol as 'user', $db_tagcol as 'tag' FROM $db_table WHERE ($db_uidcol = ?) " .
- ($db_cond ne "" ? " AND $db_cond" : "")) || die;
+ ($db_cond ne "" ? " AND $db_cond" : "")) || die;
print(stderr "Query: SELECT $db_usercol as 'user', $db_tagcol as 'tag' FROM $db_table WHERE ($db_uidcol = ?) " .
- ($db_cond ne "" ? " AND $db_cond" : "")) if ($debug);
+ ($db_cond ne "" ? " AND $db_cond" : "")) if ($debug);
return $_sth;
}
my ($sth) = open_db() || return undef;
print(stderr "UID queried: '".$uid."'\n") if ($debug);
if (!$sth->execute($uid)) {
- close_db();
- open_db() || return undef;
- $sth->execute($uid) || return undef;;
+ close_db();
+ open_db() || return undef;
+ $sth->execute($uid) || return undef;;
}
return $sth;
}
# item will stall the queue until completed. Supporting generic delays
# requires transforming @queue from a FIFO to a priority queue.
sub calc_delay {
- return $delay;
+ return $delay;
}
GetOptions("debug|d" => \$debug,
- "wait|w=i" => \$delay,
- "log|l=s" => \$logfilename)
-or die("Error in parsing command line arguments");
+ "wait|w=i" => \$delay,
+ "log|l=s" => \$logfilename)
+ or die("Error in parsing command line arguments");
if (defined $opts{h}) {
- HELP_MESSAGE();
- exit 0;
+ HELP_MESSAGE();
+ exit 0;
}
$delay /= 1000.0; # transform msec into sec
if ($logfilename) {
- open ($logfile,">>", "$opts{l}");
- $debug=1;
-}
+ open ($logfile,">>", "$opts{l}");
+ $debug=1;
+}
my @p=split(/[\\\/]/,$0);
my $prg_basename=pop @p;
# takes a result from a gettimeofday call and turns it into a
# floating-point number suitable for approximate time calculations and select
sub fract_time {
- return $_[0]+$_[1]/1000000;
+ return $_[0]+$_[1]/1000000;
}
sub dispatch_request {
- my $r = $_[0];
- chomp $r;
- &debug("got request: '$r'");
- my %evt = ();
- my @fields;
- @fields = split (/\s+/, $r);
- $evt{when} = &calc_delay($r)+fract_time(gettimeofday());
- $evt{reqid}=$reqid++;
- $evt{req} = $r;
- $evt{chan} = $fields[0];
- &debug("Dispatching: reqid $evt{reqid}, chan $evt{chan}, when $evt{when}, raw {$evt{req}}");
- push @queue,\%evt;
+ my $r = $_[0];
+ chomp $r;
+ &debug("got request: '$r'");
+ my %evt = ();
+ my @fields;
+ @fields = split (/\s+/, $r);
+ $evt{when} = &calc_delay($r)+fract_time(gettimeofday());
+ $evt{reqid}=$reqid++;
+ $evt{req} = $r;
+ $evt{chan} = $fields[0];
+ &debug("Dispatching: reqid $evt{reqid}, chan $evt{chan}, when $evt{when}, raw {$evt{req}}");
+ push @queue,\%evt;
}
sub next_event {
- my $now = fract_time(gettimeofday());
- if (@queue) {
- my $when = $queue[0]->{when} - $now;
- &debug("Next event is in $when seconds");
- return $when;
- }
- &debug("No events in queue");
- return undef;
+ my $now = fract_time(gettimeofday());
+ if (@queue) {
+ my $when = $queue[0]->{when} - $now;
+ &debug("Next event is in $when seconds");
+ return $when;
+ }
+ &debug("No events in queue");
+ return undef;
}
sub handle_events {
- my $now = fract_time(gettimeofday());
- while ( @queue ) {
- &debug("Queue length is $#queue");
- last if ($queue[0]->{when} > $now);
- my %evt = %{shift @queue};
- &debug("Event: reqid $evt{reqid}, chan $evt{chan}, when $evt{when}, raw {$evt{req}}");
- print $evt{chan} , " OK\n";
- }
+ my $now = fract_time(gettimeofday());
+ while ( @queue ) {
+ &debug("Queue length is $#queue");
+ last if ($queue[0]->{when} > $now);
+ my %evt = %{shift @queue};
+ &debug("Event: reqid $evt{reqid}, chan $evt{chan}, when $evt{when}, raw {$evt{req}}");
+ print $evt{chan} , " OK\n";
+ }
}
# main loop
while(1) {
- &debug("selecting");
- $nfound = select($rd = $rvec,undef,undef,&next_event());
- &debug("found $nfound bits set");
- if ($nfound == -1 ) {
- next if ($!{ERESTART} || $!{EAGAIN} || $!{EINTR});
- &debug("error in select: $!");
- exit 1;
- }
- if (vec($rd,0,1)==1) { #got stuff from stdin
- my $d; #data
- $nread = sysread(STDIN,$d,40960); # read 40kb
- # clear the signal-bit, stdin is special
- vec($rd,0,1) = 0;
- if ($nread==0) {
- &debug("nothing read from stdin, exiting");
- exit 0;
+ &debug("selecting");
+ $nfound = select($rd = $rvec,undef,undef,&next_event());
+ &debug("found $nfound bits set");
+ if ($nfound == -1 ) {
+ next if ($!{ERESTART} || $!{EAGAIN} || $!{EINTR});
+ &debug("error in select: $!");
+ exit 1;
}
- my $i;
- while ($i = index($d,"\n")) { #BUG: assumption of no spill-over
- last if ($i == -1);
- &dispatch_request(substr($d,0,$i));
- $d=substr($d,$i+1);
+ if (vec($rd,0,1)==1) { #got stuff from stdin
+ my $d; #data
+ $nread = sysread(STDIN,$d,40960); # read 40kb
+ # clear the signal-bit, stdin is special
+ vec($rd,0,1) = 0;
+ if ($nread==0) {
+ &debug("nothing read from stdin, exiting");
+ exit 0;
+ }
+ my $i;
+ while ($i = index($d,"\n")) { #BUG: assumption of no spill-over
+ last if ($i == -1);
+ &dispatch_request(substr($d,0,$i));
+ $d=substr($d,$i+1);
+ }
}
- }
- &handle_events();
+ &handle_events();
}
my $doc = <<_EOF;
our $VERSION = "1.0";
sub HELP_MESSAGE {
- print STDERR $doc;
+ print STDERR $doc;
}
sub dump_state {
- $SIG{HUP} = \&dump_state;
- print STDERR "Queue:\n",Dumper(\@queue),"\n";
+ $SIG{HUP} = \&dump_state;
+ print STDERR "Queue:\n",Dumper(\@queue),"\n";
}
sub debug {
- return unless ($debug);
- print $logfile $prg_basename , ": ", @_, "\n";
+ return unless ($debug);
+ print $logfile $prg_basename , ": ", @_, "\n";
}
sub debug()
{
- my @lt = localtime;
- print STDERR strftime("%Y/%m/%d %H:%M:%S", @lt)." | $name: @_\n" if $opt{d};
+ my @lt = localtime;
+ print STDERR strftime("%Y/%m/%d %H:%M:%S", @lt)." | $name: @_\n" if $opt{d};
}
sub info()
{
- my @lt = localtime;
- print STDERR strftime("%Y/%m/%d %H:%M:%S", @lt)." | $name: @_\n";
+ my @lt = localtime;
+ print STDERR strftime("%Y/%m/%d %H:%M:%S", @lt)." | $name: @_\n";
}
sub check()
{
- if ( grep( /^@_$/, @ADgroupSIDs) ) {
- &debug("DEBUG: Found @_ in AD group SID");
- return "OK";
- } else {
- &debug("DEBUG: Did not find @_ in AD group SID");
- return "ERR";
- }
+ if ( grep( /^@_$/, @ADgroupSIDs) ) {
+ &debug("DEBUG: Found @_ in AD group SID");
+ return "OK";
+ } else {
+ &debug("DEBUG: Did not find @_ in AD group SID");
+ return "ERR";
+ }
}
#
#
sub init()
{
- use Getopt::Std;
- my $errmsg;
- my $opt_string = 'hdD:p:b:G:';
- getopts( "$opt_string", \%opt ) or usage();
- Pod::Usage::pod2usage(1) if $opt{h};
- Pod::Usage::pod2usage(1) if not defined $opt{D};
- Pod::Usage::pod2usage(1) if not defined $opt{b};
- Pod::Usage::pod2usage(1) if not defined $opt{p};
- Pod::Usage::pod2usage(1) if not defined $opt{G};
-
- $ENV{'KRB5CCNAME'} = $ccname;
-
- @groups = split(/:/,$opt{G});
- $errmsg=`kinit -k $opt{p} 2>&1`;
- &info("ERROR: $errmsg") if $errmsg;
- exit 99 if $errmsg;
-
- $errmsg="";
- foreach my $group (@groups) {
- open(LDAP, "ldapsearch -LLL -Ygssapi -H ldap://$opt{D}:389 -s sub -b \"$opt{b}\" \"(CN=$group)\" objectsid 2>&1 |");
- my $sid;
- while (<LDAP>) {
- chomp($_);
- if ( $_ =~ /^object/ && defined $sid ) {
- &info("ERROR: multiple SIDs returned for group $group");
- } elsif ( $_ =~ /^object/ ) {
- $sid=$_;
- $sid=~s/^[^\s]+\s+//;
- } else {
- $errmsg=$errmsg.";".$_;
- }
- }
- close(LDAP);
- if ( ! defined $sid ) {
- $errmsg=~s/^;//;
- &info("ERROR: $errmsg");
- &info("ERROR: no SID returned for group $group");
- } else {
- &info("INFO:ldapsearch result Group=$group, SID=$sid");
- push @ADgroupSIDs, $sid;
- }
- }
- &info("ERROR: Exit as no sid was found for any group") if ! @ADgroupSIDs;
- exit 99 if ! @ADgroupSIDs;
+ use Getopt::Std;
+ my $errmsg;
+ my $opt_string = 'hdD:p:b:G:';
+ getopts( "$opt_string", \%opt ) or usage();
+ Pod::Usage::pod2usage(1) if $opt{h};
+ Pod::Usage::pod2usage(1) if not defined $opt{D};
+ Pod::Usage::pod2usage(1) if not defined $opt{b};
+ Pod::Usage::pod2usage(1) if not defined $opt{p};
+ Pod::Usage::pod2usage(1) if not defined $opt{G};
+
+ $ENV{'KRB5CCNAME'} = $ccname;
+
+ @groups = split(/:/,$opt{G});
+ $errmsg=`kinit -k $opt{p} 2>&1`;
+ &info("ERROR: $errmsg") if $errmsg;
+ exit 99 if $errmsg;
+
+ $errmsg="";
+ foreach my $group (@groups) {
+ open(LDAP, "ldapsearch -LLL -Ygssapi -H ldap://$opt{D}:389 -s sub -b \"$opt{b}\" \"(CN=$group)\" objectsid 2>&1 |");
+ my $sid;
+ while (<LDAP>) {
+ chomp($_);
+ if ( $_ =~ /^object/ && defined $sid ) {
+ &info("ERROR: multiple SIDs returned for group $group");
+ } elsif ( $_ =~ /^object/ ) {
+ $sid=$_;
+ $sid=~s/^[^\s]+\s+//;
+ } else {
+ $errmsg=$errmsg.";".$_;
+ }
+ }
+ close(LDAP);
+ if ( ! defined $sid ) {
+ $errmsg=~s/^;//;
+ &info("ERROR: $errmsg");
+ &info("ERROR: no SID returned for group $group");
+ } else {
+ &info("INFO:ldapsearch result Group=$group, SID=$sid");
+ push @ADgroupSIDs, $sid;
+ }
+ }
+ &info("ERROR: Exit as no sid was found for any group") if ! @ADgroupSIDs;
+ exit 99 if ! @ADgroupSIDs;
}
init();
# Main loop
#
while (<STDIN>) {
- chop;
- &debug("DEBUG: Got $_ from squid");
- ($user, $groupSIDs) = split(/\s+/);
- if ( defined $user && defined $groupSIDs ) {
- &debug("DEBUG: user=$user");
- &debug("DEBUG: groups=$groupSIDs");
- # test for each group squid send in it's request
- foreach my $group (split(/,/,$groupSIDs)) {
- $ans = &check($group);
- last if $ans eq "OK";
- }
- &debug("DEBUG: Sending $ans to squid");
- print "$ans\n";
- } else {
- &debug("DEBUG: Sending ERR to squid");
- print "ERR\n";
- }
+ chop;
+ &debug("DEBUG: Got $_ from squid");
+ ($user, $groupSIDs) = split(/\s+/);
+ if ( defined $user && defined $groupSIDs ) {
+ &debug("DEBUG: user=$user");
+ &debug("DEBUG: groups=$groupSIDs");
+ # test for each group squid send in it's request
+ foreach my $group (split(/,/,$groupSIDs)) {
+ $ans = &check($group);
+ last if $ans eq "OK";
+ }
+ &debug("DEBUG: Sending $ans to squid");
+ print "$ans\n";
+ } else {
+ &debug("DEBUG: Sending ERR to squid");
+ print "ERR\n";
+ }
}
# Fix for wbinfo from Samba 3.0.21
#
# 2004-08-15 Henrik Nordstrom <hno@squid-cache.org>
-# Helper protocol changed to URL escaped in Squid-3.0
+# Helper protocol changed to URL escaped in Squid-3.0
#
# 2005-06-28 Arno Streuli <astreuli@gmail.com>
# Add multi group check
#
# 2002-07-05 Jerry Murdock <jmurdock@itraktech.com>
-# Initial release
+# Initial release
#
# Globals
$|=1;
sub debug {
- print STDERR "@_\n" if $opt{d};
+ print STDERR "@_\n" if $opt{d};
}
#
# Check if a user belongs to a group
#
sub check {
- my $groupSID;
- my $groupGID;
- my @tmpuser;
-
- our($user, $group) = @_;
- if ($opt{K} && ($user =~ m/\@/)) {
- @tmpuser = split(/\@/, $user);
- $user = "$tmpuser[1]\\$tmpuser[0]";
- }
- $groupSID = `wbinfo -n "$group" | cut -d" " -f1`;
- chop $groupSID;
- $groupGID = `wbinfo -Y "$groupSID"`;
- chop $groupGID;
- &debug( "User: -$user-\nGroup: -$group-\nSID: -$groupSID-\nGID: -$groupGID-");
- return 'ERR' if($groupGID eq ""); # Verify if groupGID variable is empty.
- return 'ERR' if(`wbinfo -r \Q$user\E` eq ""); # Verify if "wbinfo -r" command returns no value.
- return 'OK' if(`wbinfo -r \Q$user\E` =~ /^$groupGID$/m);
- return 'ERR';
+ my $groupSID;
+ my $groupGID;
+ my @tmpuser;
+
+ our($user, $group) = @_;
+ if ($opt{K} && ($user =~ m/\@/)) {
+ @tmpuser = split(/\@/, $user);
+ $user = "$tmpuser[1]\\$tmpuser[0]";
+ }
+ $groupSID = `wbinfo -n "$group" | cut -d" " -f1`;
+ chop $groupSID;
+ $groupGID = `wbinfo -Y "$groupSID"`;
+ chop $groupGID;
+ &debug( "User: -$user-\nGroup: -$group-\nSID: -$groupSID-\nGID: -$groupGID-");
+ return 'ERR' if($groupGID eq ""); # Verify if groupGID variable is empty.
+ return 'ERR' if(`wbinfo -r \Q$user\E` eq ""); # Verify if "wbinfo -r" command returns no value.
+ return 'OK' if(`wbinfo -r \Q$user\E` =~ /^$groupGID$/m);
+ return 'ERR';
}
#
#
sub usage()
{
- print "Usage: ext_wbinfo_group_acl -dh\n";
- print "\t-d enable debugging\n";
- print "\t-h print the help\n";
- print "\t-K downgrade Kerberos credentials to NTLM.\n";
- exit;
+ print "Usage: ext_wbinfo_group_acl -dh\n";
+ print "\t-d enable debugging\n";
+ print "\t-h print the help\n";
+ print "\t-K downgrade Kerberos credentials to NTLM.\n";
+ exit;
}
init();
# Main loop
#
while (<STDIN>) {
- chop;
- &debug("Got $_ from squid");
- ($user, @groups) = split(/\s+/);
- $user =~ s/%([0-9a-fA-F][0-9a-fA-F])/pack("c",hex($1))/eg;
- # test for each group squid send in it's request
- foreach $group (@groups) {
- $group =~ s/%([0-9a-fA-F][0-9a-fA-F])/pack("c",hex($1))/eg;
- $ans = &check($user, $group);
- last if $ans eq "OK";
- }
- &debug("Sending $ans to squid");
- print "$ans\n";
+ chop;
+ &debug("Got $_ from squid");
+ ($user, @groups) = split(/\s+/);
+ $user =~ s/%([0-9a-fA-F][0-9a-fA-F])/pack("c",hex($1))/eg;
+# test for each group squid send in it's request
+ foreach $group (@groups) {
+ $group =~ s/%([0-9a-fA-F][0-9a-fA-F])/pack("c",hex($1))/eg;
+ $ans = &check($user, $group);
+ last if $ans eq "OK";
+ }
+ &debug("Sending $ans to squid");
+ print "$ans\n";
}
=item B<--persist>
-Keep a persistent database connection open between queries.
+Keep a persistent database connection open between queries.
=item B<--joomla>
-Tells helper that user database is Joomla DB. So their unusual salt
+Tells helper that user database is Joomla DB. So their unusual salt
hashing is understood.
=back
my $hashsalt = undef;
GetOptions(
- 'dsn=s' => \$dsn,
- 'user=s' => \$db_user,
- 'password=s' => \$db_passwd,
- 'table=s' => \$db_table,
- 'usercol=s' => \$db_usercol,
- 'passwdcol=s' => \$db_passwdcol,
- 'cond=s' => \$db_cond,
- 'plaintext' => \$plaintext,
- 'md5' => \$md5,
- 'sha1' => \$sha1,
- 'persist' => \$persist,
- 'joomla' => \$isjoomla,
- 'debug' => \$debug,
- 'salt=s' => \$hashsalt,
- );
+ 'dsn=s' => \$dsn,
+ 'user=s' => \$db_user,
+ 'password=s' => \$db_passwd,
+ 'table=s' => \$db_table,
+ 'usercol=s' => \$db_usercol,
+ 'passwdcol=s' => \$db_passwdcol,
+ 'cond=s' => \$db_cond,
+ 'plaintext' => \$plaintext,
+ 'md5' => \$md5,
+ 'sha1' => \$sha1,
+ 'persist' => \$persist,
+ 'joomla' => \$isjoomla,
+ 'debug' => \$debug,
+ 'salt=s' => \$hashsalt,
+ );
my ($_dbh, $_sth);
$db_cond = "block = 0" if $isjoomla;
return $_sth if defined $_sth;
$_dbh = DBI->connect($dsn, $db_user, $db_passwd);
if (!defined $_dbh) {
- warn ("Could not connect to $dsn\n");
- my @driver_names = DBI->available_drivers();
- my $msg = "DSN drivers apparently installed, available:\n";
- foreach my $dn (@driver_names) {
- $msg .= "\t$dn";
- }
- warn($msg."\n");
- return undef;
+ warn ("Could not connect to $dsn\n");
+ my @driver_names = DBI->available_drivers();
+ my $msg = "DSN drivers apparently installed, available:\n";
+ foreach my $dn (@driver_names) {
+ $msg .= "\t$dn";
+ }
+ warn($msg."\n");
+ return undef;
}
my $sql_query;
$sql_query = "SELECT $db_passwdcol FROM $db_table WHERE $db_usercol = ?" . ($db_cond ne "" ? " AND $db_cond" : "");
my ($user) = @_;
my ($sth) = open_db() || return undef;
if (!$sth->execute($user)) {
- close_db();
- open_db() || return undef;
- $sth->execute($user) || return undef;;
+ close_db();
+ open_db() || return undef;
+ $sth->execute($user) || return undef;;
}
return $sth;
}
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.
- #
+ #
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU General Public License for more details.
- #
+ #
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111, USA.
- #
+ #
# Change log:
- # 2006-12-10 henrik Initial revision
+ # 2006-12-10 henrik Initial revision
#
=head1 QUESTIONS
my $pop = Net::POP3->new($server);
if (!$pop) {
- print "ERR Server not responding\n";
- next;
+ print "ERR Server not responding\n";
+ next;
}
# Here apop could be used instead for MD5 support
if ($pop->login($username, $password)) {
- print "OK\n";
+ print "OK\n";
} else {
- print "ERR\n";
+ print "ERR\n";
}
$pop->quit;
undef $pop;
# user's credentials, it just takes the client's domain and username
# at face value.
# It's included mostly for demonstration purposes.
-#
+#
# TODO: use command-line arguments
#use MIME::Base64;
die ("Edit $0 to configure a domain!") unless (defined($authdomain));
while(<STDIN>) {
- chop;
- if (substr($_, 0, 2) eq "YR") {
- print "TT ".encode_base64(&make_ntlm_static_challenge);
- next;
- }
- $got=substr($_,3);
- %res=decode_ntlm_any(decode_base64($got));
-# print STDERR "got: ".hash_to_string(%res);
- if (!res) { # broken NTLM, deny
- print "BH Couldn't decode NTLM packet\n";
- next;
- }
- if ($res{type} eq "negotiate") { # ok, send a challenge
- print "BH Squid-helper protocol error: unexpected negotiate-request\n";
- next;
- }
- if ($res{type} eq "challenge") { # Huh? WE are the challengers.
- print "BH Squid-helper protocol error: unexpected challenge-request\n";
- next;
- }
- if ($res{type} eq "authentication") {
- print "AF $res{domain}\\$res{user}\n";
- next;
- }
- print "BH internal error\n"; # internal error
+ chop;
+ if (substr($_, 0, 2) eq "YR") {
+ print "TT ".encode_base64(&make_ntlm_static_challenge);
+ next;
+ }
+ $got=substr($_,3);
+ %res=decode_ntlm_any(decode_base64($got));
+# print STDERR "got: ".hash_to_string(%res);
+ if (!res) { # broken NTLM, deny
+ print "BH Couldn't decode NTLM packet\n";
+ next;
+ }
+ if ($res{type} eq "negotiate") { # ok, send a challenge
+ print "BH Squid-helper protocol error: unexpected negotiate-request\n";
+ next;
+ }
+ if ($res{type} eq "challenge") { # Huh? WE are the challengers.
+ print "BH Squid-helper protocol error: unexpected challenge-request\n";
+ next;
+ }
+ if ($res{type} eq "authentication") {
+ print "AF $res{domain}\\$res{user}\n";
+ next;
+ }
+ print "BH internal error\n"; # internal error
}
sub make_ntlm_static_challenge {
- $rv = pack ("a8 V", "NTLMSSP", 0x2);
- $payload = "";
+ $rv = pack ("a8 V", "NTLMSSP", 0x2);
+ $payload = "";
- $rv .= add_to_data(uc($authdomain),\$payload);
- $rv .= pack ("V Z8 v8", 0x18206, $challenge,0,0,0,0,0,0,0x3a,0);
- #flags, challenge, 8 bytes of unknown stuff
+ $rv .= add_to_data(uc($authdomain),\$payload);
+ $rv .= pack ("V Z8 v8", 0x18206, $challenge,0,0,0,0,0,0,0x3a,0);
+ #flags, challenge, 8 bytes of unknown stuff
- return $rv.$payload;
+ return $rv.$payload;
}
#gets as argument the decoded authenticate packet.
#returns either undef (failure to decode) or an hash with the decoded
# fields.
sub decode_ntlm_authentication {
- my ($got)=$_[0];
- my ($signature, $type, %rv, $hdr, $rest);
- ($signature, $type, $rest) = unpack ("a8 V a*",$got);
- return unless ($signature eq "NTLMSSP\0");
- return unless ($type == 0x3);
- $rv{type}="authentication";
- ($hdr, $rest) = unpack ("a8 a*", $rest);
- $rv{lmresponse}=get_from_data($hdr,$got);
- ($hdr, $rest) = unpack ("a8 a*", $rest);
- $rv{ntresponse}=get_from_data($hdr,$got);
- ($hdr, $rest) = unpack ("a8 a*", $rest);
- $rv{domain}=get_from_data($hdr,$got);
- ($hdr, $rest) = unpack ("a8 a*", $rest);
- $rv{user}=get_from_data($hdr,$got);
- ($hdr, $rest) = unpack ("a8 a*", $rest);
- $rv{workstation}=get_from_data($hdr,$got);
- ($hdr, $rest) = unpack ("a8 a*", $rest);
- $rv{sessionkey}=get_from_data($hdr,$got);
- $rv{flags}=unpack("V",$rest);
- return %rv;
+ my ($got)=$_[0];
+ my ($signature, $type, %rv, $hdr, $rest);
+ ($signature, $type, $rest) = unpack ("a8 V a*",$got);
+ return unless ($signature eq "NTLMSSP\0");
+ return unless ($type == 0x3);
+ $rv{type}="authentication";
+ ($hdr, $rest) = unpack ("a8 a*", $rest);
+ $rv{lmresponse}=get_from_data($hdr,$got);
+ ($hdr, $rest) = unpack ("a8 a*", $rest);
+ $rv{ntresponse}=get_from_data($hdr,$got);
+ ($hdr, $rest) = unpack ("a8 a*", $rest);
+ $rv{domain}=get_from_data($hdr,$got);
+ ($hdr, $rest) = unpack ("a8 a*", $rest);
+ $rv{user}=get_from_data($hdr,$got);
+ ($hdr, $rest) = unpack ("a8 a*", $rest);
+ $rv{workstation}=get_from_data($hdr,$got);
+ ($hdr, $rest) = unpack ("a8 a*", $rest);
+ $rv{sessionkey}=get_from_data($hdr,$got);
+ $rv{flags}=unpack("V",$rest);
+ return %rv;
}
#args: len, maxlen, offset
sub make_ntlm_hdr {
- return pack ("v v V", @_);
+ return pack ("v v V", @_);
}
#args: string to add, ref to payload
# returns ntlm header.
sub add_to_data {
- my ($toadd, $pl) = @_;
- my ($offset);
-# $toadd.='\0' unless ($toadd[-1]=='\0'); #broken
- $offset=48+length $pl; #48 is the length of the header
- $$pl.=$toadd;
- return make_ntlm_hdr (length $toadd, length $toadd, $offset);
+ my ($toadd, $pl) = @_;
+ my ($offset);
+# $toadd.='\0' unless ($toadd[-1]=='\0'); #broken
+ $offset=48+length $pl; #48 is the length of the header
+ $$pl.=$toadd;
+ return make_ntlm_hdr (length $toadd, length $toadd, $offset);
}
#args: encoded descriptor, entire decoded packet
# returns the decoded data
sub get_from_data {
- my($desc,$packet) = @_;
- my($offset,$length, $rv);
- ($length, undef, $offset) = unpack ("v v V", $desc);
- return unless ($length+$offset <= length $packet);
- $rv = unpack ("x$offset a$length",$packet);
- return $rv;
+ my($desc,$packet) = @_;
+ my($offset,$length, $rv);
+ ($length, undef, $offset) = unpack ("v v V", $desc);
+ return unless ($length+$offset <= length $packet);
+ $rv = unpack ("x$offset a$length",$packet);
+ return $rv;
}
sub hash_to_string {
- my (%hash) = @_;
- my ($rv);
- foreach (sort keys %hash) {
- $rv.=$_." => ".$hash{$_}."\n";
- }
- return $rv;
+ my (%hash) = @_;
+ my ($rv);
+ foreach (sort keys %hash) {
+ $rv.=$_." => ".$hash{$_}."\n";
+ }
+ return $rv;
}
#args: the base64-decoded packet
#returns: either undef or an hash describing the packet.
sub decode_ntlm_negotiate {
- my($got)=$_[0];
- my($signature, $type, %rv, $hdr, $rest);
- ($signature, $type, $rest) = unpack ("a8 V a*",$got);
- return unless ($signature eq "NTLMSSP\0");
- return unless ($type == 0x1);
- $rv{type}="negotiate";
- ($rv{flags}, $rest)=unpack("V a*",$rest);
- ($hdr, $rest) = unpack ("a8 a*", $rest);
- $rv{domain}=get_from_data($hdr,$got);
- ($hdr, $rest) = unpack ("a8 a*", $rest);
- $rv{workstation}=get_from_data($hdr,$got);
- return %rv;
+ my($got)=$_[0];
+ my($signature, $type, %rv, $hdr, $rest);
+ ($signature, $type, $rest) = unpack ("a8 V a*",$got);
+ return unless ($signature eq "NTLMSSP\0");
+ return unless ($type == 0x1);
+ $rv{type}="negotiate";
+ ($rv{flags}, $rest)=unpack("V a*",$rest);
+ ($hdr, $rest) = unpack ("a8 a*", $rest);
+ $rv{domain}=get_from_data($hdr,$got);
+ ($hdr, $rest) = unpack ("a8 a*", $rest);
+ $rv{workstation}=get_from_data($hdr,$got);
+ return %rv;
}
sub decode_ntlm_challenge {
- my($got)=$_[0];
- my($signature, $type, %rv, $hdr, $rest, $j);
- ($signature, $type, $rest) = unpack ("a8 V a*",$got);
- return unless ($signature eq "NTLMSSP\0");
- return unless ($type == 0x2);
- $rv{type}="challenge";
- ($rv{flags}, $rest)=unpack("V a*",$rest);
- ($rv{challenge}, $rest)=unpack("a8 a*",$rest);
- for ($j=0;$j<8;$j++) { # don't shoot on the programmer, please.
- ($rv{"context.$j"},$rest)=unpack("v a*",$rest);
- }
- return %rv;
+ my($got)=$_[0];
+ my($signature, $type, %rv, $hdr, $rest, $j);
+ ($signature, $type, $rest) = unpack ("a8 V a*",$got);
+ return unless ($signature eq "NTLMSSP\0");
+ return unless ($type == 0x2);
+ $rv{type}="challenge";
+ ($rv{flags}, $rest)=unpack("V a*",$rest);
+ ($rv{challenge}, $rest)=unpack("a8 a*",$rest);
+ for ($j=0;$j<8;$j++) { # don't shoot on the programmer, please.
+ ($rv{"context.$j"},$rest)=unpack("v a*",$rest);
+ }
+ return %rv;
}
#decodes any NTLMSSP packet.
#arg: the encoded packet, returns an hash with packet info
sub decode_ntlm_any {
- my($got)=$_[0];
- my ($signature, $type);
- ($signature, $type, undef) = unpack ("a8 V a*",$got);
- return unless ($signature eq "NTLMSSP\0");
- return decode_ntlm_negotiate($got) if ($type == 1);
- return decode_ntlm_challenge($got) if ($type == 2);
- return decode_ntlm_authentication($got) if ($type == 3);
- return undef; # default
+ my($got)=$_[0];
+ my ($signature, $type);
+ ($signature, $type, undef) = unpack ("a8 V a*",$got);
+ return unless ($signature eq "NTLMSSP\0");
+ return decode_ntlm_negotiate($got) if ($type == 1);
+ return decode_ntlm_challenge($got) if ($type == 2);
+ return decode_ntlm_authentication($got) if ($type == 3);
+ return undef; # default
}
$eol = "\n" unless defined $eol;
pos($_[0]) = 0; # ensure start at the beginning
while ($_[0] =~ /(.{1,45})/gs) {
- $res .= substr(pack('u', $1), 1);
- chop($res);
+ $res .= substr(pack('u', $1), 1);
+ chop($res);
}
$res =~ tr|` -_|AA-Za-z0-9+/|; # `# help emacs
# fix padding at the end
$res =~ s/.{$padding}$/'=' x $padding/e if $padding;
# break encoded string into lines of no more than 76 characters each
if (length $eol) {
- $res =~ s/(.{1,76})/$1$eol/g;
+ $res =~ s/(.{1,76})/$1$eol/g;
}
$res;
}
$str =~ tr|A-Za-z0-9+=/||cd; # remove non-base64 chars
if (length($str) % 4) {
- require Carp;
- Carp::carp("Length of base64 data not a multiple of 4")
+ require Carp;
+ Carp::carp("Length of base64 data not a multiple of 4")
}
$str =~ s/=+$//; # remove padding
$str =~ tr|A-Za-z0-9+/| -_|; # convert to uuencoded format
while ($str =~ /(.{1,60})/gs) {
- my $len = chr(32 + length($1)*3/4); # compute length byte
- $res .= unpack("u", $len . $1 ); # uudecode
+ my $len = chr(32 + length($1)*3/4); # compute length byte
+ $res .= unpack("u", $len . $1 ); # uudecode
}
$res;
}
my $redirect_path = "";
GetOptions(
- 'debug' => \$debug,
- 'local-dir=s' => \$access_local_dir,
- 'to-scheme=s' => \$redirect_scheme,
- 'to-host=s' => \$redirect_host,
- 'to-path=s' => \$redirect_path,
-);
+ 'debug' => \$debug,
+ 'local-dir=s' => \$access_local_dir,
+ 'to-scheme=s' => \$redirect_scheme,
+ 'to-host=s' => \$redirect_host,
+ 'to-path=s' => \$redirect_path,
+ );
# flush after every print
$| = 1;
# do not process hosts with unqualified hostnames
if ($host !~ /\./ ) {
- $status = $cid . " ERR message=\"unqualified hostname\"";
- print "found unqualified hostname.\n" if $debug;
- next;
+ $status = $cid . " ERR message=\"unqualified hostname\"";
+ print "found unqualified hostname.\n" if $debug;
+ next;
}
# just the file, without any host or path parts
# look if in local dir, if yes redirect
if ( $file && -r $access_local_dir . $file
- && $file ne '.' && $file ne '..' ) {
+ && $file ne '.' && $file ne '..' ) {
- $url->scheme($redirect_scheme);
- $url->host($redirect_host);
- $url->path($redirect_path . $file);
+ $url->scheme($redirect_scheme);
+ $url->host($redirect_host);
+ $url->path($redirect_path . $file);
- $status = $cid . " OK rewrite-url=\"" . $url . "\"";
- print "file found: " . $file . "\n" if $debug;
+ $status = $cid . " OK rewrite-url=\"" . $url . "\"";
+ print "file found: " . $file . "\n" if $debug;
} else {
- $status = $cid . " ERR";
- print "file not found: " . $file . "\n" if $debug;
+ $status = $cid . " ERR";
+ print "file not found: " . $file . "\n" if $debug;
}
} continue {
# others may be options
my $debug = 0;
GetOptions(
- 'debug' => \$debug,
- );
+ 'debug' => \$debug,
+ );
# utility routine to print messages on stderr (so they appear in cache log)
squid_hier_status
ip_server
http_mime_type
-);
+ );
# perform db connection
my $dsn = "DBI:mysql:database=$database" . ($host ne "localhost" ? ":$host" : "");
eval {
warn "Connecting... dsn='$dsn', username='$user', password='...'";
$dbh = DBI->connect($dsn, $user, $pass, { AutoCommit => 1, RaiseError => 1, PrintError => 1 });
-};
+ };
if ($EVAL_ERROR) {
die "Cannot connect to database: $DBI::errstr";
}
my $q = 'SELECT ' . join(',',@db_fields) . " FROM $table LIMIT 1";
my $sth = $dbh->prepare($q);
$sth->execute;
-};
+ };
if ($EVAL_ERROR) {
# run a query to create the table of required syntax
my $create_query = 'CREATE TABLE ' . $table . ' (' .
- " id INTEGER NOT NULL AUTO_INCREMENT PRIMARY KEY," .
- " time_since_epoch DECIMAL(15,3)," .
- " time_response INTEGER," .
- " ip_client CHAR(15)," .
- " ip_server CHAR(15)," .
- " http_status_code VARCHAR(10)," .
- " http_reply_size INTEGER," .
- " http_method VARCHAR(20)," .
- " http_url TEXT," .
- " http_username VARCHAR(20)," .
- " http_mime_type VARCHAR(50)," .
- " squid_request_status VARCHAR(50)," .
- " squid_hier_status VARCHAR(20)" .
- ");" ;
+ " id INTEGER NOT NULL AUTO_INCREMENT PRIMARY KEY," .
+ " time_since_epoch DECIMAL(15,3)," .
+ " time_response INTEGER," .
+ " ip_client CHAR(15)," .
+ " ip_server CHAR(15)," .
+ " http_status_code VARCHAR(10)," .
+ " http_reply_size INTEGER," .
+ " http_method VARCHAR(20)," .
+ " http_url TEXT," .
+ " http_username VARCHAR(20)," .
+ " http_mime_type VARCHAR(50)," .
+ " squid_request_status VARCHAR(50)," .
+ " squid_hier_status VARCHAR(20)" .
+ ");" ;
$sth = $dbh->prepare($create_query);
$sth->execute;
my $q = 'SELECT ' . join(',',@db_fields) . " FROM $table LIMIT 1";
my $sth = $dbh->prepare($q);
$sth->execute;
- };
+ };
if ($EVAL_ERROR) {
die "Error initializing database table: $EVAL_ERROR";
};
# for better performance, prepare the statement at startup
eval {
my $q = "INSERT INTO $table (" . join(',',@db_fields) . ") VALUES(NULL" . ',?' x (scalar(@db_fields)-1) . ')';
- #$sth = $dbh->prepare("INSERT INTO $table VALUES(NULL,?,?,?,?,?,?,?,?,?,?,?,?)");
+#$sth = $dbh->prepare("INSERT INTO $table VALUES(NULL,?,?,?,?,?,?,?,?,?,?,?,?)");
$sth = $dbh->prepare($q);
-};
+ };
if ($EVAL_ERROR) {
die "Error while preparing sql statement: $EVAL_ERROR";
}
my @log_entry = parse($line);
eval { # we catch db errors to avoid crashing squid in case something goes wrong...
$sth->execute(@log_entry) or die $sth->errstr
- };
+ };
if ( $EVAL_ERROR ) { # leave a trace of the error in the logs
warn $EVAL_ERROR . " values=(" . join(', ', @log_entry) . ')';
}
my @responseErrors = ();
while($readlen < $bodylen) {
- my $t = <>;
+ my $t = <>;
if (defined $t) {
$body = $body . $t;
$readlen = length($body);
print(STDERR logPrefix()."\tFOUND cert ".$key.": ".$certs{$key}->subject() . "\n") if ($debug);
}
- #got the peer certificate ID. Assume that the peer certificate is the first one.
+#got the peer certificate ID. Assume that the peer certificate is the first one.
my $peerCertId = (keys %certs)[0];
- # Echo back the errors: fill the responseErrors array with the errors we read.
+ # Echo back the errors: fill the responseErrors array with the errors we read.
foreach my $err (keys %errors) {
$haserror = 1;
- appendError (\@responseErrors,
- $errors{$err}{"name"}, #The error name
- "Checked by Cert Validator", # An error reason
- $errors{$err}{"cert"} # The cert ID. We are always filling with the peer certificate.
+ appendError (\@responseErrors,
+ $errors{$err}{"name"}, #The error name
+ "Checked by Cert Validator", # An error reason
+ $errors{$err}{"cert"} # The cert ID. We are always filling with the peer certificate.
);
}
sub logPrefix
{
- return strftime("%Y/%m/%d %H:%M:%S.0", localtime)." ".$0." ".$$." | " ;
+ return strftime("%Y/%m/%d %H:%M:%S.0", localtime)." ".$0." ".$$." | " ;
}
Column 1: Regular expression to match against the URL
Column 2: Rewrite rule to generate a Store-ID
Eg:
-^http:\/\/[^\.]+\.dl\.sourceforge\.net\/(.*) http://dl.sourceforge.net.squid.internal/$1
+^http:\/\/[^\.]+\.dl\.sourceforge\.net\/(.*) http://dl.sourceforge.net.squid.internal/$1
Rewrite rules are matched in the same order as they appear in the rules file.
So for best performance, sort it in order of frequency of occurrence.
# read config file
open RULES, $ARGV[0] or die "Error opening $ARGV[0]: $!";
while (<RULES>) {
- chomp;
- next if /^\s*#?$/;
- if (/^\s*([^\t]+?)\s*\t+\s*([^\t]+?)\s*$/) {
- push(@rules, [qr/$1/, $2]);
- } else {
- print STDERR "$0: Parse error in $ARGV[0] (line $.)\n";
- }
+ chomp;
+ next if /^\s*#?$/;
+ if (/^\s*([^\t]+?)\s*\t+\s*([^\t]+?)\s*$/) {
+ push(@rules, [qr/$1/, $2]);
+ } else {
+ print STDERR "$0: Parse error in $ARGV[0] (line $.)\n";
+ }
}
close RULES;
$|=1;
# read urls from squid and do the replacement
URL: while (<STDIN>) {
- chomp;
- last if $_ eq 'quit';
-
- my $channel = "";
- if (s/^(\d+\s+)//o) {
- $channel = $1;
- }
-
- foreach my $rule (@rules) {
- if (my @match = /$rule->[0]/) {
- $_ = $rule->[1];
-
- for (my $i=1; $i<=scalar(@match); $i++) {
- s/\$$i/$match[$i-1]/g;
- }
- print $channel, "OK store-id=$_\n";
- next URL;
- }
- }
- print $channel, "ERR\n";
+ chomp;
+ last if $_ eq 'quit';
+
+ my $channel = "";
+ if (s/^(\d+\s+)//o) {
+ $channel = $1;
+ }
+
+ foreach my $rule (@rules) {
+ if (my @match = /$rule->[0]/) {
+ $_ = $rule->[1];
+
+ for (my $i=1; $i<=scalar(@match); $i++) {
+ s/\$$i/$match[$i-1]/g;
+ }
+ print $channel, "OK store-id=$_\n";
+ next URL;
+ }
+ }
+ print $channel, "ERR\n";
}
my $url = shift;
my $server = shift;
my %opcodes = (
- NOP => 0,
- TST => 1,
- MON => 2,
- SET => 3,
- CLR => 4,
-);
+ NOP => 0,
+ TST => 1,
+ MON => 2,
+ SET => 3,
+ CLR => 4,
+ );
print "sending $op $url to $server\n";
my $htcp = packet($data, $auth);
my $sock = IO::Socket::INET->new(PeerAddr => $server,
- PeerPort => 4827,
- Proto => 'udp');
+ PeerPort => 4827,
+ Proto => 'udp');
die "$server: $!" unless $sock;
exit 0;
sub packet {
- my $data = shift;
- my $auth = shift;
- my $hdr = header(length($data) + length($auth));
- printf STDERR "hdr is %d bytes\n", length($hdr);
- printf STDERR "data is %d bytes\n", length($data);
- printf STDERR "auth is %d bytes\n", length($auth);
- $hdr . $data . $auth;
+ my $data = shift;
+ my $auth = shift;
+ my $hdr = header(length($data) + length($auth));
+ printf STDERR "hdr is %d bytes\n", length($hdr);
+ printf STDERR "data is %d bytes\n", length($data);
+ printf STDERR "auth is %d bytes\n", length($auth);
+ $hdr . $data . $auth;
}
sub header {
- my $length = 4 + shift;
- my $major = 0;
- my $minor = 0;
- my $buf;
- pack('nCC', $length, $major, $minor);
+ my $length = 4 + shift;
+ my $major = 0;
+ my $minor = 0;
+ my $buf;
+ pack('nCC', $length, $major, $minor);
}
sub data {
- my $op_data = shift;
- my $opcode = shift;
- my $response = shift;
- my $reserved = 0;
- my $f1 = shift;
- my $rr = shift;
- my $trans_id = shift;
- printf STDERR "op_data is %d bytes\n", length($op_data);
- printf STDERR "response is %d\n", $response;
- printf STDERR "F1 is %d\n", $f1;
- printf STDERR "RR is %d\n", $rr;
- my $length = 8 + length($op_data);
- my $x1 = ($opcode & 0xF) | (($response & 0xF) << 4);
- #my $x2 = ($rr & 0x1) | (($f1 & 0x1) << 1) | (($reserved & 0x3F) << 2);
- my $x2 = ($reserved & 0x3F) | (($f1 & 0x1) << 6) | (($rr & 0x1) << 7);
- pack('nCCNa*', $length, $x1, $x2, $trans_id, $op_data);
+ my $op_data = shift;
+ my $opcode = shift;
+ my $response = shift;
+ my $reserved = 0;
+ my $f1 = shift;
+ my $rr = shift;
+ my $trans_id = shift;
+ printf STDERR "op_data is %d bytes\n", length($op_data);
+ printf STDERR "response is %d\n", $response;
+ printf STDERR "F1 is %d\n", $f1;
+ printf STDERR "RR is %d\n", $rr;
+ my $length = 8 + length($op_data);
+ my $x1 = ($opcode & 0xF) | (($response & 0xF) << 4);
+ #my $x2 = ($rr & 0x1) | (($f1 & 0x1) << 1) | (($reserved & 0x3F) << 2);
+ my $x2 = ($reserved & 0x3F) | (($f1 & 0x1) << 6) | (($rr & 0x1) << 7);
+ pack('nCCNa*', $length, $x1, $x2, $trans_id, $op_data);
}
sub auth {
- pack('n', 2);
+ pack('n', 2);
}
sub countstr {
- my $str = shift;
- pack('na*', length($str), $str);
+ my $str = shift;
+ pack('na*', length($str), $str);
}
sub specifier {
- my $method = countstr(shift);
- my $uri = countstr(shift);
- my $version = countstr(shift);
- my $req_hdrs = countstr(shift);
- $method . $uri . $version . $req_hdrs;
+ my $method = countstr(shift);
+ my $uri = countstr(shift);
+ my $version = countstr(shift);
+ my $req_hdrs = countstr(shift);
+ $method . $uri . $version . $req_hdrs;
}
sub clr {
- my $reason = shift;
- my $reserved = 0;
- my $specifier = shift;
- printf STDERR "CLR specifier is %d bytes\n", length($specifier);
- my $x1 = ($reason & 0xF) | (($reserved & 0x7F) << 4);
- pack('na*', $x1, $specifier);
+ my $reason = shift;
+ my $reserved = 0;
+ my $specifier = shift;
+ printf STDERR "CLR specifier is %d bytes\n", length($specifier);
+ my $x1 = ($reason & 0xF) | (($reserved & 0x7F) << 4);
+ pack('na*', $x1, $specifier);
}
sub tst {
- my $specifier = shift;
- printf STDERR "TST specifier is %d bytes\n", length($specifier);
- pack('a*', $specifier);
+ my $specifier = shift;
+ printf STDERR "TST specifier is %d bytes\n", length($specifier);
+ pack('a*', $specifier);
}
sub op_data {
- my $op = shift;
- my $url = shift;
- if ($op eq 'CLR') {
- return clr(1, specifier('GET', $url, 'HTTP/1.1', "Accept: */*\r\n"));
- } elsif ($op eq 'TST') {
- return tst(specifier('GET', $url, 'HTTP/1.1', "Accept: */*\r\n"));
- } else {
- print STDERR "unsupported HTCP opcode $op\n";
- exit 1;
- }
+ my $op = shift;
+ my $url = shift;
+ if ($op eq 'CLR') {
+ return clr(1, specifier('GET', $url, 'HTTP/1.1', "Accept: */*\r\n"));
+ } elsif ($op eq 'TST') {
+ return tst(specifier('GET', $url, 'HTTP/1.1', "Accept: */*\r\n"));
+ } else {
+ print STDERR "unsupported HTCP opcode $op\n";
+ exit 1;
+ }
}
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.
-
+
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
-
+
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111, USA.
$Getopt::Std::STANDARD_HELP_VERSION=1;
getopts('h', \%opts) or die ("unrecognized options");
if (defined $opts{h}) {
- HELP_MESSAGE();
- exit 0;
+ HELP_MESSAGE();
+ exit 0;
}
my $actual_helper_cmd=join(" ",@ARGV);
# main loop
$|=1;
while(1) {
- print STDERR "selecting\n";
- $nfound=select($rd=$rvec,undef,undef,undef);
- #$nfound=select($rd=$rvec,undef,$cl=$rvec,undef);
- print STDERR "nfound: $nfound\n";
- if ($nfound == -1 ) {
- print STDERR "error in select: $!\n";
- if ($!{ERESTART} || $!{EAGAIN} || $!{EINTR}) {
- next;
- }
- exit 1;
- }
- #print STDERR "cl: ", unpack("b*", $cl) ,"\n";
- print STDERR "rd: ", unpack("b*", $rd) ,"\n";
- # stdin is special
- #if (vec($cl,0,1)==1) { #stdin was closed
- # print STDERR "stdin closed\n";
- # exit(0);
- #}
- if (vec($rd,0,1)==1) { #got stuff from stdin
- #TODO: handle leftover buffers? I hope that 40kb are enough..
- $nread=sysread(STDIN,$_,40960); # read 40kb
- # clear the signal-bit, stdin is special
- vec($rd,0,1)=0;
- if ($nread==0) {
- print STDERR "nothing read from stdin\n";
- exit 0;
- }
- foreach $req (split("\n",$_ )) {
- dispatch_request($req);
- }
- }
- # find out if any filedesc was closed
- if ($cl != 0) {
- #TODO: better handle helper restart
- print STDERR "helper crash?";
- exit 1;
- }
- #TODO: is it possible to test the whole bitfield in one go?
- # != won't work.
- foreach $h (keys %helpers) {
- my %hlp=%{$helpers{$h}};
- #print STDERR "examining helper slot $h, fileno $hlp{fno}, filemask ", vec($rd,$hlp{fno},1) , "\n";
- if (vec($rd,$hlp{fno},1)==1) {
- #print STDERR "found\n";
- handle_helper_response($h);
- }
- #no need to clear, it will be reset when iterating
- }
+ print STDERR "selecting\n";
+ $nfound=select($rd=$rvec,undef,undef,undef);
+ #$nfound=select($rd=$rvec,undef,$cl=$rvec,undef);
+ print STDERR "nfound: $nfound\n";
+ if ($nfound == -1 ) {
+ print STDERR "error in select: $!\n";
+ if ($!{ERESTART} || $!{EAGAIN} || $!{EINTR}) {
+ next;
+ }
+ exit 1;
+ }
+ #print STDERR "cl: ", unpack("b*", $cl) ,"\n";
+ print STDERR "rd: ", unpack("b*", $rd) ,"\n";
+ # stdin is special
+ #if (vec($cl,0,1)==1) { #stdin was closed
+ # print STDERR "stdin closed\n";
+ # exit(0);
+ #}
+ if (vec($rd,0,1)==1) { #got stuff from stdin
+ #TODO: handle leftover buffers? I hope that 40kb are enough..
+ $nread=sysread(STDIN,$_,40960); # read 40kb
+ # clear the signal-bit, stdin is special
+ vec($rd,0,1)=0;
+ if ($nread==0) {
+ print STDERR "nothing read from stdin\n";
+ exit 0;
+ }
+ foreach $req (split("\n",$_ )) {
+ dispatch_request($req);
+ }
+ }
+ # find out if any filedesc was closed
+ if ($cl != 0) {
+ #TODO: better handle helper restart
+ print STDERR "helper crash?";
+ exit 1;
+ }
+ #TODO: is it possible to test the whole bitfield in one go?
+ # != won't work.
+ foreach $h (keys %helpers) {
+ my %hlp=%{$helpers{$h}};
+#print STDERR "examining helper slot $h, fileno $hlp{fno}, filemask ", vec($rd,$hlp{fno},1) , "\n";
+ if (vec($rd,$hlp{fno},1)==1) {
+ #print STDERR "found\n";
+ handle_helper_response($h);
+ }
+ #no need to clear, it will be reset when iterating
+ }
}
sub dispatch_request {
- my $line=$_[0];
- my %h;
-
- #print STDERR "dispatching request $_";
- $line =~ /^(\d+) (.*)$/;
- my $reqId=$1;
- my $req=$2;
-
- undef $h;
- # Find a free helper
- foreach $slot ( 1 .. ($helpers_running)) {
- if (!defined($helpers{$slot}->{lastcmd})) {
- $h = $helpers{$slot};
- last;
- }
- }
- # If none create one
- if (!defined($h)) {
- $helpers_running = $helpers_running + 1;
- $helpers{$helpers_running}=init_subprocess();
- $h = $helpers{$helpers_running};
- # print STDERR "Now $helpers_running helpers running\n";
- }
-
- $wh=$h->{wh};
- $rh=$h->{rh};
- $h->{lastcmd}=$req;
- $h->{reqId}=$reqId;
- print $wh "$req\n";
+ my $line=$_[0];
+ my %h;
+
+ #print STDERR "dispatching request $_";
+ $line =~ /^(\d+) (.*)$/;
+ my $reqId=$1;
+ my $req=$2;
+
+ undef $h;
+ # Find a free helper
+ foreach $slot ( 1 .. ($helpers_running)) {
+ if (!defined($helpers{$slot}->{lastcmd})) {
+ $h = $helpers{$slot};
+ last;
+ }
+ }
+ # If none create one
+ if (!defined($h)) {
+ $helpers_running = $helpers_running + 1;
+ $helpers{$helpers_running}=init_subprocess();
+ $h = $helpers{$helpers_running};
+ # print STDERR "Now $helpers_running helpers running\n";
+ }
+
+ $wh=$h->{wh};
+ $rh=$h->{rh};
+ $h->{lastcmd}=$req;
+ $h->{reqId}=$reqId;
+ print $wh "$req\n";
}
# gets in a slot number having got some response.
# reads the response from the helper and sends it back to squid
# prints the response back
sub handle_helper_response {
- my $h=$_[0];
- my ($nread,$resp);
- $nread=sysread($helpers{$h}->{rh},$resp,40960);
- #print STDERR "got $resp from slot $h\n";
- print $helpers{$h}->{reqId}, " ", $resp;
- delete $helpers{$h}->{lastcmd};
+ my $h=$_[0];
+ my ($nread,$resp);
+ $nread=sysread($helpers{$h}->{rh},$resp,40960);
+ #print STDERR "got $resp from slot $h\n";
+ print $helpers{$h}->{reqId}, " ", $resp;
+ delete $helpers{$h}->{lastcmd};
}
# a subprocess is a hash with members:
# lastcmd => the command "in flight"
# a ref to such a hash is returned by this call
sub init_subprocess {
- my %rv=();
- my ($rh,$wh,$pid);
- $pid=open2($rh,$wh,$actual_helper_cmd);
- if ($pid == 0) {
- die "Failed to fork helper process";
- }
- select($rh); $|=1;
- select($wh); $|=1;
- select(STDOUT);
- $rv{rh}=$rh;
- $rv{wh}=$wh;
- $rv{pid}=$pid;
- $rv{fno}=fileno($rh);
- print STDERR "fileno is $rv{fno}\n";
- vec($rvec,$rv{fno},1)=1;
- return \%rv;
+ my %rv=();
+ my ($rh,$wh,$pid);
+ $pid=open2($rh,$wh,$actual_helper_cmd);
+ if ($pid == 0) {
+ die "Failed to fork helper process";
+ }
+ select($rh); $|=1;
+ select($wh); $|=1;
+ select(STDOUT);
+ $rv{rh}=$rh;
+ $rv{wh}=$wh;
+ $rv{pid}=$pid;
+ $rv{fno}=fileno($rh);
+ print STDERR "fileno is $rv{fno}\n";
+ vec($rvec,$rv{fno},1)=1;
+ return \%rv;
}
sub HELP_MESSAGE {
- print STDERR <<EOF
+ print STDERR <<EOF
$0 options:
- -h this help message
+ -h this help message
arguments:
- the actual helper executable and its arguments.
- it's advisable to prefix it with "--" to avoid confusion
+ the actual helper executable and its arguments.
+ it's advisable to prefix it with "--" to avoid confusion
EOF
}
sub dump_state {
- $SIG{'HUP'}=\&dump_state;
- print STDERR "Helpers state:\n",Dumper(\%helpers),"\n";
+ $SIG{'HUP'}=\&dump_state;
+ print STDERR "Helpers state:\n",Dumper(\%helpers),"\n";
}
# finds and returns the slot number of a helper, -1 if not found
# args: - key in helpers
# - value to look for
sub find_helper_slot {
- my ($k,$v) = @_;
- foreach (keys %helpers) {
- return $_ if $helpers{$k}==$v;
- }
- return -1;
+ my ($k,$v) = @_;
+ foreach (keys %helpers) {
+ return $_ if $helpers{$k}==$v;
+ }
+ return -1;
}
sub reaper {
- my $child=wait;
- print STDERR "child $child died\n";
- $SIG{'CHLD'}=\&reaper;
- $slot = find_helper_slot('pid',$child);
- print STDERR "slot is $slot\n";
- #TODO: find the died child, if it was mid-process through a request
- # send a "BH" to squid and de-init its data-structs here
- exit 1;
+ my $child=wait;
+ print STDERR "child $child died\n";
+ $SIG{'CHLD'}=\&reaper;
+ $slot = find_helper_slot('pid',$child);
+ print STDERR "slot is $slot\n";
+ #TODO: find the died child, if it was mid-process through a request
+ # send a "BH" to squid and de-init its data-structs here
+ exit 1;
}
$|=1;
while (<>) {
- print "OK\n";
+ print "OK\n";
}
print STDERR "stdin closed, exit\n";
$|=1;
while (<>) {
- sleep 10;
- print "OK\n";
+ sleep 10;
+ print "OK\n";
}
print STDERR "stdin closed, exit\n";
projects / thirdparty / squid.git / commitdiff
