#!/cw/bin/perl
##
##  OSSP snmpdx -- SNMP Daemon Extension
##  Copyright (c) 2003 The OSSP Project <http://www.ossp.org/>
##  Copyright (c) 2003 Ralf S. Engelschall <rse@engelschall.com>
##  Copyright (c) 2003 Cable & Wireless <http://www.cw.com/>
##
##  Permission to use, copy, modify, and distribute this software for
##  any purpose with or without fee is hereby granted, provided that
##  the above copyright notice and this permission notice appear in all
##  copies.
##
##  THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESSED OR IMPLIED
##  WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
##  MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
##  IN NO EVENT SHALL THE AUTHORS AND COPYRIGHT HOLDERS AND THEIR
##  CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
##  SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
##  LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF
##  USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
##  ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
##  OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT
##  OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
##  SUCH DAMAGE.
##

#   requirements
require 5;
use strict;
use warnings;
use FindBin;
use Getopt::Long;
use IO;

#   program information
my $prg = {
    'name'    => 'OSSP snmpdx',
    'version' => '0.1.0',
    'date'    => '01-Sep-2003'
};

##  _________________________________________________________________________
##
##  HELPER CLASS: LOGFILE WRITING
##  _________________________________________________________________________
##

package My::Log;

require Exporter;

our @ISA = qw(Exporter);
our @EXPORT_OK = qw(new destroy DESTROY write);

sub new ($$) {
    my $proto = shift @_;
    my $class = ref $proto || $proto;
    my $self = {};
    bless ($self, $class);
    my $level    = shift @_ || die "missing level argument";
    my $filename = shift @_ || die "missing filename argument";
    $self->{-level} = $level;
    $self->{-io} = new IO::File ">>$filename"
        or die "cannot open logfile \"$filename\" for writing";
    $self->{-io}->autoflush(1);
    return $self;
}

sub destroy ($) {
    my ($self) = @_;
    $self->{-io}->close() if (defined($self->{-io}));
    return;
}

sub DESTROY ($) {
    my ($self) = @_;
    $self->destroy;
    return;
}

sub printf ($;@) {
    my $self  = shift @_;
    my $level = shift @_ || die "missing level argument";
    my $fmt   = shift @_ || die "missing format argument";
    if ($self->{-level} >= $level) {
        my ($sec, $min, $hour, $mday, $mon, $year, $wday, $yday, $isdst) = localtime(time());
        my $id = sprintf("[%04d-%02d-%02d/%02d:%02d:%02d@%05d] ", 
                         $year+1900, $mon+1, $mday, $hour, $min, $sec, $$);
        $self->{-io}->printf($id . $fmt . "\n", @_);
    }
    return;
}

##  _________________________________________________________________________
##
##  HELPER CLASS: VALUE CACHING
##  _________________________________________________________________________
##

package My::Cache;

require Exporter;

our @ISA = qw(Exporter);
our @EXPORT_OK = qw(new destroy DESTROY store fetch);

sub new ($) {
    my ($proto) = @_;
    my $class = ref $proto || $proto;
    my $self = {};
    bless ($self, $class);
    $self->{-cache} = {};
    return $self;
}

sub destroy ($) {
    my ($self) = @_;
    return;
}

sub DESTROY ($) {
    my ($self) = @_;
    $self->destroy;
    return;
}

sub store ($$$$) {
    my ($self, $id, $expires, $value) = @_;

    die "invalid id" if (not defined($id) or $id eq '');

    if    ($expires =~ m|^(\d+)[sS]?$|) { $expires = $1; }
    elsif ($expires =~ m|^(\d+)[mM]$|)  { $expires = $1 * 60; }
    elsif ($expires =~ m|^(\d+)[hH]$|)  { $expires = $1 * 60 * 60; }
    elsif ($expires =~ m|^(\d+)[dD]$|)  { $expires = $1 * 60 * 60 * 24; }
    elsif ($expires =~ m|^(\d+)[wW]$|)  { $expires = $1 * 60 * 60 * 24 * 7; }
    elsif ($expires =~ m|^forever$|i)   { $expires = 99999 * 365 * 24 * 60 * 60; }
    else { die "invalid expire time"; }

    $expires = time() + $expires;

    $self->{-cache}->{$id} = { -expires => $expires, -value => $value };

    return;
}

