#! /usr/bin/perl -Tw-
#
# MeasureAll

# Author: Ton Hospel
# GNU License or Perl Artistic ( your choice)

BEGIN {
    $::lib = (substr($0, 0, 1) eq "/" ?
              $0 : do { require Cwd; Cwd::getcwd() . "/" . $0}) || "";
    die "Could not determine where the script is running ($::lib)" unless
        $::lib && -x $::lib;
    die "Could not parse program name $::lib" unless
        $::lib =~ s|/(?:\./)*[^/]+$||;
    die "Could not find library directory" unless $::lib =~ /(.*)\bbin$/;
    $::lib = "$1lib";
}

use lib $::lib;

# System modules
use strict;
use Getopt::Long;
use SNMP;
use Time::HiRes;
use Fcntl qw(:DEFAULT :flock);
use POSIX qw(errno_h);
use Socket;

# use Data::Dumper;
# $Data::Dumper::Indent = 1;

# My modules
use Hier qw(init tilde value opt_value last_line);
use Utils qw(df HostName SelfDocument alnum_sort);
use Device::AdminSet qw($NOVALUE);
use Ntp qw($ntp_offset ntp_props ntp_offset);
use Heap::Simple;

use constant	NORMAL_WEIGHT	=> 10;	# Weight of a normal job
use constant	DELAYED_WEIGHT	=> 1;	# Weight of a delayed job
use constant	GLOBAL_PENDING	=> 250*NORMAL_WEIGHT; # Max packets in flight
use constant    LOCAL_PENDING	=>   6*NORMAL_WEIGHT; # Max packets per device
use constant	ABORT		=> 275;	# Abort device if not finished by then
use constant	PING_SPREAD	=> 80;	# Number of seconds over which the pings will be started
use constant	WIDTH		=> 14;	# Number of simultanous questions
use constant	TIMEOUT		=> 12.0;# Max roundtrip for query/reply
use constant	RETRIES		=> 3;	# Max retries
use constant	DECAY		=> 10;	# Ping measurement stiffness
use constant	STABLE		=> 1.25;# Max factor pings may change
use constant	LITTLE		=> 5;	# Scale in ms. Ignore smallish jumps
use constant	FUDGE		=> 1.01;# how stable a jump must get
use constant	MAX_JUMP	=> 1.5; # Maximum jump factor

use constant	SOLARIS_FD_SKIP	=> 100; # See comment near usage

use constant	DONE		=> "Done\n";
use constant	THE_END		=> "the end\n";

package Job;
use fields qw(Uid Abort Id Ip Snmp Ok Serial SerialFrom Gets Sets Vars Pending Busy Status);

package Object;
use fields qw(Id Type Oid Long Fun);

package main;
use IO::Handle;
BEGIN {
    $::ilib = $::lib;
    $::ilib =~ s/lib$/.inline/;
}
use Inline C => 'DATA', UNTAINT => 1, DIRECTORY => $::ilib;

my $file_proto	 = 2;
my $sender_proto = 2;
my $class = "snmp";

my $rand = 0;
my (@do, %do);
@do{@do}=();

$::prog = "MeasureAll";
$::Base = $::lib;
$::Base =~ s/lib$/conf\/$::prog/;
$::restricted = 0;

&Getopt::Long::config("bundling", "require_order");

my $tai_offset = 32;
my (@todo, @sess, $tpos, $pending, $boring, $beat, $start, %ping_offset);
my ($start_time, $in, $pout, $lin, %objects, %ip2str, %ping2object);
my (@cisco_list, $unsafe, $help, $version, %pings, $send);
my ($keep, $measure, $file_mode, %ip_seen, $host, $verbose, $delay_min);

die "Could not parse your command line" unless
    GetOptions("file=s"	=> \$::Base,
               "F=s"	=> \$::Base,
               "restricted!"=> \$::restricted,
               "r"	=> \$::restricted,
               "unsafe!"	=> \$unsafe,
               "U"		=> \$unsafe,
               "help!"		=> \$help,
               "h"		=> \$help,
               "version!"	=> \$version,
               "verbose!"	=> \$verbose,
               "v"		=> \$verbose);
if ($version) {
    print<<"EOF";
MeasureAll (Ton utils) 0.00
EOF
    exit 0;
}

my $delayed = Heap::Simple->new(elements => ["Array"]);

sub process {
    my ($file) = @_;

    init($::prog, $file);
    SelfDocument($unsafe) if $help;

    $send	= opt_value("Send",	1);
    $keep	= opt_value("Keep",	0);
    $measure	= opt_value("Measure",	1);
    $file_mode	= opt_value("SafeMode", 0600);
    $host = HostName() unless defined($host = opt_value("HostName"));
    $host =~ /^([a-zA-z][a-zA-Z0-9-]*(?:\.[a-zA-Z0-9-]+)*)\z/ or
        die "Invalid character in host name $host";
    $host = $1;
    eval {
        my $ntp_props = ntp_props(tilde(opt_value("Ntpq", "ntpq")));
        ntp_offset($ntp_props);
    };
    if ($@) {
        print STDERR "Cannot determine ntp offset: $@";
        $ntp_offset = "0E0";	# Special perl zero value
    }

    my $dir = tilde(value("ResultDir"));
    $dir =~ s|/*\z|/|g; # */
    chdir($dir) || die "Could not change directory to $dir: $!";

    # The measure lock is also the ticket lock
    my $mfh = get_lock(tilde(opt_value("MeasureLock", "measure.lock")));
    sendout($mfh) if $send;
    # The measurements should not fail, even if writing to $pout does
    $SIG{PIPE}='IGNORE';

    my $counter = sender();
    if ($measure) {
        print $in "v$file_proto\n";

        print $in "prober=$host/$class\n";
        print $in "counter=$counter\n";
        print $in "time_type=UT\n";
        print $in "legal_offset=", -$tai_offset, "\n";
        print $in "time_offset=$ntp_offset\n";
        $pending = 0;
        setup();

        # Debug the streaming
        #my $fh = select($in);
        #{
        #    local $| = 1;
        #    print $in "";
        #}
        #select($fh);
        #print STDERR "PreSleep\n";
        #sleep 60;
        #print STDERR "PostSleep\n";

        $start_time = Time::HiRes::time;
        print $in "start_time=", $start_time+$tai_offset, "\n";
        print $in "results(packed)=\n";
        startup();
        eval {
            $beat = 0;
            $start = 0;
            # print STDERR "Entering Mainloop at ", scalar localtime, "\n";
            &SNMP::MainLoop(5, \&heart_beat);
            die "Leaving Mainloop. Huh ?\n";
        };
        print STDERR "$@" if $@ ne "\n";
        # print STDERR "Escape from Mainloop at ", scalar localtime, "\n";

        # Flush so we can push a perl-level print
        buffer_flush($in);
        print $in "\0\n";
        print $in THE_END;
        close($in) || die "Error closing $0 resultfile: $!";
    }
    # Close MeasureLock
    truncate($mfh, 0);
    close $mfh;

    if ($send) {
        # Tell downstream process we are done
        print $pout DONE;
        close $pout;
    }

    check_pings() if $measure;

    if ($send) {
        # Wait for all processes to finish
        my $last = <$lin>;
    }
}

sub ping_log($$$$$$$) {
    my ($rfh, $line, $min, $hour, $mday, $mon, $year) = @_;
    unless ($$rfh) {
        return unless defined(my $ping_log = opt_value("PingLog"));
        $ping_log = tilde($ping_log);
        unless (open($$rfh, ">>", $ping_log)) {
            print STDERR "Could not open $ping_log for append: $!";
            return;
        }
        my $old = select($$rfh);
        $| = 1;
        select($old);
    }
    printf {$$rfh} ("%04d/%02d/%02d %02d:%02d UT: %s",
                    $year+1900, $mon+1, $mday, $hour, $min, $line);
}

sub check_pings {
    eval {
        my $pfh = get_lock(tilde(opt_value("PingLock", "ping.lock")));
        my $file = opt_value("PingState", "ping.state");
        my %state;
        if (open(my $fh, "<", $file)) {
            local $_;
            while (<$fh>) {
                s/#.*//;
                if (my ($from, $to, $size, @data) =
                    /^\s*(\S+)\s+(\S+)\s+(\d+)\s+(\d+(?:\.\d*)?)\s+(\d+(?:\.\d*)?)\s+(\d+(?:\.\d*)?)\s+(\d+(?:\.\d*)?)\s*$/) {
                    $state{$from}{$to}{$size} = \@data;
                } elsif (/\S/) {
                    die "Could not parse line $. of $file: $_";
                }
            }
        } elsif ($! != ENOENT) {
            die "Could not open ping file $file: $!";
        }
        my ($min, $hour, $mday, $mon, $year) = (gmtime)[1, 2, 3, 4, 5];
        my $fh;
        while (my ($from, $udata) = each %pings) {
            while (my ($to, $data) = each %$udata) {
                # $data = [time, size, sent, received, min, avg, max]
                # print STDERR "$from -> $to: $data->[5] ms\n";
                if (defined(my $old = $state{$from}{$to}{$data->[1]})) {
                    # $old = [last, best, typical, current]
                    $old->[0] = $data->[0];
                    if ($data->[2] == $data->[3] && $data->[3]) {
                        # min/cur/avg only seem right if sent == received
                        if (defined($data->[4])) {
                            # print STDERR "$from -> $to old=[@$old], data=[@$data]\n";
                            $old->[1] = $data->[4] if $data->[4] < $old->[1];
                            # No super big jumps
                            if ($data->[5] > MAX_JUMP * $old->[3]) {
                                $data->[5] = $old->[3] * MAX_JUMP;
                            } elsif ($data->[5]*MAX_JUMP < $old->[3]) {
                                $data->[5] = $old->[3] / MAX_JUMP;
                            }
                            my $previous = $old->[3];
                            $old->[3] = ((DECAY-1)*$previous+$data->[5])/DECAY;
                            if ($old->[3]+LITTLE > ($old->[2]+LITTLE)* STABLE &&
                                $old->[3] <= $previous*FUDGE ||
                                ($old->[3]+LITTLE) * STABLE < $old->[2]+LITTLE &&
                                $old->[3] >= $previous/FUDGE) {
                                my $line = sprintf("Typical Ping delay from %s to %s changed from %.1f ms to %.1f ms\n", $from, $to, $old->[2], $old->[3]);
                                print STDERR $line;
                                ping_log(\$fh, $line,
                                         $min, $hour, $mday, $mon, $year);
                                $old->[2] = $old->[3];
                            }
                        } else {
                            print STDERR "$from -> $to has received packets, but not min/avg/max result\n";
                        }
                    }
                    $state{$from}{$to}{$data->[1]} = $old;
                } elsif (defined($data->[5])) {
                    $state{$from}{$to}{$data->[1]} =
                        [$data->[0], $data->[5],$data->[5],$data->[5]];
                }
            }
        }
        my $new = "$file.new.$$";
        open(my $wfh, ">", $new) || die "Could not create $new: $!";
        eval {
            print $wfh "# From\t\tTo\t\tSize\t\tLast\tBest\ttypical\tcurrent\n";
            for my $from (alnum_sort(keys %state)) {
                my $fstate = $state{$from};
                for my $to (alnum_sort(keys %{$fstate})) {
                    my $tfstate = $fstate->{$to};
                    for my $size (sort {$a <=> $b } keys %{$tfstate}) {
                        printf $wfh ("%-15s %-15s %-7s %-17s %-7s %-7s %s\n", $from, $to, $size, @{$tfstate->{$size}});
                    }
                }
            }
            print $wfh "# ", THE_END;
            close $wfh;
            my $last = last_line($new);
            $last eq "# " . THE_END ||
                die "Unexpected last line in $new. Disk full ? ($last)";
            rename($new, $file) || die "Could not rename $new to $file: $!";
        };
        if ($@) {
            unlink($new) ||
                die "Could not unlink $new: $!. The reason I wanted to: $@";
            die $@;
        }
        truncate($pfh, 0);
        close $pfh;
    };
    print STDERR $@ if $@;
}

