SNMP::Extension::PassPersist - Generic pass/pass_persist extension framework

    use strict;
    use SNMP::Extension::PassPersist;

    # create the object
    my $extsnmp = SNMP::Extension::PassPersist->new;

    # add a few OID entries
    $extsnmp->add_oid_entry($oid, $type, $value);
    $extsnmp->add_oid_entry($oid, $type, $value);

    # run the program
    $extsnmp->run;

    use strict;
    use SNMP::Extension::PassPersist;

    my $extsnmp = SNMP::Extension::PassPersist->new(
        backend_collect => \&update_tree
    );
    $extsnmp->run;




    sub update_tree {
        my ($self) = @_;

        # add a serie of OID entries
        $self->add_oid_entry($oid, $type, $value);
        ...

        # or directly add a whole OID tree
        $self->add_oid_tree(\%oid_tree);
    }

    my $extsnmp = SNMP::Extension::PassPersist->new;

    my $extsnmp = SNMP::Extension::PassPersist->new(
        backend_collect => \&update_tree,
        idle_count      => 10,      # no more than 10 idle cycles
        refresh         => 10,      # refresh every 10 sec
    );

    dispatch => {
        SNMP_CMD  =>  { nargs => NUMBER_ARGS,  code => CODEREF },
        ...
    }

    oid_tree => {
        FUNC_OID  =>  [ FUNC_TYPE, FUNC_VALUE ],
        ...
    }

    my $extsnmp = SNMP::Extension::PassPersist->new(
        backend_collect => \&update_tree,
    );

    sub update_tree {
        my ($self) = @_;

        # fetch the number of running processes
        my $nb_proc = @{ Proc::ProcessTable->new->table };

        $self->add_oid_entry("1.3.6.1.4.1.32272.10", gauge", $nb_proc);
    }

    my $extsnmp = SNMP::Extension::PassPersist->new(
        backend_init    => \&connect_db,
        backend_collect => \&update_tree,
    );

    sub connect_db {
        my ($self) = @_;
        my $heap = $self->heap;

        # connect to a database
        my $dbh = DBI->connect($dsn, $user, $password);
        $heap->{dbh} = $dbh;
    }

    sub update_tree {
        my ($self) = @_;
        my $heap = $self->heap;

        # fetch the number of records from a given table
        my $dbh = $heap->{dbh};
        my $sth = $dbh->prepare_cached("SELECT count(*) FROM whatever");
        $sth->execute;
        my ($count) = $sth->fetchrow_array;

        $self->add_oid_entry("1.3.6.1.4.1.32272.20", "gauge", $count);
    }

    perldoc SNMP::Extension::PassPersist

package SNMP::Extension::PassPersist;
use strict;
use warnings;

use parent qw<Class::Accessor>;

use Carp;
use Getopt::Long;
use File::Basename;
use IO::Handle;
use IO::Pipe;
use IO::Select;
use List::MoreUtils qw<any>;
use Storable            qw< nfreeze thaw >;
use Sys::Syslog;


{
    no strict "vars";
    $VERSION = '0.05';
}

use constant HAVE_SORT_KEY_OID
                    => eval "use Sort::Key::OID 0.04 qw<oidsort>; 1" ? 1 : 0;


# early initialisations --------------------------------------------------------
my @attributes = qw<
    backend_collect
    backend_fork
    backend_init
    backend_pipe
    heap
    idle_count
    input
    oid_tree
    sorted_entries
    output
    refresh
    dispatch
>;

__PACKAGE__->mk_accessors(@attributes);


# constants --------------------------------------------------------------------
use constant SNMP_NONE                  => "NONE";
use constant SNMP_PING                  => "PING";
use constant SNMP_PONG                  => "PONG";
use constant SNMP_GET                   => "get";
use constant SNMP_GETNEXT               => "getnext";
use constant SNMP_SET                   => "set";
use constant SNMP_NOT_WRITABLE          => "not-writable";
use constant SNMP_WRONG_TYPE            => "wrong-type";
use constant SNMP_WRONG_LENGTH          => "wrong-length";
use constant SNMP_WRONG_VALUE           => "wrong-value";
use constant SNMP_INCONSISTENT_VALUE    => "inconsistent-value";


# global variables -------------------------------------------------------------
my %snmp_ext_type = (
    counter     => "counter",
    gauge       => "gauge",
    integer     => "integer",
    ipaddr      => "ipaddress",
    ipaddress   => "ipaddress",
    netaddr     => "ipaddress",
    objectid    => "objectid",
    octetstr    => "string",
#   opaque      => "opaque",
    string      => "string",
    timeticks   => "timeticks",
);



#
# new()
# ---
sub new {
    my ($class, @args) = @_;
    my %attrs;
    my $ref = ref $args[0];

    # see how arguments were passed
    if ($ref and $ref eq "HASH") {
        %attrs = %{$args[0]};
    }
    else {
        croak "error: Don't know how to handle \L$ref reference" if $ref;
        croak "error: Odd number of arguments"  if @args % 2 == 1;
        %attrs = @args;
    }

    # filter out unknown attributes
    my %known_attr;
    @known_attr{@attributes} = (1) x @attributes;
    !$known_attr{$_} && delete $attrs{$_} for keys %attrs;

    # check that code attributes are coderefs
    for my $code_attr (qw<backend_init backend_collect>) {
        croak "error: Attribute $code_attr must be a code reference"
            if defined $attrs{$code_attr} and ref $attrs{$code_attr} ne "CODE";
    }

    # default values
    %attrs = (
        backend_collect => sub {},
        backend_fork    => 0,
        backend_init    => sub {},
        heap            => {},
        input           => \*STDIN,
        output          => \*STDOUT,
        oid_tree        => {},
        sorted_entries  => [],
        idle_count      => 5,
        refresh         => 10,
        dispatch        => {
            lc(SNMP_PING)    => { nargs => 0,  code => \&ping        },
            lc(SNMP_GET)     => { nargs => 1,  code => \&get_oid     },
            lc(SNMP_GETNEXT) => { nargs => 1,  code => \&getnext_oid },
            lc(SNMP_SET)     => { nargs => 2,  code => \&set_oid     },
        },
        %attrs,
    );

    # create the object with Class::Accessor
    my $self = $class->SUPER::new(\%attrs);

    return $self
}


#
# run()
# ---
sub run {
    my ($self) = @_;

    # process command-line arguments
    Getopt::Long::Configure(qw<no_auto_abbrev no_ignore_case>);
    GetOptions(\my %options, qw<get|g=s  getnext|n=s  set|s=s>)
        or croak "fatal: An error occured while processing runtime arguments";

    my $name = $::COMMAND || basename($0);
    openlog($name, "ndelay,pid", "local0");

    my ($mode_pass, $mode_passpersist);
    my $backend_fork = $self->backend_fork;

    # determine the run mode
    if (any { defined $options{$_} } "get", "getnext", "set") {
        $mode_pass          = 1;
        $mode_passpersist   = 0;
    }
    else {
        $mode_pass          = 0;
        $mode_passpersist   = 1;
    }

    # execute the init and collect callback once, except in the case
    # where the backend run in a separate process
    unless ($mode_passpersist and $backend_fork) {
        # initialise the backend
        eval { $self->backend_init->($self); 1 }
            or croak "fatal: An error occurred while executing the backend "
                    ."initialisation callback: $@";

        # collect the information
        eval { $self->backend_collect->($self); 1 }
            or croak "fatal: An error occurred while executing the backend "
                    ."collecting callback: $@";
    }

    # Net-SNMP "pass" mode
    if ($mode_pass) {
        for my $op (qw<get getnext set>) {
            if ($options{$op}) {
                my @args = split /,/, $options{$op};
                my $coderef = $self->dispatch->{$op}{code};
                my @result = $coderef->($self, @args);
                $self->output->print(join $/, @result, "");
            }
        }
    }
    # Net-SNMP "pass_persist" mode
    else {
        my $needed  = 1;
        my $delay   = $self->refresh;
        my $counter = $self->idle_count;
        my ($pipe, $child);

        # if the backend is to be run in a separate process,
        # create a pipe and fork
        if ($backend_fork) {
            $pipe = IO::Pipe->new;
            $self->backend_pipe($pipe);

            $child = fork;
            my $msg = "fatal: can't fork: $!";
            syslog err => $msg and die $msg
                unless defined $child;

            # child setup is handled in run_backend_loop()
            goto &run_backend_loop if $child == 0;

            # parent setup
            $pipe->reader;  # declare this end of the pipe as the reader
            $pipe->autoflush(1);
        }

        my $io = IO::Select->new;
        $io->add($self->input);
        $self->output->autoflush(1);

        if ($backend_fork) {
            $io->add($pipe);
            $SIG{CHLD} = sub { $io->remove($pipe); waitpid($child, 0); };
        }


        # main loop
        while ($needed and $counter > 0) {
            my $start_time = time;

            # wait for some input data
            my @ready = $io->can_read($delay);

            for my $fh (@ready) {
                # handle input data from netsnmpd
                if ($fh == $self->input) {
                    if (my $cmd = <$fh>) {
                        $self->process_cmd(lc($cmd), $fh);
                        $counter = $self->idle_count;
                    }
                    else {
                        $needed = 0
                    }
                }

                # handle input data from the backend process
                if ($backend_fork and $fh == $pipe) {
                    use bytes;

                    # read a first chunk from the child
                    $fh->sysread(my $buffer, 20);
                    last unless length $buffer;

                    # extract the header
                    my $headline= substr($buffer, 0, index($buffer, "\n")+1, "");
                    chomp $headline;
                    my %header  = map { split /=/, $_, 2 } split /\|/, $headline;

                    # read the date in Storable format
                    my $length  = $header{length};
                    $fh->sysread(my $freezed, $length);
                    $freezed    = $buffer.$freezed;

                    # decode the freezed data
                    my $struct  = thaw($freezed);
                    $self->add_oid_tree($struct);
                }
            }

            $delay = $delay - (time() - $start_time);

            if ($delay <= 0) {
                if (not $backend_fork) {
                    # collect information when the timeout has expired
                    eval { $self->backend_collect->($self); 1 }
                        or croak "fatal: An error occurred while executing "
                                ."the backend collecting callback: $@";
                }

                # reset delay
                $delay = $self->refresh;
                $counter--;
            }
        }

        if ($backend_fork) {
            kill TERM => $child;
            sleep 1;
            kill KILL => $child;
            waitpid($child, 0);
        }
    }
}


#
# run_backend_loop()
# ----------------
sub run_backend_loop {
    my ($self) = @_;

    my $pipe = $self->backend_pipe;
    $pipe->writer;  # declare this end of the pipe as the writer
    $pipe->autoflush(1);

    # execute the initialisation callback
    eval { $self->backend_init->($self); 1 }
        or croak "fatal: An error occurred while executing the backend "
                ."initialisation callback: $@";

    while (1) {
        my $start_time = time;

        # execute the collect callback
        eval { $self->backend_collect->($self); 1 }
            or croak "fatal: An error occurred while executing the backend "
                    ."collecting callback: $@";

        # freeze the OID tree using Storable
        use bytes;
        my $freezed = nfreeze($self->oid_tree);
        my $length  = length $freezed;
        my $output  = "length=$length\n$freezed";

        # send it to the parent via the pipe
        $pipe->syswrite($output);
        select(undef, undef, undef, .000_001);

        # wait before next execution
        my $delay = $self->refresh() - (time() - $start_time);
        sleep $delay;
    }
}


#
# add_oid_entry()
# -------------
sub add_oid_entry {
    my ($self, $oid, $type, $value) = @_;

    croak "error: Unknown type '$type'" unless exists $snmp_ext_type{$type};
    $self->oid_tree->{$oid} = [$type => $value];

    # need to resort
    @{$self->sorted_entries} = ();

    return 1
}


#
# add_oid_tree()
# ------------
sub add_oid_tree {
    my ($self, $new_tree) = @_;

    croak "error: Unknown type"
        if any { !$snmp_ext_type{$_->[0]} } values %$new_tree;
    my $oid_tree = $self->oid_tree;
    @{$oid_tree}{keys %$new_tree} = values %$new_tree;

    # need to resort
    @{$self->sorted_entries} = ();

    return 1
}


#
# dump_oid_tree()
# -------------
sub dump_oid_tree {
    my ($self) = @_;

    my $oid_tree = $self->oid_tree;
    my $output   = $self->output;

    for my $oid (sort by_oid keys %$oid_tree) {
        my ($type, $value) = @{ $oid_tree->{$oid} };
        $output->print("$oid ($type) = $value\n");
    }
}


#
# ping()
# ----
sub ping {
    return SNMP_PONG
}


#
# get_oid()
# -------
sub get_oid {
    my ($self, $req_oid) = @_;

    my $oid_tree = $self->oid_tree;
    my @result = ();

    if ($oid_tree->{$req_oid}) {
        my ($type, $value) = @{ $oid_tree->{$req_oid} };
        @result = ($req_oid, $type, $value);
    }
    else {
        @result = (SNMP_NONE)
    }

    return @result
}


#
# getnext_oid()
# -----------
sub getnext_oid {
    my ($self, $req_oid) = @_;

    my $next_oid = $self->fetch_next_entry($req_oid)
                || $self->fetch_first_entry();

    return $self->get_oid($next_oid)
}


#
# set_oid()
# -------
sub set_oid {
    my ($self, $req_oid, $value) = @_;
    return SNMP_NOT_WRITABLE
}


# 
# process_cmd()
# -----------
# Process and dispatch Net-SNMP commands when in pass_persist mode.
# 
sub process_cmd {
    my ($self, $cmd, $fh) = @_;
    my @result = ();

    chomp $cmd;
    my $dispatch = $self->dispatch;

    if (exists $dispatch->{$cmd}) {

        # read the command arguments
        my @args = ();
        my $n    = $dispatch->{$cmd}{nargs};

        while ($n-- > 0) {
            chomp(my $arg = <$fh>);
            push @args, $arg;
        }

        # call the command handler
        my $coderef = $dispatch->{$cmd}{code};
        @result = $coderef->($self, @args);
    }
    else {
        @result = SNMP_NONE;
    }

    # output the result
    $self->output->print(join $/, @result, "");
}


#
# fetch_next_entry()
# ----------------
sub fetch_next_entry {
    my ($self, $req_oid) = @_;

    my $entries = $self->sorted_entries;

    if (!@$entries) {
        @$entries = HAVE_SORT_KEY_OID
            ? oidsort(keys %{ $self->oid_tree })
            : sort by_oid keys %{ $self->oid_tree };
    }

    # find the index of the current entry
    my $curr_entry_idx = -1;

    for my $i (0..$#$entries) {
        # exact match of the requested entry
        $curr_entry_idx = $i and last if $entries->[$i] eq $req_oid;

        # prefix match of the requested entry
        $curr_entry_idx = $i - 1 and last
            if $curr_entry_idx == -1 and index($entries->[$i], $req_oid) >= 0;
    }

    # get the next entry if it exists, otherwise none
    my $next_entry_oid = $entries->[$curr_entry_idx + 1] || SNMP_NONE;

    return $next_entry_oid
}


#
# fetch_first_entry()
# -----------------
sub fetch_first_entry {
    my ($self) = @_;

    my $entries = $self->sorted_entries;

    if (!@$entries) {
        @$entries = HAVE_SORT_KEY_OID
            ? oidsort(keys %{ $self->oid_tree })
            : sort by_oid keys %{ $self->oid_tree };
    }
    my $first_entry_oid = $entries->[0];

    return $first_entry_oid
}


# 
# by_oid()
# ------
# sort() sub-function, for sorting by OID
#
sub by_oid ($$) {
    my (undef, @a) = split /\./, $_[0];
    my (undef, @b) = split /\./, $_[1];
    my $v = 0;
    $v ||= $a[$_] <=> $b[$_] for 0 .. $#a;
    return $v
}


32272

__END__