sub fetch ($$) {
    my ($self, $id) = @_;

    my $value = undef;
    if (defined($self->{-cache}->{$id})) {
        if ($self->{-cache}->{$id}->{-expires} > time()) {
            $value = $self->{-cache}->{$id}->{-value};
        }
        else {
            undef $self->{-cache}->{$id};
        }
    }
    return $value;
}

##  _________________________________________________________________________
##
##  HELPER CLASS: RUNNING SYSTEM COMMANDS
##  _________________________________________________________________________
##

package My::System;

require Exporter;

our @ISA = qw(Exporter);
our @EXPORT_OK = qw(new destroy DESTROY run);

sub new ($;$) {
    my ($proto, $log, $cache) = @_;
    my $class = ref $proto || $proto;
    my $self = {};
    bless ($self, $class);
    $self->{-log}   = $log;
    $self->{-cache} = (defined($cache) ? $cache : new My::Cache);
    return $self;
}

sub destroy ($) {
    my ($self) = @_;
    $self->{-cache}->destroy() if (defined($self->{-cache}));
    return;
}

sub DESTROY ($) {
    my ($self) = @_;
    $self->destroy;
    return;
}

sub run ($$;$) {
    my ($self, $cmd, $expires) = @_;

    $expires = "1m" if (not defined($expires));
    my $result = $self->{-cache}->fetch($cmd);
    if (defined($result)) {
        $self->{-log}->printf(4, "system: run: \"$cmd\" ($expires) [CACHE HIT]");
    }
    else {
        $self->{-log}->printf(3, "system: run: \"$cmd\" ($expires) [CACHE MISS]");
        $self->{-log}->printf(5, "system: executing command: \"$cmd\""); 
        $result = { -stdout => '', -rv => 0 };
        $result->{-stdout} = `$cmd 2>/dev/null`;
        $result->{-rv} = ($? >> 8);
        $self->{-log}->printf(6, "system: return value: ". $result->{-rv}); 
        $self->{-cache}->store($cmd, $expires, $result);
    }
    return $result;
}

##  _________________________________________________________________________
##
##  HELPER CLASS: PLATFORM IDENTIFICATION
##  _________________________________________________________________________
##

package My::Platform;

require Exporter;

our @ISA = qw(Exporter);
our @EXPORT_OK = qw(new destroy DESTROY id);

sub new ($) {
    my ($proto) = @_;
    my $class = ref $proto || $proto;
    my $self = {};
    bless ($self, $class);
    $self->{-machine} = `(uname -m) 2>/dev/null`;
    $self->{-machine} = `(uname -p) 2>/dev/null` if ($self->{-machine} eq '');
    $self->{-machine} =~ s|^\s*(.+?)\s*$|$1|s;
    $self->{-system}  = `(uname -s) 2>/dev/null`;
    $self->{-system}  =~ s|^\s*(.+?)\s*$|$1|s;
    $self->{-release} = `(uname -r) 2>/dev/null`;
    $self->{-release} = `(uname -v) 2>/dev/null` if ($self->{-release} eq '');
    $self->{-release} =~ s|^\s*(.+?)\s*$|$1|s;
    return $self;
}

sub destroy ($) {
    my ($self) = @_;
    return;
}

sub DESTROY ($) {
    my ($self) = @_;
    $self->destroy;
    return;
}

sub arch ($) {
    my ($self) = @_;
    return $self->{-machine};
}

sub os ($) {
    my ($self) = @_;
    return sprintf("%s%s", $self->{-system}, $self->{-release});
}

sub id ($) {
    my ($self) = @_;
    return sprintf("%s-%s%s", $self->{-machine}, $self->{-system}, $self->{-release});
}

##  _________________________________________________________________________
##
##  HELPER CLASS: MIB OID/NAME MAPPING
##  _________________________________________________________________________
##

package My::MIB;

require Exporter;