sub setup_variables {
    # Order matters a bit. Currently the requests are processed back to front,
    # so put important things last, so that if a measurement is broken off,
    # these have the highest chance of already having been done.
    my @rfc_list = qw (ifStackStatus
                       ifStackLastChange
                       sysDescr
                       sysName
                       sysObjectID
                       ipAdEntIfIndex
                       ipAdEntNetMask
                       ipAdEntBcastAddr
                       ifNumber
                       ifIndex
                       ifDescr
                       ifType
                       ifSpeed
                       ifHighSpeed
                       ifOperStatus
                       ifOutUcastPkts
                       ifAdminStatus
                       ifOutDiscards
                       ifInDiscards
                       ifAlias
                       ifInOctets
                       ifOutOctets
                       sysUpTime
                       );
                       # ifLastChange
    		       # ifPhysAddress
                       # ifOutNUcastPkts
                       # ifMtu
                       # ipNetToMediaIfIndex
                       # ifOutQLen
                       # ifSpecific
                       # ifPromiscuousMode
                       # ipInReceives
                       # ifInUcastPkts
                       # ifInNUcastPkts
                       # ifInUnknownProtos
                       # ifInErrors
                       # ifOutErrors
    push(@rfc_list, qw(bgpLocalAs)) unless $::restricted;

    @cisco_list = ();
    push(@cisco_list, qw(ciscoEnvMonTemperatureStatusValue
                         ciscoEnvMonTemperatureThreshold
                         avgBusy1
                         avgBusy5
                         busyPer
                         freeMem
                         nvRAMSize
                         nvRAMUsed
                         processorRam
                         sysUpTimeAtLastChassisChange
                         locIfDescr
                         locIfInBitsSec
                         locIfOutBitsSec
                         locIfInputQueueDrops
                         locIfOutputQueueDrops
                         locIfInPktsSec
                         locIfOutPktsSec)) unless $::restricted;

    my @ping_list = qw(ciscoPingProtocol ciscoPingPacketCount
                       ciscoPingPacketSize ciscoPingPacketTimeout
                       ciscoPingDelay ciscoPingAddress
                       ciscoPingSentPackets ciscoPingReceivedPackets
                       ciscoPingMinRtt ciscoPingAvgRtt ciscoPingMaxRtt
                       ciscoPingEntryStatus ciscoPingEntryOwner
                       ciscoPingCompleted);

    my @address_ping_list = qw
        (addressCiscoPingSentPackets addressCiscoPingReceivedPackets
         addressCiscoPingMinRtt addressCiscoPingAvgRtt
         addressCiscoPingMaxRtt addressCiscoPingPacketCount
         addressCiscoPingPacketTimeout addressCiscoPingDelay
         addressCiscoPingProtocol);
    # 0: Start time
    # 1: next expire
    # 2: completed
    my $i=3;
    for (@ping_list) {
        $ping_offset{$_} = $i++;
    }
    # Basic sanity check for existence (and expand full name as we are busy)
    my $objectnr = 0;
    print $in "oids(list)=\n";
    for (@rfc_list, @cisco_list, @ping_list, @address_ping_list) {
        my @split;

        die "duplicate setup of $_" if defined($objects{$_});
        my Object $object = $objects{$_} = bless [$_], "Object";
        my $mib  = $SNMP::MIB{$_}	or die "Could not find mib for $_";
        my $type = $object->{Type} = $mib->{"type"} or
            die "Could not find type for $_";
        $object->{Fun} = \&add_device if $_ eq "sysObjectID";

        unless (/^ciscoPing/) {
            if ($type eq "INTEGER") {
                print $in "I$_\n"; # Integer
            } elsif ($type eq "IPADDR") {
                print $in "A$_\n"; # Address
            } elsif ($type eq "OBJECTID") {
                print $in "O$_\n"; # ObjectId
            } elsif ($type eq "TICKS" ||
                     $type eq "GAUGE" ||
                     $type eq "COUNTER" ||
                     $type eq "UINTEGER") {
                print $in "U$_\n"; # Unsigned
            } elsif ($type eq "OCTETSTR") {
                print $in "S$_\n"; # String
            } else {
                die "Unknown type $type. Don't know how to encode it";
            }
            $object->{"Id"}   = pack("w", ++$objectnr);
        }

        my $oid  = $mib->{"objectID"} or die "Could not find oid for $_";
        $oid =~ /^(?:\.\d+)+$/ or die "Tag $_ has an invalid oid: $oid";
        my $sanity = &SNMP::translateObj($oid);
        die "Forward($_) and backward translation($sanity) do not match" unless
            $_ eq $sanity;

        # print "$_ -> $oid\n";
        $object->{"Oid"}  = $oid;
        $object->{"Long"} = &SNMP::translateObj($oid, 1);

        $_ = $object;
    }
    print $in "\n";
    return \@rfc_list;
}

sub add_device {
    (my Job $work, my ($tag, $iid, $type)) = @_;
    # print STDERR "$tag, $iid, $type\n";

    unless ($type =~ /^\.1\.3\.6\.1\.4\.1\.(\d+)\.(.*)$/) {
        print STDERR "Unknown device OID $type\n";
        return;
    }
    $type = $1;
    my $sub_type = $2;
    my $more;
    if ($type == 2021) {
        # UCD snmp agent
        $more = [];
    } elsif ($type == 9) {
        # Cisco
        $more = \@cisco_list;
    } elsif ($type == 42) {
        # Sun
        $more = [];
    } elsif ($type == 166) {
        # Shiva
        $more = [];
    } elsif ($type == 1919) {
        $more = [];
    } else {
        print STDERR "Unknown enterprise $type\n";
        return;
    }
    push(@{$work->{"Vars"}}, @{$more});
    push(@{$work->{"Pending"}}, map { new SNMP::Varbind([$_->[0]]) } @{$more});
}

my $ping_count = 100;
my $ping_size  = 100;	# 36
my $ping_timeout = 1500;
my $ping_delay = 100;

my $ping_step = 4;

sub ping {
    my Job $job = shift;
    for my $ip (@_) {
        my $num = ++$job->{"Serial"};
        #ciscoPingEntryStatus
        push(@{$job->{"Sets"}}, [sub {
            my Job $work = shift;
            my ($send_time, $pends) = @_;
            my $num = $pends->[0][$SNMP::Varbind::iid_f];
            push(@{$work->{"Sets"}}, [sub {
                my Job $work = shift;
                my ($send_time, $pends) = @_;
                my $num = $pends->[0][$SNMP::Varbind::iid_f];
                # possibly measure octets here
                push(@{$work->{"Gets"}}, ["ciscoPingEntryStatus", $num]);
            },
                 ["ciscoPingEntryStatus", $num, 5, "INTEGER"],
                 ["ciscoPingEntryOwner", $num,
                  "MeasureAll\@$host", "OCTETSTR"],
                 ["ciscoPingProtocol", $num, 1,   "INTEGER"],
                 ["ciscoPingPacketCount", $num, $ping_count, "INTEGER"],
                 ["ciscoPingPacketSize", $num, $ping_size, "INTEGER"],
                 ["ciscoPingPacketTimeout",$num, $ping_timeout,"INTEGER"],
                 ["ciscoPingDelay",   $num, $ping_delay, "INTEGER"],
                 ["ciscoPingAddress", $num, pack("C*",split /\./, $ip), "OCTETSTR"]]);
        }, ["ciscoPingEntryStatus", $num, 6, "INTEGER"]]);
    }
}

sub hosts($$) {
    my ($device_set, $file) = @_;
    $file = tilde($file);
    local(*FILE, $_);
    local $/ = "\n";
    open(FILE, "<", $file) || die "Could not open $file: $!";
    my @result;
    while (<FILE>) {
        s/#.*//;
        if (my ($name) = /^\s*(\S+)\s*$/) {
            eval {
                my $device = $device_set->device($name) ||
                    die "Unknown host $name";
                push(@result, $name);
            };
            print STDERR "File $file line $.: $@" if $@;
        } else {
            die "File $file line $.: Invalid hostname $_";
        }
    }
    return @result;
}