our @ISA = qw(Exporter);
our @EXPORT_OK = qw(new destroy DESTROY oid2name name2oid oid2type);

sub new ($$$) {
    my ($proto, $bindir, $mibdir, $mib) = @_;
    my $class = ref $proto || $proto;
    my $self = {};
    bless ($self, $class);
    $self->{-oid2name} = {};
    $self->{-name2oid} = {};
    my @entries = `$bindir/snmptranslate -M $mibdir -m $mib -Tl`;
    foreach my $entry (@entries) {
        $entry =~ s|\n$||s;
        my $name = $entry;
        my $oid = '';
        $name =~ s|\((\d+)\)|$oid .= ".$1", ''|sge;
        my $out = `$bindir/snmptranslate -M $mibdir -m $mib -Td $oid`;
        if ($out =~ m|\s+MAX-ACCESS\s+not-accessible\s*|si) {
            next;
        }
        my $type;
        if ($out =~ m|TEXTUAL\s+CONVENTION\s+(.+?)\n\s+SYNTAX|si) {
            $type = $1;
        }
        elsif ($out =~ m|SYNTAX\s+(.+?)\s*\n|si) {
            $type = $1;
            $type =~ s|\s+\([^\)]+\)$||s;
        }
        else {
            next;
        }
        if ($name =~ m|[^.]+TABLE\.[^.]+ENTRY\.[^.]+$|) {
            $name .= ".#";
            $oid  .= ".#";
        }
        $self->{-oid2type}->{$oid} = $type;
        $self->{-oid2name}->{$oid} = $name;
        $self->{-name2oid}->{$name} = $oid;
    }
    return $self;
}

sub destroy ($) {
    my ($self) = @_;
    return;
}

sub DESTROY ($) {
    my ($self) = @_;
    $self->destroy;
    return;
}

sub oid2name ($$) {
    my ($self, $oid) = @_;
    return $self->{-oid2name}->{$oid};
}

sub name2oid ($$) {
    my ($self, $name) = @_;
    return $self->{-name2oid}->{$name};
}

sub oid2type ($$) {
    my ($self, $oid) = @_;
    return $self->{-oid2type}->{$oid};
}

sub oids ($;@) {
    my ($self, @patterns) = @_;
    my $oids = [];
    foreach my $pattern (@patterns) {
        $pattern = "*" if (not defined($pattern));
        $pattern =~ s/\./\\./sg;
        $pattern =~ s/\*/.*/sg;
        foreach my $name (keys(%{$self->{-name2oid}})) {
            if ($name =~ m|^${pattern}$|si) {
                push(@{$oids}, $self->{-name2oid}->{$name});
            }
        }
    }
    return $oids;
}

##  _________________________________________________________________________
##
##  HELPER CLASS: PROBE (abstract only)
##  _________________________________________________________________________
##

package My::Probe;

require Exporter;

our @ISA = qw(Exporter);
our @EXPORT_OK = qw(new destroy DESTROY oids probe);

sub new ($$) {
    my ($proto, $ctx) = @_;
    my $class = ref $proto || $proto;
    my $self = {};
    bless ($self, $class);
    $self->{-ctx} = $ctx;
    return $self;
}

sub destroy ($) {
    my ($self) = @_;
    return;
}

sub DESTROY ($) {
    my ($self) = @_;
    $self->destroy;
    return;
}

sub oids ($) {
    my ($self) = @_;
    return [];
}

sub probe ($$$) {
    my ($self, $ctx, $oid) = @_;
    return {};
}

##  _________________________________________________________________________
##
##  HELPER CLASS: Encoding
##  _________________________________________________________________________
##

package My::Enc;

require Exporter;

our @ISA = qw(Exporter);
our @EXPORT_OK = qw(new destroy DESTROY dat_encode dat_decode octet_encode octet_decode);

sub new ($$) {
    my ($proto) = @_;
    my $class = ref $proto || $proto;
    my $self = {};
    bless ($self, $class);
    return $self;
}

sub destroy ($) {
    my ($self) = @_;
    return;
}

sub DESTROY ($) {
    my ($self) = @_;
    $self->destroy;
    return;
}