sub setup_ping($$) {
    my ($device_set, $jobs) = @_;
    # my %hosts;
    my $devices = $device_set->devices;
    my $central = $device_set->central;
    my (@central, %paths);
    for my $uid (@{$device_set->alive}) {
        # print STDERR "Considering $uid\n";
        my $device = $devices->{$uid};
        my $comm = $device->Community;
        next if $comm eq "dummy";
        my $type = $device->Type;
        next if $type eq "External" || $type eq "Server";
        #my $dns = $device->Dns;
        #if ($dns ne $NOVALUE) {
        #    if ($dns =~ /^([\w-]+)/) {
        #        $hosts{uc($1)} = $uid;
        #    } else {
        #        print STDERR "Dns name $dns has invalid start\n";
        #    }
        #}
        next if $device->Cpe;
        if ($device->Centrals) {
            # We'll do these later
            push(@central, $uid);
            next;
        }
        for my $region ($device->AllRegions) {
            $paths{$uid}{$central->{$region}}++;
        }
    }
    for my $from (@central) {
        for my $to (@central) {
            $paths{$from}{$to}++;
        }
    }
    #my @pingers = hosts(\%hosts, value("Pingers"));
    #my @pingees = hosts(\%hosts, value("Pingees"));
    my @pingers = hosts($device_set, value("Pingers"));
    my @pingees = hosts($device_set, value("Pingees"));
    for my $from (@pingers) {
        for my $to (@pingees) {
            $paths{$from}{$to}++;
        }
    }
    my @plan;
    while ((my $from, my Job $job) = each %{$jobs}) {
        for my $to (keys %{$paths{$from} || {}}) {
            next if $from eq $to;
            if ($to =~ /^\d+\.\d+\.\d+\.\d+\z/) {
                # Can't yet happen in the current code
                push(@plan, [$job, $to]);
            } else {
                my Job $target = $jobs->{$to};
                unless ($target) {
                    print STDERR "Can't set up a ping from $from to unknown device $to\n";
                    next;
                }
                push(@plan, [$job, $target->{"Ip"}]);
            }
        }
    }

    return if !@plan;

    my $step = PING_SPREAD/@plan;
    print STDERR ("Abort ", ABORT, " < 10 + ping_spread (", PING_SPREAD, ")\n") if PING_SPREAD+10 > ABORT;
    my $from = time+5;
    # print STDERR ("Pushing pings since ", scalar gmtime($from), "\n");
    for (@plan) {
        my Job $job = $_->[0];
        $pending	+= DELAYED_WEIGHT;
        $job->{"Busy"}	+= DELAYED_WEIGHT;
        # print STDERR "setup_ping(): $job->{'Uid'} busy=$job->{'Busy'}, pending=$pending\n";
        #print STDERR "Delayed start planned for ", scalar gmtime($from), "\n";
        $delayed->insert([$from, $job, $_->[1]]);
        $from += $step;
    }
    $delay_min = $delayed->min_key;
}

sub setup() {
    $SNMP::use_long_names = 0;
    $SNMP::debugging = 0;
    $SNMP::dump_packet = 0;
    &SNMP::initMib();
    &SNMP::addMibDirs(map { tilde($_) } Hier::values("MibDir"));
    my @failed;
    for (qw(BGP4-MIB OLD-CISCO-INTERFACES-MIB OLD-CISCO-SYS-MIB CISCO-PING-MIB
            CISCO-ENVMON-MIB OLD-CISCO-CHASSIS-MIB CISCO-PRODUCTS-MIB
            INFONET-MIB)) {
        &SNMP::loadModules($_) or push(@failed, $_);
    }
    die "Could not find modules @failed" if @failed;

    my $vars = setup_variables();

    my $device_set = Device::AdminSet->new(safe => 0);
    my $devices = $device_set->devices;
    my @uids = @ARGV ? $device_set->uid_lookup(@ARGV) : @{$device_set->alive};

    my $devnr = 0;
    my %jobs;
    %ip_seen = ();
    print $in "targets(list)=\n";
    {
        my $fd = fileno($in);
        print STDERR "The first free filedescriptor is $fd, which gets too close to the solaris skip. The caller probably leaves garbage filedescriptors\n" if $fd + 10 > SOLARIS_FD_SKIP;
        my @handles;
        if ($^O eq "solaris") {
            # Terrible hack. Solaris 32-bit libc can only handle filehandles
            # with fileno up to 256. We'll need some of these later on, so we
            # try to push the snmp-sockets "high". But the first SNMP open
            # needs to open some files (like /etc/services, or loading a
            # shared library), so we can't push all the way.
            # Therefore just allocate "a bunch".
            # This hack depends critically on the way ucd-snmp does a
            # session_open internally, so it could in principle stop working
            # at any upgrade
            while (1) {
                open(my $fh, ">&$fd") || die "Could not dup $fd: $!";
                push(@handles, $fh);
                last if fileno($fh) >= SOLARIS_FD_SKIP;
            }
        }
        # Next two lines are a better way to calculate a serial (inc per 
        # device). Only activate after debugging the double ip ping problem
        # basically make the lower bits in time the major determinant
        # my $serial = unpack("N", pack("B32", "0" . reverse unpack("B32", pack("N", time-86145778))));
        for my $uid (@uids) {
            my $device	= $devices->{$uid};
            my $community	= $device->Community;
            # A way to get rid of weirdos
            next if $community eq "dummy";
            my $ip = $device->Ip;
            if ($ip_seen{$ip}) {
                print STDERR "Multiple devices with ip $ip, at least $uid and $ip_seen{$ip}\n";
                next;
            }
            $ip_seen{$ip} = $uid;

            print $in "$ip\n";
            my $sess = SNMP::Session->new
                (DestHost	=> $ip,
                 Community	=> $community,
                 RetryNoSuch => 1,
                 Retries	=> RETRIES,
                 Timeout	=> TIMEOUT * 1000000) or
                     die "Could not create SNMP::Session for $uid: $!";

            my Job $job = bless [], "Job";
            $jobs{$uid} = $job;
            push(@todo, $job);
            $job->{"Uid"}	= $uid; # The device unique id
            $job->{"Ip"}	= $ip;
            $job->{"Id"}	= pack("w", ++$devnr); # The device short string
            $job->{"Snmp"}	= $sess; # query object
            $job->{"Ok"}	= 1; # false means problems
            # basically make the lower bits in time the major determinant
            $job->{"Serial"} = unpack("N", pack("B32", "0" . reverse unpack("B32", pack("N", time-86145778))));
            $job->{"SerialFrom"} = $job->{"Serial"};
            $job->{"Gets"}	= [];
            $job->{"Sets"}	= [];
            # Work to be done (processed back to front)
            $job->{"Vars"}	= [@{$vars}];
            # Encoded form of work to be done (includes the iid
            # that's next, so it encodes more than just Vars !)
            $job->{"Pending"} = [map {new SNMP::Varbind([$_->[0]])} @{$vars}];
            $job->{"Busy"} = 0; # nr of requests in flight
        }
    }
    print $in "\n";
    $tpos = @todo-1;	# last @todo we considered

    setup_ping($device_set, \%jobs);

    # boring means: we haven't seen any replies for a bit of time
    $boring = 1;
}

sub startup() {
    # $pending = 0;
    my $abort = Time::HiRes::time+ABORT;
    for my Job $job (@todo) {
        $job->{"Abort"} = $abort;
        $delayed->insert([$abort, $job, "abort"]);
    }
    $delay_min = $delayed->min_key;

    for (my $i = $pending; $i < GLOBAL_PENDING; $i+=NORMAL_WEIGHT) {
        # print STDERR "starting up $i\n";
        activate();
    }
}

# Activate one pending job
sub activate() {
    # print STDERR "Activate (tpos=$tpos) @todo\n";
    for my $count (1..@todo) {
        last if $pending > @todo * LOCAL_PENDING || $pending > GLOBAL_PENDING;
        $tpos = 0 if ++$tpos >= @todo;
        # print STDERR "tpos is $tpos\n";
        my Job $todo = $todo[$tpos];
        next if $todo->{"Busy"} > LOCAL_PENDING;
        if ($todo->{"Ok"}) {
            if (@{$todo->{"Gets"}}) {
                my $len = @{$todo->{"Gets"}};
                $len = WIDTH if $len > WIDTH;
                my @gets = splice(@{$todo->{"Gets"}}, 0, $len);
                my $now = Time::HiRes::time;
                if ($now < $todo->{"Abort"}) {
                    $todo->{"Snmp"}->get
                        (\@gets, [\&get, $todo, $now]);
                    $pending	    += NORMAL_WEIGHT;
                    $todo->{"Busy"} += NORMAL_WEIGHT;
                    # print STDERR "activate(): $todo->{'Uid'} busy=$todo->{'Busy'}, pending=$pending\n";
                    heart_beat() if $delay_min && $now > $delay_min;
                    return;
                } else {
                    print STDERR "$todo->{'Uid'} ($todo->{'Ip'}) was taking too long and is being aborted\n";
                    $todo->{"Ok"} = 0;
                }
            } elsif (@{$todo->{"Sets"}}) {
                my $set = shift(@{$todo->{"Sets"}});
                my $fun = shift(@{$set});
                my $now = Time::HiRes::time;
                if ($now < $todo->{"Abort"}) {
                    $todo->{"Snmp"}->set
                        ($set, [\&set, $todo, $fun, $now]);
                    $pending	+= NORMAL_WEIGHT;
                    $todo->{"Busy"} += NORMAL_WEIGHT;
                    # print STDERR "activate(): $todo->{'Uid'} busy=$todo->{'Busy'}, pending=$pending\n";
                    heart_beat() if $delay_min && $now > $delay_min;
                    return;
                } else {
                    print STDERR "$todo->{'Uid'} ($todo->{'Ip'}) was taking too long and is being aborted\n";
                    $todo->{"Ok"} = 0;
                }
            } else {
                my $pends = $todo->{"Pending"};
                if (my $len = @{$pends}) {
                    $len = WIDTH if $len > WIDTH;
                    my @pends = splice(@{$pends}, -$len);
                    my @vars  = splice(@{$todo->{"Vars"}}, -$len);
                    # Work around a cisco bug where parallel getnexts on a
                    # same iid causes "sympathic skipping"
                    my ($iid, %seen);
                    for (my $i=0; $i < @pends; $i++) {
                        $iid = -1 unless
                            defined($iid=$pends[$i]->[$SNMP::Varbind::iid_f]);
                        if ($seen{$iid}) {
                            #print STDERR "Skipping parallel $iid\n";
                            push(@{$pends},          splice(@pends, $i, 1));
                            push(@{$todo->{"Vars"}}, splice(@vars,  $i, 1));
                            $i--;
                        } else {
                            #print STDERR "Keeping $iid\n";
                            $seen{$iid} = 1;
                        }
                    }
                    #print STDERR "-----\n";
                    # print STDERR "Sending out @vars\n";
                    # print STDERR Dumper(\@pends);
                    # Writing the next 2 lines as 2 instead of one
                    # subtly avoids a coredump on perl 5.004_04 --Ton
                    $pends = bless(\@pends, "SNMP::VarList");
                    my $now = Time::HiRes::time;
                    if ($now < $todo->{"Abort"}) {
                        $todo->{"Snmp"}->getnext
                            ($pends,[\&get_next, $todo, \@vars, $now]);
                        $pending	+= NORMAL_WEIGHT;
                        $todo->{"Busy"} += NORMAL_WEIGHT;
                        # print STDERR "activate(): $todo->{'Uid'} busy=$todo->{'Busy'}, pending=$pending\n";
                        heart_beat() if $delay_min && $now > $delay_min;
                        return;
                    } else {
                        print STDERR "$todo->{'Uid'} ($todo->{'Ip'}) was taking too long and is being aborted\n";
                        $todo->{"Ok"} = 0;
                    }
                }
            }
        }
        unless ($todo->{"Busy"}) {
            # This device is done
            # Maybe at some point clean up pending heap entries here
            # Clean up filedescriptor
            $todo->{"Snmp"} = undef;
            # remember finish. This is very inaccurate, only meant as a mark
            # 0x80 is used as a BER escape
            my $end_time = Time::HiRes::time;
            # Flush so we can push a perl-level print
            buffer_flush($in);
            print $in ("\x80", $todo->{"Id"}, "F", $todo->{"Ok"} ? 1 : 0,
                       pack("w", int(($end_time-$start_time)*1000+0.5)));
            splice(@todo, $tpos, 1);
            $tpos--;
            print STDERR "Finished with $todo->{'Uid'} (ok=$todo->{'Ok'})\n" if $verbose;
        }
    }
    heart_beat() if $delay_min && Time::HiRes::time > $delay_min;
    die "\n" unless $pending;
}

sub objid2str {
    $_[0] =~ /^\d+(?:\.\d+)*\z/ || die "$_[0] is not an oid";
    my $str = pack("w*", map { $_ * 2 } split(/\./, $_[0]));
    substr($str, -1, 1) |= "\x01";
    return $str;
}

# Notice that it's an irregular heartbeat !
sub heart_beat {
    $beat++;
    my $now = Time::HiRes::time;
    #print STDERR ("Heart_beat $beat ($start,$boring) at ",
    #              scalar gmtime($now), ", next action at ",
    #              scalar gmtime($delayed->min_key), "\n");
    if (my @work = $delayed->extract_upto($now)) {
        $boring = 0;
        my $count = 0;
        for (@work) {
            (undef, my Job $work, my $num) = @{$_};
            if ($num =~ /^\d+\z/) {
                # print DEBUG (scalar gmtime($now),
                #              ": Repushing $work->{Uid} $num\n");
                $work->{"Busy"} -= DELAYED_WEIGHT;
                $pending	-= DELAYED_WEIGHT;
                # print STDERR "heart_beat(): $work->{'Uid'} busy=$work->{'Busy'}, pending=$pending\n";
                $count++;
                push(@{$work->{"Gets"}},
                     ["ciscoPingSentPackets", $num],
                     ["ciscoPingCompleted", $num]);
            } elsif ($num =~ /^\d+\.\d+\.\d+\.\d+\z/) {
                $work->{"Busy"} -= DELAYED_WEIGHT;
                $pending	-= DELAYED_WEIGHT;
                # print STDERR "heart_beat(): $work->{'Uid'} busy=$work->{'Busy'}, pending=$pending\n";
                $count++;
                # print DEBUG (scalar gmtime($now),
                #              ": starting ping from $work->{Uid} to $num\n");
                ping($work, $num);
            } elsif ($num eq "abort") {
                if ($work->{"Ok"} && $work->{"Snmp"}) {
                    print STDERR "$work->{'Uid'} ($work->{'Ip'}) was taking too long and is being aborted\n";
                    $work->{"Ok"} = 0;
                }
            } else {
                die "Unexpected num $num in heart_beat";
            }
        }
        activate() for $count;
        activate();
        return;
    }
    return if $delay_min = $delayed->min_key;

    $boring++;
    if ($boring <= 1) {
        # First heartbeat since the last get_next
        $boring = 1;
        $start = 0;
        return;
    }
    if ($start == 0) {
        # Second heartbeat since the last get_next
        $start = $now;
        return;
    }
    # Third or higher heartbeat since the last get_next
    # By this point we have compenstated for the irregularity of the  heartbeat
    # We didn't get any replies since at least $diff seconds
    my $diff = $now - $start;
    # After this amount of time at least one pending should have timed out
    die "Global timeout $diff, pending is $pending\n" if
        $diff > (TIMEOUT*1.2+2)*RETRIES;
}

sub get_next {
    my Job $work = shift;
    my ($vars, $send_time, $pends) = @_;

    $pending -= NORMAL_WEIGHT;
    $work->{"Busy"} -= NORMAL_WEIGHT;
    # print STDERR "get_next(): $work->{'Uid'} busy=$work->{'Busy'}, pending=$pending\n";
    $boring = 0;
    # print STDERR "Received @{$vars}\n";
    if ($work->{"Ok"}) {
        if (defined($pends) && !$work->{"Snmp"}{ErrorNum}) {
            process_results($in, $work, $vars, $start_time,
                            $pends, $send_time);
        } else {
            # Error, probably timeout
            my $sess = $work->{"Snmp"};
            print STDERR "SNMP get_next on $work->{Uid} ($sess->{DestHost}): ";
            if ($sess->{ErrorNum}) {
                print STDERR $sess->{ErrorStr};
            } else {
                print STDERR "timed out";
            }
            print STDERR " on ", join(", ", map $_->[0], @{$vars}), "\n";
            $work->{"Ok"} = 0;
        }
    }
    my $p = $pending;
    activate();
    # Get one more job going (until max is reached)
    activate() if $p != $pending && $pending < GLOBAL_PENDING;
}

sub set {
    my Job $work = shift;
    my ($fun, $send_time, $pends) = @_;

    $pending	    -= NORMAL_WEIGHT;
    $work->{"Busy"} -= NORMAL_WEIGHT;
    # print STDERR "set(): $work->{'Uid'} busy=$work->{'Busy'}, pending=$pending\n";
    $boring = 0;
    # print STDERR "Received @{$vars}\n";
    if ($work->{"Ok"}) {
        if (defined($pends) && !$work->{"Snmp"}{ErrorNum}) {
            $fun->($work, $send_time, $pends);
        } else {
            # Error, probably timeout
            my $sess = $work->{"Snmp"};
            print STDERR "SNMP set $work->{Uid} ($sess->{DestHost}): ";
            if ($sess->{ErrorNum}) {
                print STDERR "$sess->{ErrorStr}";
            } else {
                print STDERR "timed out";
                $work->{"Ok"} = 0;
            }
            if ($pends) {
                print STDERR " on ", join(", ", map { "$_->[$SNMP::Varbind::tag_f].$_->[$SNMP::Varbind::iid_f]=$_->[$SNMP::Varbind::val_f]($_->[$SNMP::Varbind::type_f])"} @{$pends});
            }
            print STDERR "\n";
            # A common reason is no set abilities. Maybe not drop ok ?
            # $work->{"Ok"} = 0;
        }
    }
    my $p = $pending;
    activate();
    # Get one more job going (until max is reached)
    activate() if $p != $pending && $pending < GLOBAL_PENDING;
}

sub ping2object {
    my $name = "address" . ucfirst(shift);
    return $objects{$name} || die "Could not find object $name";
}