#   ASN.1 DateAndTime encoding/decoding
sub dat_encode ($$) {
    my ($self, $asc) = @_;
    my ($y, $m, $d, $H, $M, $S) = (0, 0, 0, 0, 0, 0);
    if ($asc =~ m|^(\d{4})-(\d{2})-(\d{2}) (\d{2}):(\d{2}):(\d{2})$|) {
        ($y, $m, $d, $H, $M, $S) = ($1, $2, $3, $4, $5, $6);
    }
    return pack("nCCCCCCCCC", $y, $m, $d, $H, $M, $S, 0, 0, 0, 0);
}
sub dat_decode ($$) {
    my ($self, $bin) = @_;
    my ($y, $m, $d, $H, $M, $S) = unpack("nCCCCCCCCC", $bin);
    return sprintf("%04d-%02d-%02d %02d:%02d:%02d", $y, $m, $d, $H, $M, $S);
}

#   snmpd(8) pass_persist protocol 'octet' encoding/decoding
sub octet_encode ($$) {
    my ($self, $bin) = @_;
    my $asc = '';
    $bin =~ s|(.)|$asc .= sprintf("%02x ", ord($1)), ''|sge;
    return $asc;
}
sub octet_decode ($$) {
    my ($self, $asc) = @_;
    my $bin = '';
    $asc =~ s|([0-9a-zA-Z]{2})\s*|$bin .= chr(hex($1)), ''|sge;
    return $bin;
}

##  _________________________________________________________________________
##
##  MAIN PROCEDURE
##  _________________________________________________________________________
##

package main;

#   find path to ourself
my $myroot = "$FindBin::Bin";

#   parameters (defaults)
my $opt = {
    'config'    => "$myroot/snmpdx.cfg",
    'version'   => 0,
    'help'      => 0,
    'tmpdir'    => ($ENV{TMPDIR} || $ENV{TEMPDIR} || "/tmp"),
    'get'       => 0,
    'next'      => 0,
    'set'       => 0,
    'bindir'    => "/cw/bin",
    'probedir'  => "$myroot/snmpdx.d",
    'probename' => "*",
    'mibdir'    => "$myroot/snmpdx.mib",
    'mibname'   => "snmpdx",
    'logfile'   => "$myroot/snmpdx.log",
    'loglevel'  => 9,
    'strict'    => 0,
};

#   command line parsing
my %options = (
    'c|config=s'    => \$opt->{'config'},
    'V|version'     => \$opt->{'version'},
    'h|help'        => \$opt->{'help'},
    't|tmpdir=s'    => \$opt->{'tmpdir'},
    'g|get'         => \$opt->{'get'},
    'n|next'        => \$opt->{'next'},
    's|set'         => \$opt->{'set'},
    'b|bindir=s'    => \$opt->{'bindir'},
    'P|probedir=s'  => \$opt->{'probedir'},
    'p|probename=s' => \$opt->{'probename'},
    'M|mibdir=s'    => \$opt->{'mibdir'},
    'm|mibname=s'   => \$opt->{'mibname'},
    'l|logfile=s'   => \$opt->{'logfile'},
    'L|loglevel=i'  => \$opt->{'loglevel'},
    'S|strict'      => \$opt->{'strict'},
);
Getopt::Long::Configure("bundling");
my $result = GetOptions(%options) || die "option parsing failed";
if ($opt->{'help'}) {
    print "Usage: $prg->{'name'} [options] [SPECFILE ...]\n" .
          "Available options:\n" .
          " -c,--config=PATH    read command line options from configuration fil\n" .
          " -V,--version        print program version\n" .
          " -h,--help           print out this usage page\n" .
          " -t,--tmpdir=PATH    filesystem path to temporary directory\n" .
          " -g,--get            get value of this MIB OID\n" .
          " -n,--next           get value of next MIB OID\n" .
          " -s,--set            set value of next MIB OID (NOT IMPLEMENTED)\n" .
          " -b,--bindir=PATH    path to the net-snmp binaries\n" .
          " -P,--probedir=PATH  path to probe directory\n" .
          " -p,--probename=NAME the pattern for probes to load\n" .
          " -M,--mibdir=PATH    path to MIB directory\n" .
          " -m,--mibname=MIB    the name of the MIB to act under\n" .
          " -l,--logfile=PATH   path to daemon logfile\n" .
          " -L,--loglevel=NUM   logging level (0...9)\n" .
          " -S,--strict         strict processing of unknown values\n";
    exit(0);
}
if ($opt->{'version'}) {
    print "$prg->{'name'} $prg->{'version'} ($prg->{'date'})\n";
    exit(0);
}