sub get {
    my Job $work = shift;
    my ($send_time, $pends) = @_;

    $pending	    -= NORMAL_WEIGHT;
    $work->{"Busy"} -= NORMAL_WEIGHT;
    # print STDERR "get(): $work->{'Uid'} busy=$work->{'Busy'}, pending=$pending\n";
    $boring = 0;
    if ($work->{"Ok"}) {
        if (defined($pends) && !$work->{"Snmp"}{ErrorNum}) {
            for (@{$pends}) {
                if ($_->[$SNMP::Varbind::tag_f] eq "ciscoPingEntryStatus") {
                    if ($_->[$SNMP::Varbind::val_f] == 2) {
                        my $num = $_->[$SNMP::Varbind::iid_f];
                        # possibly measure octets here
                        push(@{$work->{"Sets"}}, [sub {
                            my Job $work = shift;
                            my ($send_time, $pends) = @_;
                            my $num = $pends->[0][$SNMP::Varbind::iid_f];
                            $work->{"Status"}{$num}[0] = $send_time;
                            # print DEBUG "$work->{Uid} $num: first status check after ping start\n";
                            push(@{$work->{"Gets"}},
                                 ["ciscoPingSentPackets", $num],
                                 ["ciscoPingCompleted", $num]);
                        }, ["ciscoPingEntryStatus", $num, 1, "INTEGER"]]);
                    } else {
                        print STDERR "$work->{Uid}: Could not prepare cisco ping (returned status $_->[$SNMP::Varbind::val_f])";
                    }
                } elsif ($_->[$SNMP::Varbind::tag_f] eq "ciscoPingSentPackets") {
                    $work->{"Status"}{$_->[$SNMP::Varbind::iid_f]}[$ping_offset{ciscoPingSentPackets}] = $_->[$SNMP::Varbind::val_f];
                    if ($_->[$SNMP::Varbind::val_f] > 5) {
                        if (!defined($work->{"Status"}{$_->[$SNMP::Varbind::iid_f]}[0])) {
                            # Trying to debug how this can happen...
                            print STDERR "$work->{'Uid'}: BAAAAAD: \$_->[\$SNMP::Varbind::val_f]=$_->[$SNMP::Varbind::val_f], \$work->{'Status'}{\$_->[\$SNMP::Varbind::iid_f]}[0]=undef (iid=$_->[$SNMP::Varbind::iid_f] serial_from=$work->{'SerialFrom'} serial=$work->{'Serial'}\n"
                        }
                        my $step = (1+$ping_count-$_->[$SNMP::Varbind::val_f])*
                            ($send_time-$work->{"Status"}{$_->[$SNMP::Varbind::iid_f]}[0])/$_->[$SNMP::Varbind::val_f];
                        $step /= 2 if
                            $_->[$SNMP::Varbind::val_f]*2 < $ping_count;
                        $step = 2  if $step < 2;
                        $step = 30 if $step > 30;
                        $work->{"Status"}{$_->[$SNMP::Varbind::iid_f]}[1] =
                            $send_time+$step;
                    } else {
                        $work->{"Status"}{$_->[$SNMP::Varbind::iid_f]}[1] =
                            $send_time+$ping_step;
                    }
                    # print DEBUG (scalar gmtime,
                    #              ": Ping $work->{Uid} $_->[$SNMP::Varbind::iid_f] is at $_->[$SNMP::Varbind::val_f] packets\n");
                } elsif ($_->[$SNMP::Varbind::tag_f] eq "ciscoPingCompleted") {
                    if ($_->[$SNMP::Varbind::val_f] == 1) {
                        # Completed
                        my $num = $_->[$SNMP::Varbind::iid_f];
                        $work->{"Status"}{$num}[2] = Time::HiRes::time;
                        # print DEBUG "Ping $work->{Uid} $num done. Rechecking props\n";
                        push(@{$work->{"Gets"}},
                             ["ciscoPingSentPackets",	$num],
                             ["ciscoPingReceivedPackets", $num],
                             # mm, shouldn't this be PacketSize ?
                             ["ciscoPingPacketCount",	$num],
                             ["ciscoPingPacketTimeout",	$num],
                             ["ciscoPingDelay",		$num],
                             ["ciscoPingProtocol",	$num]);
                    } else {
                        # Still going
                        my $when = $work->{"Status"}{$_->[$SNMP::Varbind::iid_f]}[1];
                        $when = $work->{"Abort"}+1 if $when > $work->{"Abort"};
                        $pending	+= DELAYED_WEIGHT;
                        $work->{"Busy"} += DELAYED_WEIGHT;
                        # print STDERR "get(): $work->{'Uid'} busy=$work->{'Busy'}, pending=$pending\n";
                        $delayed->insert([$when, $work,
                                          $_->[$SNMP::Varbind::iid_f]]);
                        $delay_min = $when if $when < $delay_min;
                    }
                } elsif ($_->[$SNMP::Varbind::tag_f] eq "ciscoPingProtocol") {
                    my $num = $_->[$SNMP::Varbind::iid_f];
                    $work->{"Status"}{$num}[$ping_offset{"ciscoPingProtocol"}] = $_->[$SNMP::Varbind::val_f];
                    if ($work->{"Status"}{$num}[$ping_offset{"ciscoPingReceivedPackets"}]) {
                        push(@{$work->{"Gets"}},
                             ["ciscoPingMinRtt", $num],
                             ["ciscoPingAvgRtt", $num],
                             ["ciscoPingMaxRtt", $num]);
                    }
                    push(@{$work->{"Gets"}}, ["ciscoPingAddress", $num]);
                } elsif ($_->[$SNMP::Varbind::tag_f] eq "ciscoPingAddress") {
                    my $val = delete $work->{"Status"}{$_->[$SNMP::Varbind::iid_f]};
                    my $address = inet_ntoa($_->[$SNMP::Varbind::val_f]);
                    my $addr = defined($ip_seen{$address}) ?
                        $ip_seen{$address} : $address;
                    $pings{$work->{"Uid"}}{$addr}
                    = [$val->[0], map $val->[$ping_offset{$_}],
                       qw(ciscoPingPacketCount ciscoPingSentPackets
                          ciscoPingReceivedPackets ciscoPingMinRtt
                          ciscoPingAvgRtt ciscoPingMaxRtt)];
                    # Fake PacketCount to PacketSize
                    $pings{$work->{"Uid"}}{$addr}[1] = $ping_size;
                    if ($verbose) {
                        print STDERR "from $work->{'Uid'} to $address: @{$pings{$work->{'Uid'}}{$addr}}[4, 5, 6]\n";
                    }

                    my $ip = $ip2str{$_->[$SNMP::Varbind::val_f]} ||=
                        objid2str("1.$address");
                    my $count = 0;
                    my $str = "";
                    for (qw(ciscoPingSentPackets ciscoPingReceivedPackets
                            ciscoPingMinRtt ciscoPingAvgRtt
                            ciscoPingMaxRtt ciscoPingPacketCount
                            ciscoPingPacketTimeout ciscoPingDelay
                            ciscoPingProtocol)) {
                        next unless defined($val->[$ping_offset{$_}]);
                        $count++;
                        my Object $object =
                            $ping2object{$_} ||= ping2object($_);
                        # print STDERR "Object $object->[0], id ", unpack("w", $object->{"Id"}), "\n";
                        if ($object->{"Type"} eq "COUNTER") {
                            $val->[$ping_offset{$_}] =~ /^\d+\z/ or
                                die "$val->[$ping_offset{$_}] does not look like a $object->{'Type'}";
                            $str .= $object->{"Id"} . $ip . pack("w", $val->[$ping_offset{$_}]);
                        } elsif ($object->{"Type"} eq "INTEGER") {
                            $val->[$ping_offset{$_}] =~ /^-?\d+\z/ or
                                die "$val->[$ping_offset{$_}] does not look like a $object->{'Type'}";
                            $str .= $object->{"Id"} . $ip . pack("w", $val->[$ping_offset{$_}] & 0xffffffff);
                        } else {
                            die "$_ has Unhandled type $object->{'Type'}";
                        }
                    }
                    # Flush so we can push a perl-level print
                    buffer_flush($in);
                    print $in ($work->{"Id"},
                               pack("ww",
                                    int(($val->[0]-$start_time)*1000+0.5),
                                    int(($val->[2]-$val->[0])*1000+0.5)),
                               $str, "\x00");
                } elsif ($ping_offset{$_->[$SNMP::Varbind::tag_f]}) {
                    $work->{"Status"}{$_->[$SNMP::Varbind::iid_f]}[$ping_offset{$_->[$SNMP::Varbind::tag_f]}] = $_->[$SNMP::Varbind::val_f];
                } else {
                    print STDERR "$work->{Uid}: Dropping unknown tag $_->[$SNMP::Varbind::tag_f]";
                }
            }
        } else {
            # Error, probably timeout
            my $sess = $work->{"Snmp"};
            print STDERR "SNMP get from $work->{Uid}($sess->{DestHost}): ";
            if ($sess->{ErrorNum}) {
                print STDERR $sess->{ErrorStr};
            } else {
                print STDERR "timed out";
            }
            if ($pends) {
                print STDERR " on ", join(", ", map { "$_->[$SNMP::Varbind::tag_f].$_->[$SNMP::Varbind::iid_f]"} @{$pends});
            }
            print STDERR "\n";
            $work->{"Ok"} = 0;
        }
    }
    my $p = $pending;
    activate();
    # Get one more job going (until max is reached)
    activate() if $p != $pending && $pending < GLOBAL_PENDING;
}

sub get_lock {
    my $file = shift;
    sysopen(my $fh, $file, O_RDWR | O_CREAT) ||
        die "Could not open/create lockfile $file: $!";
    flock($fh, LOCK_NB | LOCK_EX) || die "Could not lock $file: $!";
    truncate($fh, 0);
    my $lfh = select($fh);
    $| = 1;
    select($lfh);
    print $fh "$$ $0\n";
    return $fh;
}

sub sender {
    my $file = tilde(opt_value("TicketFile", "ticket"));
    my $nr;
    if ($measure) {
        sysopen(my $fh, $file, O_RDWR | O_CREAT) ||
            die "Could not open/create ticket file $file: $!";
        $nr = <$fh> || 0;
    } else {
        if (sysopen(my $fh, $file, O_RDONLY)) {
            $nr = <$fh> || 0;
        } else {
            die "Could not open ticket file $file: $!" unless $! == ENOENT;
            $nr = 0;
        }
    }

    $nr =~ /^(\d*)$/ or die "Weird ticket in $file: $nr";
    $nr = $1 || "0";
    my $last = sprintf("%08d", ($1 || 0)%100000000);
    my (@nr) = $last =~ /^(\d\d)(\d\d)(\d\d)(\d\d)$/
        or die "Huh ? number $last cannot be written as four groups of 2 ??";
    $last = join("/", ".", @nr);
    # Tell about the last currently existing file
    print $pout "$last\n" if $send;
    return unless $measure;

    cleaner($last);

    $nr++;
    $nr .= "\n";

    open(my $fh, ">", "$file.new") || die "Could not create $file.new: $!";
    print $fh $nr;
    undef $fh;

    open($fh, "<", "$file.new") || die "Could not read from $file.new: $!";
    my $test = <$fh> || "\n";
    undef $fh;

    $test eq $nr || die "Failed to update ticket file. Disk full ?";
    rename("$file.new", $file) ||
        die "Could not rename $file.new to $file: $!";

    (@nr) = sprintf("%08d", $nr % 100000000) =~ /^(\d\d)(\d\d)(\d\d)(\d\d)$/
        or die "Huh ? number $nr cannot be written as four groups of 2 ??";
    my $file_name = join("/", @nr);
    unless(sysopen($fh, $file_name,
                   O_WRONLY | O_CREAT | O_TRUNC, $file_mode)) {
        unless (mkdir(join("/", @nr[0..@nr-2], ""))) {
            mkdir(join("/", @nr[0..$_], "")) for 0..@nr-2;
        }
        unless (sysopen($fh, $file_name,
                        O_WRONLY | O_CREAT | O_TRUNC, $file_mode)) {
            my $err = "$!";
            for (reverse 0..@nr-2) {
                rmdir(join("/", @nr[0..$_], "")) || last;
            }
            die "Could not create $file_name: $err";
        }
    }
    # print STDERR "Created $file_name\n";
    # Tell about the current file
    print $pout "./$file_name\n" if $send;
    $in = $fh;
    chomp($nr);
    return $nr;
}

sub sendout {
    my $mfh = shift;

    my $ssh = tilde(opt_value("Ssh", "ssh"));
    # print STDERR "will use ssh client $ssh\n";
    my $deliver = opt_value("DeliverHost", "localhost");
    pipe(my $pin, $pout) || die "Could not open pipe: $!";
    local (*LOUT);
    pipe($lin, LOUT)     || die "Could not open pipe: $!";
    defined(my $pid = fork()) || die "Could not fork: $!";
    if ($pid) {
        #parent
        close $pin;
        close(LOUT);
        my $fh = select($pout);
        $| = 1;
        select($fh);
        return;
    }
    # Child
    close $mfh;
    close $pout;
    close $lin;

    $mfh = get_lock(tilde(opt_value("SendLock", "send.lock")));

    local(*IN, *IN0, *OUT, *OUT0, *PIN, *POUT);

    pipe(IN0, OUT)	|| die "Could not create input  pipe: $!";
    pipe(IN, OUT0)	|| die "Could not create output pipe: $!";
    pipe(PIN, POUT)	|| die "Could not create probe pipe: $!";

    defined($pid = fork()) || die "Could not fork: $!";
    unless ($pid) {             # child
        close($mfh);
        close(IN);
        close(OUT);
        close(PIN);
        close(LOUT);

        eval {
            my $command = opt_value("RemoteCommand", "bin/CommitMeasurements");
            open(STDOUT, ">&OUT0") || die "Could not dup OUT0 to STDOUT: $!";
            my $flags;
            $flags = fcntl(STDOUT, F_GETFL, 0) ||
                die "Can't get flags for STDOUT: $!\n";
            fcntl(STDOUT, F_SETFL, $flags | O_NONBLOCK) ||
                die "Could not unblock STDOUT\n";

            open(STDIN, "<&IN0") || die "Could not dup IN0 to STDIN: $!";
            $flags = fcntl(STDIN, F_GETFL, 0) ||
                die "Can't get flags for STDIN: $!\n";
            fcntl(STDIN, F_SETFL, $flags | O_NONBLOCK) ||
                die "Could not unblock STDIN\n";
            close(IN0);
            close(OUT0);

            # Turns of use of authentication agent
            # delete $ENV{"SSH_AUTH_SOCK"};

            exec($ssh, $deliver, "-o", "Compression no", $command);
            # Just some general paranoia
            die "Exec failed: $!";
        };
        print POUT $@;
        exit 1;
    }
    close(IN0);
    close(OUT0);
    close(POUT);

    defined($pid = fork()) || die "Could not fork: $!";
    unless ($pid) {             # child
        close OUT;
        close PIN;
        close $pin;
        close $mfh;
        eraser(\*IN);
        print LOUT DONE;
        exit 0;
    }
    close LOUT;
    close IN;

    my $error = <PIN>;
    close PIN;
    die $error if defined($error);

    send_all($pin, \*OUT);
    print OUT DONE;

    # Close SendLock
    truncate($mfh, 0);

    exit 0;
}

sub eraser {
    my $sin = shift;
    # print STDERR "Going for erase\n";
    while (<$sin>) {
        last if $_ eq DONE;
        chomp;
        m|^(\.(?:/\d\d){4})\z| or die "Invalid form of filename $_";
        my $file = $1;
        # print STDERR "Erasing $file\n";
        next if $keep;
        unlink($file) || print STDERR "Could not unlink $file: $!";
    }
}