#   support external configuration file
if (-f $opt->{'config'}) {
    my $cfg = new IO::File "<$opt->{'config'}";
    my $line;
    while (defined($line = $cfg->getline())) {
        $line =~ s|\r?\n$||s;
        next if ($line =~ m/^\s*(#.*)?$/s);
        my ($option, $value) = ($line =~ m|^\s*(\S+)\s+(.+?)\s*$|s);
        die "invalid configuration line \"$line\""
            if (not defined($option) or not defined($value));
        my ($var) = map  { $options{$_} } 
                    grep { $_ =~ m/^.\|\Q$option\E(=[si])?$/s }
                    keys(%options);
        die "invalid configuration option \"$option\""
            if (not defined($var));
        ${$var} = $value;
    }
    $cfg->close;
}

#   create daemon run-time context
my $ctx = {};
$ctx->{-prg}      = $prg;
$ctx->{-opt}      = $opt;
$ctx->{-log}      = new My::Log ($opt->{'loglevel'}, $opt->{'logfile'});
$ctx->{-cache}    = new My::Cache;
$ctx->{-sys}      = new My::System ($ctx->{-log}, $ctx->{-cache});
$ctx->{-platform} = new My::Platform;
$ctx->{-mib}      = new My::MIB ($opt->{'bindir'}, $opt->{'mibdir'}, $opt->{'mibname'});
$ctx->{-enc}      = new My::Enc;

#   startup information
$ctx->{-log}->printf(1, "startup %s %s (%s) on %s",
    $prg->{'name'}, $prg->{'version'}, $prg->{'date'},
    $ctx->{-platform}->id());

#   exception handling support 
$SIG{__DIE__} = sub {
    my ($err) = @_;
    $err =~ s|\r?\n$||s;
    $ctx->{-log}->printf(1, "ERROR: $err ". ($! ? "($!)" : ""));
    undef $ctx;
    exit(1);
};
$SIG{__WARN__} = sub {
    my ($err) = @_;
    $err =~ s|\r?\n$||s;
    $ctx->{-log}->printf(1, "WARNING: $err");
    return;
};

#   PROTOCOL   MIB        MIB TYPE            net-snmp API   CONVERT TYPE
#   ---------- ---------- ------------------- -------------- ------- ------
#   string     SNMPv2-TC  DisplayString       ASN_OCTET_STR  -       char *
#   integer    ASN.1      Integer32           ASN_INTEGER    strtol  long
#   unsigned   SNMPv2-SMI Unsigned32          ASN_UNSIGNED   strtoul long
#   counter    SNMPv2-SMI Counter32           ASN_COUNTER    strtoul long
#   octet      ASN.1      OCTET STRING        ASN_OCTET_STR  asc2bin char *
#   opaque     SNMPv2-SMI Opaque              ASN_OPAQUE     asc2bin char *
#   gauge      SNMPv2-SMI Gauge32             ASN_GAUGE      strtoul long
#   objectid   ASN.1      OBJECT IDENTIFIER   ASN_OBJECT_ID  -       char *
#   timetick   SNMPv2-SMI TimeTicks           ASN_TIMETICKS  strtoul long
#   ipaddress  SNMPv2-SMI IpAddress           ASN_IPADDRESS  htonl   long
#   octet      SNMPv2-TC  DateAndTime         ASN_OCTET_STR  asc2bin char *

#   load probes and determine their handled OIDs
my $oidtable   = [];
my $oidhandler = {};
my $oidprobe   = {};
my $oidtype    = {
    'DisplayString'      => [ 'string',    'N.A.'    ],
    'Integer32'          => [ 'integer',   '-1'      ],
    'Unsigned32'         => [ 'unsigned',  '0'       ],
    'Counter32'          => [ 'counter',   '-1'      ],
    'OCTET STRING'       => [ 'octet',     'N.A.'    ],
    'Opaque'             => [ 'opaque',    'N.A.'    ],
    'Gauge32'            => [ 'gauge',     '-1'      ],
    'OBJECT IDENTIFIER'  => [ 'objectid',  '.0'      ],
    'TimeTicks'          => [ 'timetick',  '0'       ],
    'IpAddress'          => [ 'ipaddress', '0.0.0.0' ],
    'DateAndTime'        => [ 'octet',     $ctx->{-enc}->dat_encode("1970-01-01 01:02:03") ],
};
$ctx->{-log}->printf(1, "MIB id: %s", $opt->{'mibname'});
foreach my $probefile (glob($opt->{'probedir'}."/".$opt->{'probename'}.".pm")) {
    my $probe = $probefile;
    $probe =~ s|^.*/([^/]+)\.pm$|$1|sg;
    my $p;
    eval {
        local $SIG{__DIE__} = 'DEFAULT';
        eval "require \"$probefile\";";
        die if ($@);
        eval "\$p = new My::Probe::$probe (\$ctx);";
        die if ($@);
    };
    if ($@) {
        die "invalid probe \"$probe\": $@";
    }
    $ctx->{-log}->printf(2, "Probe: \"%s\"", $probe);
    foreach my $oid (sort(@{$p->oids()})) {
        push(@{$oidtable}, $oid);
        $oidhandler->{$oid} = $p;
        $oidprobe->{$oid} = $probe;
        $ctx->{-log}->printf(1, "MIB OID: %s [%s] ::= %s (%s)",
            $oid, $ctx->{-mib}->oid2name($oid),
            $ctx->{-mib}->oid2type($oid),
            $oidtype->{$ctx->{-mib}->oid2type($oid)}->[0]);
    }
}
@{$oidtable} = sort(@{$oidtable});

#   determine run-time mode
my $mode = "pass_persist";
if ($opt->{'get'} or $opt->{'next'} or $opt->{'set'}) {
    $mode = "pass";
}

#   connect I/O channels
my $stdin = new IO::Handle;;
$stdin->fdopen(fileno(STDIN), "r");
$stdin->blocking(1);
my $stdout = new IO::Handle;;
$stdout->fdopen(fileno(STDOUT), "w");
$stdout->autoflush(1);
open(STDERR, ">/dev/null");

#   processing loop
while (1) {
    #   determine command
    my $cmd;
    if ($mode eq "pass_persist") {
        #   read next command from snmpd
        $cmd = $stdin->getline;
        if (not defined($cmd)) {
            $ctx->{-log}->printf(4, "IO: EOF");
                last;
        }
        $cmd =~ s|\n?$||s;
        $ctx->{-log}->printf(4, "IO: recv: << \"%s\\n\"", $cmd);
    }
    else {
        $cmd = ($opt->{'get'}  ? 'get'     :
               ($opt->{'next'} ? 'getnext' :
               ($opt->{'set'}  ? 'set'     : 'unknown')));
        $ctx->{-log}->printf(4, "CMD: \"%s\\n\"", $cmd);
    }

    #   act upon command
    if ($cmd =~ m/^PING$/i) {
        #
        #   the PING/PONG protocol part
        #
        $ctx->{-log}->printf(4, "IO: send: >> \"PONG\\n\"");
        $stdout->printf("PONG\n");
    }

    elsif ($cmd =~ m/^GET$/i or $cmd =~ m/^GETNEXT$/i) {
        #
        #   the GET/GETNEXT protocol part
        #
        my $error = 1;

        #   read requested OID
        my $oid_request;
        if ($mode eq "pass") {
            $oid_request = $ARGV[0];
        }
        else {
            $oid_request = $stdin->getline;
            if (not defined($oid_request)) {
                $ctx->{-log}->printf(1, "ERROR: EOF instead of OID");
                goto ERROR;
            }
            $oid_request =~ s|\n?$||s;
        }
        $ctx->{-log}->printf(4, "IO: recv: << \"%s\\n\"", $oid_request);
        if ($oid_request !~ m/^(\.\d+)+$/) {
            $ctx->{-log}->printf(1, "ERROR: invalid query OID \"%s\"", $oid_request);
            goto ERROR;
        }

        #  re-entry point for OID processing
        my $oid_search = $oid_request;
        RETRY:

        #   determine acted/handled OID
        my $oid_action  = undef;
        my $oid_handled = undef;
        my $oid_handler = undef;
        my $oid_next    = undef;
        if ($cmd =~ m/^GET$/i) {
            #   search for explicitly handled OID
            for (my $i = 0; defined($oidtable->[$i]); $i++) {
                if ($oidtable->[$i] eq $oid_search) {
                    $oid_action  = $oidtable->[$i];
                    $oid_handled = $oidtable->[$i];
                    last;
                }
            }
            #   search for implicitly handled OID (sequence element)
            if (not defined($oid_handled)) {
                my $oid_parent = $oid_search;
                $oid_parent =~ s|(\.\d+)$||s;
                for (my $i = 0; defined($oidtable->[$i]); $i++) {
                    if ($oidtable->[$i] =~ m|^\Q$oid_parent\E\.#$|) {
                        $oid_action  = $oid_search;
                        $oid_handled = $oidtable->[$i];
                        last;
                    }
                }
            }
        }
        elsif ($cmd =~ m/^GETNEXT$/i) {
            #   search for explicitly handled OID
            for (my $i = 0; defined($oidtable->[$i]); $i++) {
                if ($oidtable->[$i] =~ m|^\Q$oid_search\E(\.\d+)+$|) {
                    #   OID starts with requested OID prefix, so use this OID
                    $oid_action  = $oidtable->[$i];
                    $oid_handled = $oidtable->[$i];
                    $oid_next    = $oidtable->[$i+1];
                    last;
                }
                elsif ($oidtable->[$i] eq $oid_search) {
                    #   OID is the requested OID exactly, so use next OID
                    if (defined($oidtable->[$i+1])) {
                        $oid_action  = $oidtable->[$i+1];
                        $oid_action  =~ s|\.#$|.1|s;
                        $oid_handled = $oidtable->[$i+1];
                        $oid_next    = $oidtable->[$i+2];
                        last;
                    }
                    else {
                        goto ERROR; # end-of-MIB
                    }
                }
            }
            #   search for implicitly handled OID (sequence element)
            if (not defined($oid_handled)) {
                my $oid_parent = $oid_search;
                $oid_parent =~ s|(\.\d+)$||s;
                for (my $i = 0; defined($oidtable->[$i]); $i++) {
                    #   search for implicitly handled OID (sequence element)
                    if ($oidtable->[$i] =~ m|^\Q$oid_search\E(\.\d+)*\.#$|) {
                        #   OID start with requested OID prefix, so use first OID in sequence
                        $oid_action  = $oidtable->[$i];
                        $oid_action  =~ s|\.#$|.1|s;
                        $oid_handled = $oidtable->[$i];
                        $oid_next    = $oidtable->[$i+1];
                        last;
                    }
                    elsif ($oidtable->[$i] =~ m|^\Q$oid_parent\E\.#$|) {
                        #   OID is the requested OID of a sequence exactly, so use next OID in sequence
                        $oid_action  = $oid_search;
                        $oid_action  =~ s|\.(\d+)$|".".($1+1)|se;
                        $oid_handled = $oidtable->[$i];
                        $oid_next    = $oidtable->[$i+1];
                        last;
                    }
                }
            }
        }
        if (defined($oid_handled)) {
            $oid_handler = $oidhandler->{$oid_handled};
        }
        else {
            $ctx->{-log}->printf(1, "ERROR: no handler found for OID \"%s\"", $oid_request);
            goto ERROR; # end-of-MIB
        }

        #   prepare probe request object
        my $obj = {
            -oid   => $oid_action,
            -name  => $ctx->{-mib}->oid2name($oid_handled),
            -type  => $ctx->{-mib}->oid2type($oid_handled),
            -value => undef
        };

        #   provide mixed name/OID for sequence index
        if ($obj->{-name} =~ m|\.#$|) {
            my ($idx) = ($obj->{-oid} =~ m|\.(\d+)$|);
            $obj->{-name} =~ s|\.#$|.$idx|;
        }

        #   probe value of OID
        $ctx->{-log}->printf(2, "probing \"%s\" for OID \"%s\"", $oidprobe->{$oid_handled}, $oid_action);
        $oid_handler->probe($obj);

        #   handle special "unknown OID value" situation
        if (not defined($obj->{-value})) {
            $ctx->{-log}->printf(1, "WARNING: handler was unable to provide probe value for OID \"%s\"", $oid_request);
            if ($opt->{'strict'}) {
                #   strict processing: return ERROR on unknown value
                #   for GET request and skip unknown OIDs on GETNEXT.
                if ($cmd =~ m/^GET$/i) {
                    goto ERROR; # no-value
                }
                else { # GETNEXT
                    if (defined($oid_next)) {
                        $oid_search = $oid_next;
                        $oid_search =~ s|\.#$||s;
                        goto RETRY;
                    }
                    else {
                        goto ERROR; # no-value
                    }
                }
            }
            else {
                #   non-strict processing: return a reasonable default value
                if ($oid_handled =~ m|\.#$|) {
                    if ($oid_action =~ m|\.1$|) {
                        $obj->{-value} = $oidtype->{$obj->{-type}}->[1];
                    }
                    else {
                        if (defined($oid_next)) {
                            $oid_search = $oid_next;
                            $oid_search =~ s|\.#$||s;
                            goto RETRY;
                        }
                        else {
                            goto ERROR; # end-of-MIB
                        }
                    }
                }
                else {
                    $obj->{-value} = $oidtype->{$obj->{-type}}->[1];
                }
            }
        }

        #   optionally encode value to conform to snmpd(8) protocol
        if ($oidtype->{$obj->{-type}}->[0] =~ m/^(octet|opaque)$/) {
            $obj->{-value} = $ctx->{-enc}->octet_encode($obj->{-value});
        }

        #   return result
        $ctx->{-log}->printf(1, "QUERY: %s [%s] ::= %s \"%s\"",
            $obj->{-name}, $obj->{-oid}, $obj->{-type}, $obj->{-value});
        $stdout->printf("%s\n%s\n%s\n",
            $obj->{-oid}, $oidtype->{$obj->{-type}}->[0], $obj->{-value});
        $ctx->{-log}->printf(4, "IO: send: >> \"%s\\n%s\\n%s\\n\"",
            $obj->{-oid}, $oidtype->{$obj->{-type}}->[0], $obj->{-value});

        #   end-of-MIB or no-value handling
        $error = 0;
        if ($error) {
            ERROR:
            if ($mode eq "pass_persist") {
                $ctx->{-log}->printf(4, "IO: send: >> \"NONE\\n\"");
                $stdout->printf("NONE\n");
            }
        }
    }
    elsif ($cmd =~ m/^SET$/i) {
        #
        #   the SET protocol part
        #
        if ($mode eq "pass_persist") {
            #   read requested OID/TYPE/VALUE (and ignore)
            my $oid       = $stdin->getline;
            my $oid_type  = $stdin->getline;
            my $oid_value = $stdin->getline;
            $ctx->{-log}->printf(4, "IO: send: >> \"NONE\\n\"");
            $stdout->printf("NONE\n");
        }
        else {
            $ctx->{-log}->printf(4, "IO: send: >> \"not-writable\\n\"");
            $stdout->printf("not-writable\n");
        }
    }
    else {
        #   for anything else (not expected) just send at least
        #   "NONE" in case snmpd(8) expects something.
        $ctx->{-log}->printf(4, "IO: send: >> \"NONE\\n\"");
        $stdout->printf("NONE\n");
    }

    #   stop processing on "pass" mode
    last if ($mode eq "pass");
}

#   shutdown gracefully
$ctx->{-log}->printf(1, "shutdown");
undef $ctx;
exit(0);