{
    my ($tsize, $end, $fun);

    sub file_find {
        my $dir = shift;
        local *DIR;
        unless (opendir(DIR, $dir)) {
            print STDERR "Could not opendir $dir: $!";
            rmdir($dir);
            return;
        }
        my @files = sort {$a <=> $b} map {/^(\d+)\z/?($1):()} readdir(DIR);
        closedir DIR;
        eval {
            while (defined(my $file = shift(@files))) {
                $file = "$dir/$file";
                next if $file ge $end;
                if (-d $file) {
                    file_find($file);
                } elsif (-f _) {
                    $fun->($file);
                } else {
                    print STDERR "Kept weird file $file\n";
                }
            };
            rmdir($dir) if !@files && $dir ne "";
            die $@ if $@;
        }
    }

    sub send_all {
        my ($pin, $sout) = @_;

        print $sout "v$sender_proto\n";
        print $sout "sender=${host}\n";
        my $cur_time = Time::HiRes::time+$ntp_offset+$tai_offset;
        print $sout "cur_time=$cur_time\n";
        # First get the id of the last finished file
        my $buffer = "";
        do {
            unless (my $rc = sysread($pin, $buffer, 8192, length($buffer))) {
                die "Short read from measurement process" if defined($rc);
                die "Error reading from measurement process: $!";
            }
        } until ($buffer =~ s/(.*)\n//);
        $end = $1;
        $end =~ m|^(\.(?:/\d+)+)\z| or die "Unexpected current file $end";
        $end = "$1/";
        # print STDERR "Up to $end\n";
        $fun = sub {
            my $file = shift;

            # Some debugging stuff
            return if $rand && rand($rand) >=1;	# simulates holes for debugging
            if (@do) {
                my $n=$file;
                $n =~ s/^\.//g;
                $n =~ s|/||g;
                $n +=0;
                return unless exists $do{$n};
            }

            # The real code
            local *FILE;
            unless (open(FILE, "<", $file)) {
                print STDERR "Could not open $file: $!";
                return;
            }
            my $last = last_line(\*FILE);
            if ($last ne THE_END) {
                print STDERR "Skip file $file not ending with ", THE_END;
                return;
            }
            seek(FILE, 0, 0) || die "Could not seek to 0 in $file: $!";
            print $sout "file(here)=$file\n";
            local $/ = \8192;
            print $sout $_ while <FILE>;
        };
        file_find(".");

        # Can fail if the measurer does not get started
        # Get the current snoopable file
        while (index($buffer, "\n") < 0) {
            unless (my $rc = sysread($pin, $buffer, 8192, length($buffer))) {
                die "Short read from measurement process (buffer='$buffer')" if
                    defined($rc);
                die "Error reading from measurement process: $! (buffer='$buffer')";
            }
        }
        $buffer =~ s/(.*)\n//;
        my $file = $1;
        if (!$measure) {
            return if "$file\n" eq DONE;
            die "Got a last file '$file' even while not measuring";
        }
        $file =~ m|^(\.(?:/\d+)+)\z| or die "Unexpected last file $file";
        $file = $1;
        # print STDERR "Last file is $file\n";

        # Set up $pin for polling (used to check if the measurer finished)
        my $flags;
        $flags = fcntl($pin, F_GETFL, 0) ||
            die "Can't get flags for measurement pipe: $!\n";
        fcntl($pin, F_SETFL, $flags | O_NONBLOCK) ||
            die "Could not unblock measurement pipe\n";

        local *FILE;
        unless (open(FILE, "<", $file)) {
            print STDERR "Could not open $file: $!";
            return;
        }
        print $sout "file(here)=$file\n";

        local $/ = \8192;
        my $pos = 0;
        while (1) {
            if ($buffer eq "" &&
                !(my $rc = sysread($pin, $buffer, 8192, length($buffer)))) {
                die "Short read from measurement process" if defined($rc);
                die "Error reading from measurement process: $!" unless
                    $! == EAGAIN;
            }
            seek(FILE, $pos, 0) || die "Could not seek $file to $pos: $!";
            # print STDERR "Seek to $pos, buffer='$buffer'\n";
            print $sout $_ while <FILE>;
            $pos = tell(FILE);
            if ($buffer ne "") {
                # The final DONE is coming in
                seek(FILE, -length(THE_END)-2, 1) ||
                    die "Could not seek $file backwards: $!";
                local $/="\n";
                my $last = <FILE>;
                defined($last)  || die "Unexpected short read from $file";
                $last eq "\0\n" || die "Unexpected contents near end of $file";
                $last = <FILE>;
                defined($last)  || die "Unexpected short read from $file";
                $last eq THE_END ||
                    die "Unexpected contents near end of $file";
                return;
            }

            my $fh = select($sout);
            {
                local $|=1;
                print $sout "";
            }
            select($fh);
            # print STDERR "Early end. Waiting\n";
            sleep 2;
        }
    }

    sub cleaner {
        $end = shift;
        my $size = $tsize = (-s $end || 1024*1024)*2;
        my $avail = df(".");
        # $avail= 0;              # for debugging
        if ($size) {
            return if $avail > $size/1024;
        }
        print STDERR "Free diskspace is getting low. I'll try to free $size bytes\n";
        eval {
            $fun = sub {
                my $file = shift;
                print STDERR "Unlinking $file\n";
                unless (unlink($file)) {
                    next if $! == ENOENT;
                    die "Could not unlink $file: $!";
                }
                $tsize -= -s _;
                print STDERR "Target of $tsize bytes left\n";
                die "\n" if $tsize <0;
            };
            file_find(".");
        };
        die $@ if $@ && $@ ne "\n";

        $avail = df(".");
        # $avail= 0;              # for debugging
        return if $avail > $size/1024;
        die "Could not free $size bytes. The disk is too full";
    }
}

process($::Base);

__DATA__
__C__
#line 861

#include <strings.h>
#include <errno.h>
#include <limits.h>
#include <ctype.h>
#include <stdlib.h>

#define BUFSIZE 16000
static unsigned char buffer[BUFSIZE*2];
static unsigned char *base=buffer;
static unsigned char *pos=buffer;

void buffer_flush(SV *out) {
    dSP;

    if (base == pos) return;
    if (!SvOK(out)) croak("output handle is undef");

    ENTER;
    SAVETMPS;
    PUSHMARK(SP);
    EXTEND(SP, 2);
    PUSHs(sv_2mortal(SvREFCNT_inc(out)));
    PUSHs(sv_2mortal(newSVpvn(base, pos-base)));
    PUTBACK;
    call_method("print", G_DISCARD);
    FREETMPS;
    LEAVE;

    base = pos = buffer;
}

static void output(SV *out, const char *string, STRLEN length) {
    if (pos+length >= &buffer[sizeof(buffer)]) {
        if (pos+length-(base-buffer) >= &buffer[sizeof(buffer)]) {
            /* Shifting won't help either */
            buffer_flush(out);
            if (pos+length >= &buffer[sizeof(buffer)])
                croak("Internal buffer overflows trying to send %lu bytes",
                      (unsigned long) length);
        } else {
            Move(base, buffer, pos-base, unsigned char);
            pos -= base-buffer;
            base = buffer;
        }
    }
    Copy(string, pos, length, unsigned char);
    pos += length;
}

static void out_ulong(SV *out, unsigned long value) {
    unsigned char work[80], *ptr;

    ptr = &work[sizeof(work)-1];
    *ptr = value & 0x7F;
    value >>= 7;
    while (value) {
        if (ptr == work) croak("Wow grandmother, your longs are so long !");
        *--ptr = (value & 0x7F)|0x80;
        value >>= 7;
    }
    output(out, ptr, &work[sizeof(work)]-ptr);
}

static void output_oid(SV *out, char *string, const char *context) {
    SV **rval, *val;
    char *ptr;
    unsigned long value;
    while (1) {
        if (!isdigit(*string))
            croak("Non number %.300s in oid %.150s", string, context);
        value = strtoul(string, &ptr, 10);
        if (ptr == string)
            croak("Weird ! Non number %.300s in oid %.150s", string, context);
        if (value == ULONG_MAX)
            croak("Number %.300s in oid %.150s overflows", string, context);
        if (value >= ULONG_MAX/2)
            croak("Number %.300s in oid %.150s is a valid long, but overflows my encoding", string, context);
        if (*ptr == 0) {
            out_ulong(out, 2*value+1);
            break;
        } else if (*ptr == '.') {
            out_ulong(out, 2*value);
            string = ptr+1;
        } else croak("Number %.300s in %.150s contains invalid characters",
                     string, context);
    }
}


static int job_Id_index, job_Pending_index, job_Vars_index;
static int object_Id_index, object_Type_index, object_Fun_index;
static int varbind_tag_index, varbind_iid_index;
static int varbind_val_index, varbind_type_index;

typedef struct {
    int *value;
    const char *name;
} namer;

static const namer job_field_names[] = {
    {&job_Id_index,	"Id"},
    {&job_Pending_index,"Pending"},
    {&job_Vars_index,	"Vars"},
};

static const namer object_field_names[] = {
    {&object_Id_index,	"Id"},
    {&object_Type_index,"Type"},
    {&object_Fun_index, "Fun"},
};

static const namer varbind_field_names[] = {
    {&varbind_tag_index,	"SNMP::Varbind::tag_f"},
    {&varbind_iid_index,	"SNMP::Varbind::iid_f"},
    {&varbind_val_index,	"SNMP::Varbind::val_f"},
    {&varbind_type_index,	"SNMP::Varbind::type_f"},
};

static void get_constants(void) {
    SV **rval, *val;
    const namer *here;
    HV *fields;
    static int done=0;
    if (done) return;

    fields = get_hv("Job::FIELDS", FALSE);
    if (!fields) croak("No %%Job::FIELDS");
    for (here = job_field_names;
         here < job_field_names+sizeof(job_field_names)/sizeof(*job_field_names);
         here++) {
        rval = hv_fetch(fields, here->name, strlen(here->name), 0);
        if (!rval) croak("No $Job::FIELDS{%s} entry", here->name);
        val = *rval;
        if (!SvOK(val)) croak("$Job::FIELDS{%s} is undefined", here->name);
        *here->value = SvIV(val);
        if (*here->value <= 0)
            croak("$Job::FIELDS{%s} is %d instead of positive",
                  here->name, *here->value);
    }

    fields = get_hv("Object::FIELDS", FALSE);
    if (!fields) croak("No %%Object::FIELDS");
    for (here = object_field_names;
         here < object_field_names+sizeof(object_field_names)/sizeof(*object_field_names);
         here++) {
        rval = hv_fetch(fields, here->name, strlen(here->name), 0);
        if (!rval) croak("No $Object::FIELDS{%s} entry", here->name);
        val = *rval;
        if (!SvOK(val)) croak("$Object::FIELDS{%s} is undefined", here->name);
        *here->value = SvIV(val);
        if (*here->value <= 0)
            croak("$Object::FIELDS{%s} is %d instead of positive",
                  here->name, *here->value);
    }

    for (here = varbind_field_names; here < varbind_field_names+sizeof(varbind_field_names)/sizeof(*varbind_field_names); here++) {
        SV *val;
        int value;

        val = get_sv(here->name, FALSE);
        if (!val) croak("$%.300s does not exist", here->name);
        if (!SvOK(val)) croak("$%.300s is undef", here->name);
        value = SvIV(val);
        if (value < 0) croak("%.300ss returned %d, which is negative",
                             here->name, value);
        *here->value = value;
        /* fprintf(stderr, "Name: %s=%d\n", here->name, *here->value); */
    }

    done = 1;
}

void process_results(SV *out, SV *work_array, SV *vars_array,
                     double start_time, SV *pends_array, double send_time) {
    SV *val, **rval;
    AV *work, *vars, *pends, *work_pending, *work_vars;
    STRLEN length;
    char *string;
    struct timeval tv;
    int i;
    dSP;

    ENTER;
    get_constants();

    if (!SvROK(work_array)) croak("work argument is not a reference");
    work = (AV*)SvRV(work_array);
    if (SvTYPE(work) != SVt_PVAV) croak("work is not an array reference");

    rval = av_fetch(work, job_Pending_index, 0);
    if (!rval) croak("$work->{Pending} is unset");
    val = *rval;
    if (!SvOK(val)) croak("$work->{Pending} is undef");
    if (!SvROK(val)) croak("$work->{Pending} is not a reference");
    work_pending = (AV*)SvRV(val);
    if (SvTYPE(work_pending) != SVt_PVAV)
        croak("$work->{Pending} is not an array reference");

    rval = av_fetch(work, job_Vars_index, 0);
    if (!rval) croak("$work->{Vars} is unset");
    val = *rval;
    if (!SvOK(val)) croak("$work->{Vars} is undef");
    if (!SvROK(val)) croak("$work->{Vars} is not a reference");
    work_vars = (AV*)SvRV(val);
    if (SvTYPE(work_vars) != SVt_PVAV)
        croak("$work->{Vars} is not an array reference");

    if (!SvROK(vars_array)) croak("vars argument is not a reference");
    vars = (AV*)SvRV(vars_array);
    if (SvTYPE(vars) != SVt_PVAV) croak("vars is not an array reference");

    if (!SvROK(pends_array)) croak("pends argument is not a reference");
    pends = (AV*)SvRV(pends_array);
    if (SvTYPE(pends) != SVt_PVAV)
        croak("pends is not an array reference");

    if (av_len(vars) != av_len(pends))
        croak("Unexpected answer length, vars has %d elements, pends has %d",
              av_len(vars)+1, av_len(pends)+1);
    if (gettimeofday(&tv, NULL))
        croak("gettimeofday failed: %s", strerror(errno));

    rval = av_fetch(work, job_Id_index, 0);
    if (!rval) croak("Id field of work is unset");
    val = *rval;
    if (!SvOK(val)) croak("Id field of work is undef");
    string = SvPV(val, length);
    output(out, string, length);
    out_ulong(out, (unsigned long)((send_time-start_time)*1000+0.5));
    out_ulong(out, (unsigned long)(((double)tv.tv_sec-send_time)*1000+(double)tv.tv_usec/1000+0.5));
    for (i=0; i <= av_len(vars); i++) {
        AV *pend_item;
        AV *object;
        SV *tag, *vars_info, *pend_info;
        char *tag_string;
        STRLEN tag_length;

        rval = av_fetch(pends, i, 0);
        if (!rval) croak("pend[%d] is not set", i);
        pend_info = *rval;
        if (!SvOK(pend_info)) croak("pend[%d] is undef", i);
        if (!SvROK(pend_info)) croak("pend->[%d] is not a reference", i);
        pend_item = (AV*)SvRV(pend_info);
        if (SvTYPE(pend_item) != SVt_PVAV)
            croak("pend->[%d] is not an array reference", i);

        rval = av_fetch(vars, i, 0);
        if (!rval) croak("vars->[%d] is not set", i);
        vars_info = *rval;
        if (!SvOK(vars_info)) croak("vars->[%d] is undef", i);
        if (!SvROK(vars_info)) croak("vars->[%d] is not a reference", i);
        object = (AV*)SvRV(vars_info);
        if (SvTYPE(object) != SVt_PVAV)
            croak("vars->[%d] is not an array reference", i);

        rval = av_fetch(pend_item, varbind_tag_index, 0);
        if (!rval) croak("pend->[%d][tag] is not set", i);
        tag = *rval;
        if (!SvOK(tag)) croak("pend->[%d][tag] is undef", i);
        tag_string = SvPV(tag, tag_length);

        rval = av_fetch(object, 0, 0);	/* Object has name at index 0 */
        if (!rval) croak("vars->[%d][0] is not set", i);
        val = *rval;
        if (!SvOK(val)) croak("vars->[%d][0] is undef", i);
        string = SvPV(val, length);

        /* fprintf(stderr, "%d: Sent %s, received %s\n",
           i, string, tag_string); */
        if (length == tag_length && memcmp(string, tag_string, length) == 0) {
            char *val_string, *oid_string;
            STRLEN val_length;
            SV *val_sv, *iid_sv;

            /* Not at the end of the table yet */
            av_push(work_vars,    SvREFCNT_inc(vars_info));
            av_push(work_pending, SvREFCNT_inc(pend_info));

            rval = av_fetch(object, object_Id_index, 0);
            if (!rval) croak("%.300s: $object->{Id} is unset", tag_string);
            val = *rval;
            if (!SvOK(val))
                croak("%.300s: $object->{Id} is undef", tag_string);
            string = SvPV(val, length);
            output(out, string, length);

            rval = av_fetch(pend_item, varbind_iid_index, 0);
            if (!rval)
                croak("%.300s: $pend->[$SNMP::Varbind::iid_f] is unset",
                      tag_string);
            iid_sv = *rval;
            if (!SvOK(iid_sv))
                croak("%.300s: $pend->[$SNMP::Varbind::iid_f] is undef",
                      tag_string);
            oid_string = SvPV(iid_sv, length);
            output_oid(out, oid_string, "$pend->[$SNMP::Varbind::iid_f]");

            rval = av_fetch(pend_item, varbind_val_index, 0);
            if (!rval)
                croak("%.300s: $pend->[$SNMP::Varbind::val_f] is unset",
                      tag_string);
            val_sv = *rval;
            if (!SvOK(val_sv))
                croak("%.300s: $pend->[$SNMP::Varbind::val_f] is undef",
                      tag_string);
            val_string = SvPV(val_sv, val_length);

            rval = av_fetch(object, object_Type_index, 0);
            if (!rval) croak("%.300s: $object->{Type} is unset", tag_string);
            val = *rval;
            if (!SvOK(val))
                croak("%.300s: $object->{Type} is undef", tag_string);
            string = SvPV(val, length);
            /* fprintf(stderr, "%s.%s -> Type %s, value %s\n",
               tag_string, oid_string, string, val_string); */
            switch(length) {
                long svalue;
                unsigned long value;
                unsigned char work[4];
                char *ptr;
                int i;
              case 7: /* INTEGER, COUNTER */
                if (memcmp(string, "INTEGER", length)) {
                    if (memcmp(string, "COUNTER", length) == 0) goto ugroup;
                    croak("%.200s: Unknown $object->{Type}=\"%.200s\"",
                          tag_string, string);
                }
                errno = 0;
                svalue = strtol(val_string, &ptr, 10);
                if (val_string == ptr || *ptr)
                    croak("%.200s: $pend->[$SNMP::Varbind::val_f]=\"%.200s\" is not a valid integer", tag_string, val_string);
                if (errno) {
                    if (errno != ERANGE)
                        croak("%.200s: $pend->[$SNMP::Varbind::val_f]=\"%.200s\" errors with %s", tag_string, val_string, strerror(errno));
                    else if (svalue == LONG_MIN)
                        croak("%.200s: $pend->[$SNMP::Varbind::val_f]=\"%.200s\" underflows", tag_string, val_string);
                    else if (svalue == LONG_MAX)
                        croak("%.200s: $pend->[$SNMP::Varbind::val_f]=\"%.200s\" overflows", tag_string, val_string);
                    else croak("%.200s: $pend->[$SNMP::Varbind::val_f]=\"%.200s\" has a range error which seems neither an overflow or an underflow", tag_string, val_string);
                }
                out_ulong(out, (unsigned long) svalue);
                break;
              case 6: /* IPADDR */
                if (memcmp(string, "IPADDR", length))
                    croak("%.200s: Unknown $object->{Type}=\"%.200s\"",
                          tag_string, string);
                if (!isdigit(*val_string)) croak("%.200s: $pend->[$SNMP::Varbind::val_f]=\"%.200s\" is not a valid ip address", tag_string, val_string);
                value = strtoul(val_string, &ptr, 10);
                if (val_string == ptr) croak("%.200s: Weird ! $pend->[$SNMP::Varbind::val_f]=\"%.200s\" is not a valid ip address", tag_string, val_string);
                if (value >= 0x100)
                    croak("%.200s; First number in ip address $pend->[$SNMP::Varbind::val_f]=\"%.200s\" is out of range", tag_string, val_string);
                work[0] = value;
                for (i=1; i<4; i++) {
                    if (*ptr != '.')
                        croak("%.200s: $pend->[$SNMP::Varbind::val_f]=\"...%.200s\" is not a valid ip address", tag_string, val_string);
                    val_string = ptr+1;
                    if (!isdigit(*val_string)) croak("%.200s: $pend->[$SNMP::Varbind::val_f]=\"...%.200s\" is not a valid ip address", tag_string, val_string);
                    value = strtoul(val_string, &ptr, 10);
                    if (val_string == ptr) croak("%.200s: Weird ! $pend->[$SNMP::Varbind::val_f]=\"...%.200s\" is not a valid ip address", tag_string, val_string);
                    if (value >= 0x100)
                        croak("%.200s: First number in ip address $pend->[$SNMP::Varbind::val_f]=\"...%.200s\" is out of range", tag_string, val_string);
                    work[i] = value;
                }
                if (*ptr)
                    croak("%.200s: Extra stuff in $pend->[$SNMP::Varbind::val_f]=\"...%.200s\"", tag_string, val_string);
                output(out, work, 4);
                break;
              case 8: /* OBJECTID, OCTETSTR */
                if (memcmp(string, "OBJECTID", length) == 0) {
                    if (*val_string != '.')
                        croak("Oid $pend->[$SNMP::Varbind::val_f]=\"\" does not start with a .", val_string);
                    output_oid(out, val_string+1,
                               "$pend->[$SNMP::Varbind::val_f]");
                } else if (memcmp(string, "OCTETSTR", length) == 0) {
                    out_ulong(out, (unsigned long) val_length);
                    output(out, val_string, val_length);
                } else {
                    croak("%.200s: Unknown $object->{Type}=\"%.200s\"",
                          tag_string, string);
                }
                break;
              default: /* The unsigned group */
              ugroup:
                if (!isdigit(*val_string))
                    croak("%.200s: Non number %.200s in unsigned $pend->[$SNMP::Varbind::val_f]", tag_string, val_string);
                errno = 0;
                value = strtoul(val_string, &ptr, 10);
                if (errno) {
                    if (errno != ERANGE)
                        croak("%.150s: $pend->[$SNMP::Varbind::val_f]=\"%.200s\" errors with %s", tag_string, val_string, strerror(errno));
                    else if (svalue == ULONG_MAX)
                        croak("%.200s: $pend->[$SNMP::Varbind::val_f]=\"%.200s\" overflows", tag_string, val_string);
                    else croak("%.200s: $pend->[$SNMP::Varbind::val_f]=\"%.200s\" has a range error which seems not an overflow", tag_string, val_string);
                }
                out_ulong(out, (unsigned long) value);
                break;
            }

            rval = av_fetch(object, object_Fun_index, 0);
            if (!rval) continue;
            val = *rval;
            if (!SvOK(val)) continue;

            SAVETMPS;

            SPAGAIN;
            PUSHMARK(SP);
            EXTEND(SP, 4);
            PUSHs(sv_2mortal(SvREFCNT_inc(work_array)));
            PUSHs(sv_2mortal(SvREFCNT_inc(tag)));
            PUSHs(sv_2mortal(SvREFCNT_inc(iid_sv)));
            PUSHs(sv_2mortal(SvREFCNT_inc(val_sv)));
            PUTBACK;
            sv_2mortal(SvREFCNT_inc(val));
            call_sv(val, G_DISCARD);

            FREETMPS;
        }
    }
    output(out, "", 1);
    if (pos - base >= 4096) buffer_flush(out);
    LEAVE;
}

__END__

=head1 NAME

This documentation is unfinished !!!!

MeasureAll - Parallel device SNMP query

=head1 SYNOPSIS

MeasureAll [-U] [--unsafe] [-h] [--help] [-v] [--version] [-r] [--restricted]

=head1 DESCRIPTION

Process and communication structure:

 +-------------------------------------------------------------------------+
 |  MeasureHost                                                            |
 |                                                                         |
 |  +-------------------------------<-----------------------------------+  |
 |  |                                                                   |  |
 |  |   +---------+         +--------+    +----------+    +--------+    |  |
 |  |   |         |         |        |    |          |    |        |    |  |
 |  +-->| Measure +-      ->+  Send  +--->++  Ssh   ++--->+ Delete +->--+  |
 |      |         | \    /  |        |    | \      / |    |        |       |
 |      +--++-----+  |  |   +--------+    +--+----+--+    +--------+       |
 |        //         V  |                    |    ^                        |
 |   ~~~~++~     +---+--+---+                |    |                        |
 |  /       \    |          |                |    |                        |
 | { network }   |FileSystem|                |    |                        |
 |  \       /    |          |                |    |                        |
 |   ~~~~~~~     +----------+                |    |                        |
 |                                           |    |                        |
 +-------------------------------------------+----+------------------------+
                                             |    |
                                             |    |
 +-------------------------------------------+----+------------------------+
 | DeliverHost                               |    |                        |
 |                                           V    |                        |
 |                                        +--+----+--+                     |
 |                                        |  |    ^  |                     |
 |                                        |  |Sshd|  |                     |
 |                                        |  |    |  |                     |
 |                                        +--+----+--+                     |
 |                                           |    ^                        |
 |                                           |    |                        |
 |                                           V    |                        |
 |                                        +--+----+--+                     |
 |                                        |          |                     |
 |                                        |  Commit  |                     |
 |                                        |          |                     |
 |                                        +----+-----+                     |
 |                                             |                           |
 |                                             |                           |
 +---------------------------------------------+---------------------------+
                                               |
                                               |
 +---------------------------------------------+---------------------------+
 | DataHost                                    |                           |
 |                                             |                           |
 |                                        +----+-----+                     |
 |                                        |          |                     |
 |                                        | Database |                     |
 |                                        |          |                     |
 |                                        +----------+                     |
 |                                                                         |
 |                                                                         |
 +-------------------------------------------------------------------------+


=head1 OPTIONS

=over 4

=item  -h, --help

Show this help.

=item -U, --unsafe

Allow even root to run the perldoc.
Remember, the reason this is off by default is because it B<IS> unsafe.

=item -v, --version

Print version info.

=item -r, --restricted

Only do rfc standard probes, nothing device specific (in particular, no
cisco specific queries).

=back

=head1 Configuration file

The configuration file is derived from the executable name by replacing the
F<bin/> in the path by F<conf/>. So if the program is called
F</home/nms_measure/bin/MeasureAll>, the configuration file will be found in
F</home/nms_measure/conf/MeasureAll>.

For the format see L<Hier>. Recognized tags are:

=over 4

=item Send

Whether the sending components will be activated. Defaults to true.

=item Measure

Whether the measurement component will be activated. Defaults to true

=item Keep

Whether transmitted resultfiles will be erased after a successful transfer.
Defaults to false (erase after succesful send). If set to true, a next send
will retransmit the file.

=item SafeMode

Filemode given to the result files. Defaults to 0600 (so only the user itself
can read the files which might contain sensitive info, like the SNMP write
community)

=item Ntpq

The ntp query program, defaults to L<ntpq|ntpq(1)>

=item MibDir

The name of the directory with extra mibs. Has no default and must be supplied.
Will be passed as argument to L<SNMP::addMibDirs|SNMP/"addMibDirs">.

=item ResultDir

=item MeasureLock

=item TicketFile

=item Ssh

=item DeliverHost

=item SendLock

=item RemoteCommand

=back

=head1 EXAMPLE

Here's a simple example configuration file:

 # Hier magic
 # The indentation gives the structure! The braces are just syntactic sugar.
 %include General
 Program = MeasureAll {
     MibDir = /home/nms_measure/mibs/good
     ResultDir = ~/data/test-snmp
     DeliverHost = quasar.eth
 }
 # This must be the last line

=head1 BUGS

Setting up pings fails ever so often for unclear reasons.

The setup would probably be clearer if the components were split up over
multiple programs.

=head1 Communication Protocols

This describes the messages passed between the several subprocesses

=over 4

=head2 Output to the remote site

sftghdfgs

=back

=head1 AUTHOR

Ton Hospel (MeasureAll@ton.iguana.be)

=head1 SEE ALSO

L<CommitMeasurements>,
L<Collect>,
L<ReceiveFiles>,
L<Ntp>,
L<SNMP>