#!/usr/bin/perl -w
# n e t  d i s c o
# Created for UCSC
# Changes from 0.92 on (C)2003-2005 Max Baker - All rights Reserved.
# (C) 2002,2003 UC Regents.  See bottom of this file.
# $Id: netdisco,v 1.113 2006/11/28 19:19:04 fenner Exp $

=head1 NAME

netdisco - Internal API

=head1 DESCRIPTION

This is the inside guts of the Netdisco executable.  You should be looking in 
README for how to use Netdisco.

=cut

use strict;
use Getopt::Long;
use FindBin;             # Add this directory for netdisco.pm
use lib $FindBin::Bin;
use IO::File;            # For batch_mode()
use POSIX qw/:errno_h/;  # for Admin Daemon
use netdisco qw/:all/;  
tryuse('SNMP::Info', ver => '1.0', die => 1);

$| = 1;

# Signal Handlers
$SIG{INT}  = \&end_int_handler;
$SIG{ALRM} = \&timeout;

# --------------------------------------------------------------
#                         Globals                               
# --------------------------------------------------------------
use vars qw/$DEBUG %CONFIG %Discovered %Discovered_Alias @Discover_Queue %NoCDP %UnDiscovered
            %TimedOut $Aliases $OldDevices $OldNodes $PortMAC $start_time $end_time $ArpTotal $NbtTotal %MacSeen
            $MacTotal @OldSTDOUT @LogFH @LogFile %DeviceTopo %args $configfile $BatchMode $Log
            $New_Only $VERSION $DaemonMode/;

$VERSION = '0.95';
%Discovered = ();
%Discovered_Alias = ();
@Discover_Queue = ();
%NoCDP = ();
%UnDiscovered = ();
%TimedOut = ();
$Aliases = undef;
$OldDevices = undef;
$PortMAC = undef;
$DaemonMode=$start_time=$end_time=0;
$ArpTotal = 0;
$NbtTotal = undef;
%MacSeen = ();
$MacTotal = 0; 
@OldSTDOUT = ();
@LogFH     = ();
@LogFile   = ();
%DeviceTopo = ();

# --------------------------------------------------------------
#              Command Line Flags                               
# --------------------------------------------------------------
Getopt::Long::Configure('no_ignore_case');
GetOptions(\%args,'a|arpwalk',
                  'A|arpnip=s',
                  'b|batchmode',
                  'B|backup',
                  'C|configfile=s',
                  'd|discover=s',
                  'D|debug',
                  'e|expirenodes=s',
                  'E|expiredevice=s',
                  'expire-nodes-subnet=s',
                  'F|discoverfile=s',
                  'g|graph',
                  'h|help',
                  'I|expireips',
                  'i|changeip=s',
                  'k|cleanalias',
                  'K|cleannodes',
                  'L|nologging',
                  'm|macwalk',
                  'M|macsuck=s',
                  'n|nodestoo',
                  'N|newonly',
                  'O|oui',
                  'P|port=s',
                  'p|daemon=s',
                  'r|discoverall=s',
                  'S|dumpsql',
                  'R|refresh',
                  't|test',
                  'T|topofile',
                  'u|user',
                  'v|version|ver',
                  'V|archive',
                  'w|nbtwalk',
                  'W|nbtstat=s',
          );
$DEBUG             = $args{D} || 0;
$netdisco::SQLCARP = $args{S} || 0;
$BatchMode         = $args{b} || 0;
$New_Only          = $args{N} || 0;
$Log               = $BatchMode && !defined $args{L};

# Allow the -h or -v commands to run no matter what
defined $args{h} and &usage;
defined $args{v} and &version;

# Print Header
&header if (grep(/^([aABdeEFgIikKmMOprRTu]|expire-nodes-subnet)$/,keys %args) and !$BatchMode);

# Parse Config File - Check for -C, then in current dir, then in default dir.
foreach my $c ($args{C},"$FindBin::Bin/netdisco.conf",'/usr/local/netdisco/netdisco.conf') {
    if (defined $c and -r $c){
        $configfile = $c;
        print "Using Config File : $configfile\n" if $DEBUG;
        last;
    }
}

unless (defined $configfile){
    print "No Config file found!\n";
    exit;
}

config($configfile);

# --------------------------------------------------------------
#             Run Commands                                      
# --------------------------------------------------------------

#   Discovery
defined $args{R} and &refresh_all;
defined $args{d} and &topo_load_file;
defined $args{d} and &discover($args{d});
defined $args{r} and &run($args{r});
if (defined $args{F} or defined $args{T}) {
    &schlop( defined $args{F} ? $args{F} : homepath('topofile'), 
             defined $args{T}
           );
}

#   Mac Sucking
defined $args{M} and &macsuck($args{M});
defined $args{m} and &macwalk;

#   Arp Nipping
defined $args{a} and &arpwalk;
defined $args{A} and &arpnip($args{A});

#   NetBIOS
defined $args{w} and &nbtwalk;
defined $args{W} and &nbtstat($args{W});

#   Other
defined $args{K} and &db_clean;
defined $args{k} and &alias_clean;
defined $args{g} and &graph;
defined $args{t} and &test;
defined $args{O} and &parse_oui;
defined $args{B} and &nightly;
defined $args{E} and &expire_device($args{E},defined $args{n});
defined $args{e} and &expire_nodes($args{e},defined $args{V},$args{P});
defined $args{I} and &expire_ips;
defined $args{i} and &change_device_ip($args{i},shift @ARGV);
defined $args{p} and &admin_daemon_ctl($args{p});
defined $args{u} and &add_user(@ARGV);
defined $args{'expire-nodes-subnet'} and &expire_nodes_subnet($args{'expire-nodes-subnet'});

# Make sure we ran a command, else spit out the usage
&usage unless ( grep(/^([aABdeEFgiIkKmMnNOprRtTuwW]|expire-nodes-subnet)$/,keys %args) );
exit;

=head1 FUNCTIONS

=head2 Network Discovery

=over

=item discover(host) 

Discovers one device, stores its info, interfaces, and neighbors, and returns.

=cut

sub discover{
    my $hostname = shift;

    print "Discover($hostname) : ";

    my $ip = getip($hostname);
    if (in_device($ip,$CONFIG{discover_no}) ||
        ($CONFIG{discover_only} && !in_device($ip,$CONFIG{discover_only}))) {
        print " Excluded from discovery in config file.\n";
        return;
    }

    my $device = get_device($hostname) or return;
    $ip        = $device->{ip};

    # Store Device Info
    store_device($device);

    # Walk Interfaces
    store_interfaces($device);

    # Walk Modules

    # Walk neighbors
    find_neighbors($device);

    # Manual Topology Info
    topo_add_link( $DeviceTopo{$ip} ) if defined $DeviceTopo{$ip}; 

    $Discovered{ $ip }++;

    foreach my $alias (keys %{$device->{_alias}}){
        next unless defined $alias and length($alias);
        $Discovered_Alias{ $alias }++;
    }
}

=item refresh_all()

Calls discover() for each file already in device table.

=cut

sub refresh_all {
    $start_time = time;

    my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime();
    my $month = sprintf("%d%02d",$year+1900,$mon+1);
    &batch_mode("logs/$month/refresh");

    my $now = localtime();
    print "[Refresh All Devices]  Started at $now. \n";
    &load_old_devices;
    &topo_load_file;

    my $timeout = $CONFIG{timeout};

    foreach my $dev (keys %$OldDevices){
        eval {
            alarm($timeout);
            discover($dev);
            alarm(0); 
        };

        if ($@) {
            if ($@ =~ /timeout/){
                $TimedOut{$dev}++;
                print "\n  ! Device Timed out ($timeout sec)\n";
            } else {
                print "\n$@\n";
            }
        }
    }

    sql_vacuum('device','print'=>1);
    sql_vacuum('device_port','print'=>1);
    sql_vacuum('device_ip','print'=>1);
    &end;

}

=item run() 

Event loop that calls discover() as long as the @Discover_Queue has something in it.

=cut

sub run {
    my $root_device = shift;
    
    my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime();
    my $month = sprintf("%d%02d",$year+1900,$mon+1);
    &batch_mode("discover/$month/discover_net",1);

    print "Network discovery starting from root $root_device at " . localtime() . "\n";

    my $root_dev_ip = &getip($root_device);
    unless (defined $root_dev_ip){
        print "Cannot resolve $root_device to an IP address.\n";
        return;
    }

    # Getting old devices for statistics.
    &load_old_devices;
    topo_load_file();

    $start_time = time;
    push (@Discover_Queue, $root_dev_ip);

    my $timeout = $CONFIG{timeout};

    
    while (my $this_dev = shift @Discover_Queue){ 
        # We've already been here.
        next if defined $Discovered{$this_dev};
        next if defined $Discovered_Alias{$this_dev};

        # We couldn't connect already, dont try again.
        next if defined $UnDiscovered{$this_dev};

        # New Only scan, ignore existing devices
        #   except let us rediscover our target
        next if ( ((defined $OldDevices->{$this_dev} or defined $Aliases->{$this_dev}) and $New_Only)
                  and ($this_dev ne $root_dev_ip)                                               
                );

        # Set time out 
        eval {
            alarm($timeout);
            discover($this_dev);
            alarm(0);   # Cancel alarm if we return in time.
        };

        if ($@) {
            if ($@ =~ /timeout/){
                $TimedOut{$this_dev}++;
                print "\n  ! Device Timed out ($timeout sec)\n";
            } else {
                print "\n$@\n";
            }
        }
    }
    
    print "Network Discovery complete.\n";
    
    sql_vacuum('device','print'=>1);
    sql_vacuum('device_port','print'=>1);
    sql_vacuum('device_ip','print'=>1);

    &end;
    
}

=item schlop(file,topo_only_flag) 

Used to start a discovery based on topography file.  Will then proceed to do an initial mac_suck() and arp_nip() unless the topo_only_flag is set.

=cut

sub schlop {
    my ($file,$topo_only) = @_;
    &batch_mode('discover_file');

    $start_time = time; 
    my $function = "Discovering devices";
    $function = "Discovering only new devices" if ($New_Only);
    $function = "Loading Topology" if ($topo_only);
    print "$function from file: $file...\n";

    &topo_load_file($file);
    &load_old_devices;

    # Add devices
    foreach my $dev (keys %DeviceTopo){
        next if ($New_Only and defined $OldDevices->{$dev});
        last if defined $topo_only and $topo_only;

        my $timeout = defined $CONFIG{timeout} ? $CONFIG{timeout} : 90;

        eval {
            alarm($timeout);
            discover($dev);
            alarm(0);   # Cancel alarm if we return in time.
        };

        if ($@) {
            if ($@ =~ /timeout/){
                $TimedOut{$dev}++;
                print "\n  ! Device Timed out ($timeout sec)\n";
            } else {
                print "\n$@\n";
            }
        }
    }
    
    # Deal with topology info
    foreach my $dev (keys %DeviceTopo){
        topo_add_link($DeviceTopo{$dev}); 
    }

    return if (defined $topo_only and $topo_only);

    # ArpNip and Macsuck newly found devices.
    &load_old_devices;
    &mac_getportmacs;

    foreach my $dev (keys %DeviceTopo){
        $dev = root_device($dev);
        my $layers = $OldDevices->{$dev};
        unless (defined $dev and defined $layers and length($layers)){
            print "  Device $dev not discovered. Skipped.\n";
            next;
        }

        macsuck($dev) if (has_layer($layers,2));
        arpnip($dev)  if (has_layer($layers,3));
    }

    foreach my $dev (@Discover_Queue){
        next if (defined $OldDevices->{$dev} or defined $Aliases->{$dev});
        print "  Found new device: $dev\n";
    }
    &end;
}

=item topo_add_link([{},{}])

Pass reference to array of hash references holding link: lines from 
manual topology info.  Adds information to device_port table.

=cut

sub topo_add_link {
    my $links = shift;

    foreach my $link (@$links){
        next unless defined $link;

        unless ( defined $link->{from} and 
                 defined $link->{from_port} and
                 defined $link->{to} and
                 defined $link->{to_port} ) {
            print "  topo_add_link() - Bad link! ", join(',',each %$link), "\n";
            next;
        }
            
        # Add link info
        print "  topo_add_link() $link->{from} / $link->{from_port} --> $link->{to} / $link->{to_port}\n" if $DEBUG;

        my $from = root_device($link->{from});
        if (!defined($from)) {
            print "  topo_add_link() - can't resolve $link->{from} into device - discover with -F?\n";
            next;
        }
        my $to = root_device($link->{to});
        if (!defined($to)) {
            print "  topo_add_link() - can't resolve $link->{to} into device - discover with -F?\n";
            next;
        }

        # Check for existing / conflicting topology info
        my $link_from = sql_hash('device_port', 
                            ['remote_ip','remote_port'],
                            { 'ip' => $from, 'port' => $link->{from_port} }
                            );
        my $link_to = sql_hash('device_port', 
                            ['remote_ip','remote_port'],
                            { 'ip' => $to, 'port' => $link->{to_port}  }
                            );

        # Check for destinations
        unless (defined $link_from) {
            print "    !topo_add_link() -  Topology file error! Source Port Doesn't exist in this link : $from / $link->{from_port} --> $to / $link->{to_port} \n";
            next;
        }
        # Check for destinations
        unless (defined $link_to) {
            print "    !topo_add_link() -  Topology file error! Destination Port Doesn't exist in this link : $from / $link->{from_port} --> $to / $link->{to_port} \n";
            next;
        }

        # See if from -> to direction conflicts
        # (Note: using addresses in topo file, not root device)
        if ((defined $link_from->{remote_ip} and $link_from->{remote_ip} ne $link->{to})
          or(defined $link_from->{remote_port} and $link_from->{remote_port} ne $link->{to_port})) {
            print "    !topo_add_link() - $link->{from} / $link->{from_port} has discovered neighbor ",
                  "$link_from->{remote_ip} / $link_from->{remote_port} which conflicts with ",
                  "forced info of $link->{to} / $link->{to_port} \n";
        }

        # See if to -> from direction conflicts
        # (Note: using addresses in topo file, not root device)
        if ((defined $link_to->{remote_ip} and $link_to->{remote_ip} ne $link->{from})
          or(defined $link_to->{remote_port} and $link_to->{remote_port} ne $link->{from_port})) {
            print "    !topo_add_link() - $link->{to} / $link->{to_port} has discovered neighbor ",
                  "$link_to->{remote_ip} / $link_to->{remote_port} which conflicts with ",
                  "forced info of $link->{from} / $link->{from_port} \n";
        }

        my $rv = insert_or_update('device_port',
                        {'ip' => $from, 'port' => $link->{from_port} },
                        {'remote_ip' => $to, 'remote_port' => $link->{to_port} }
                        );
        print "    topo_add_link() - Failed to add $from / $link->{from_port} --> $to / $link->{to_port} \n" if $rv;
    }
}

=item topo_load_file(filename) 

Loads and parses manual topography file. 

=cut

sub topo_load_file {
    my $file = shift;

    $file = homepath('topofile') unless $file;

    my $dev;    # current config line

    print "Loading topology information from $file\n" if $DEBUG;
    open (DEVS,"<$file") or die "topo_load_file($file)  $!\n";
    while (my $line = (<DEVS>)){
        chomp $line;
        # comments
        $line =~ s/#.*//;
        # White Space
        $line =~ s/^\s+//g;
        $line =~ s/\s+$//g;
        next if $line =~ /^\s*$/;
        
        if ($line =~ /^link:(.*)/){
            my ($from_port,$to,$to_port) = split(/,/,$1);

            unless (defined $dev){
                print "Skipping $line. No dev defined.\n" if $DEBUG;
                next;
            }

            my $to_ip = &getip($to);
            unless (defined $to_ip and length $to_ip){
                print "    Can't resolve $to in $line!\n";
                next;
            }
        
            # Save Link info both directions
            push (@{$DeviceTopo{$dev}},   {'from' => $dev,  'from_port' => $from_port, 'to' => $to_ip, 'to_port' => $to_port});
            push (@{$DeviceTopo{$to_ip}}, {'from' => $to_ip,'from_port' => $to_port,   'to' => $dev,   'to_port' => $from_port});

        } elsif ($line =~ /^alias:(.*)/){
            unless (defined $dev){
                print "Skipping $line. No dev defined.\n" if $DEBUG;
                next;
            }
            print "  Alias : $1 found.\n" if $DEBUG;
            next;

        } else {
            $dev = &getip($line);
            unless (defined $dev and length $dev){
                print "Bad line or device IP not found in $file : $line\n";
                next;
            } else {
                #print "    $line ($dev)\n" if $DEBUG;
            }
            $DeviceTopo{$dev} = [] unless defined $DeviceTopo{$dev};
        }
    }
    close (DEVS);

    print scalar(keys(%DeviceTopo)) . " entries loaded \n" if $DEBUG;

}

=back

=head2 Utility Functions

=over

=item add_user()

Takes 4 optional arguments from @ARGV = (user,pw,port,admin) 

If all 4 are not there, then interactive mode is entered and prompts are given.

=cut

sub add_user {
    my ($user, $pw, $port, $admin) = @_;

    my %args;
    unless (defined $user){
        print "Enter User Name : ";
        $user = <STDIN>;
        chomp $user;
    }

    unless ($user){
        print "User Name is required.\n";
        return;
    }

    unless (defined $pw){
        print "Enter new password for $user [no change]: ";
        $pw = <STDIN>;
        chomp $pw;
    }
    unless (defined $port){
        print "Give $user Port Control [no change]? ";
        $port = <STDIN>;
        chomp $port;
    }
    unless (defined $admin){
        print "Give $user Admin Rights [no change]? ";
        $admin = <STDIN>;
        chomp $admin;
    }

    print "$user $pw $port $admin\n" if $DEBUG;

    my $rv = user_add($user, admin => $admin, port => $port, pw => $pw);

    if ($rv) { 
        print "Added user $user. ($rv)\n";
    }  else {
        print "Added / Changed user $user\n";
    }
}

=item batch_mode(name,time_too?)

Redirects STDOUT to a log file with timestamp.

Can be called recursively.  call batch_mode_end() to return to previous Output.

=cut

sub batch_mode{
    return unless $BatchMode;

    my ($file_name,$want_time,$no_header) = @_;

    my $file_path = homepath('datadir','data');

    my $extension = defined $CONFIG{logextension} ? $CONFIG{logextension} : 'log';
    
    my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime();

    # YYYYMMDD-HHmm
    my $date = sprintf("%d%02d%02d",$year+1900,$mon+1,$mday);
    my $time = sprintf("%02d:%02d",$hour,$min);

    my $timestamp = (defined $want_time and $want_time) ? "$date-$time" : $date;
    
    my $file = "$file_path/$file_name-$timestamp.$extension";

    # Path is everything up to the last /
    my $path = $file;
    $path =~ s/\/[^\/]+$//;

    # Make the target directory if not already there
    unless (-d $path){
        system("mkdir -m 0775 -p $path") and die "Can't make directory $path. $!\n";
    }

    my $fh = new IO::File;
    my $old_umask = umask(0000);
    $fh->open($file,O_WRONLY|O_CREAT,0664) or die "Can't open $file. $!\n";
    umask($old_umask);
    
    # Redirect output to log
    push (@OldSTDOUT, select($fh) );
    push (@LogFH,$fh);
    push (@LogFile,$file);

    # No Buffering output
    $| = 1;

    print STDERR "Batch Mode - Output in $file\n" if $DEBUG;
    &header unless (defined $no_header and $no_header);
}

=item batch_mode_end(no_compress_flag)

Returns control of stdout to previous value, optionally compresses 
the finished output file.

Function returns file name of closed output file.

Pass something as first parameter to force no compression.

=cut

sub batch_mode_end {
    my $no_compress = shift;
    return unless $BatchMode;

    return unless scalar @LogFile;

    my $file = pop @LogFile;
    select (pop @OldSTDOUT);
    my $fh = pop @LogFH;
    $fh->close() or die "Can't write $file. $!\n";

    if (defined $CONFIG{compresslogs} and $CONFIG{compresslogs} and ! defined $no_compress){
       print STDERR "\tCompressing $file\n" if $DEBUG;
       my $compress = defined $CONFIG{compress} ? $CONFIG{compress} : "/usr/bin/gzip -f";
       system("$compress $file") and warn "Compress of $file Failed.\n";
    }
    
    return $file;
}

=item end_int_handler 

=cut

sub end_int_handler {
    &end;
    &batch_mode_end;
    exit;
}

=item end()

Cleanup routine that is called upon interrupt (ctrl-c) or end of routines. 

Prints various statistics to stdout or batch_redirect() and calls Netdisco::log().

=cut

sub end {
    return unless $start_time != 0;

    $end_time = time;
    my $run_time = sprintf("%-.2f",($end_time-$start_time)/60);
    print "\n" .'-'x70 . "\n";
    print "Run took $run_time minutes\n";

    if ($ArpTotal > 0 ){
        print "Found $ArpTotal arp cache entries.\n";
        log('arp',"$ArpTotal entries. $run_time minutes.",$LogFile[-1]) if $Log;
    }

    if (defined $NbtTotal){
        my $nodes = scalar(keys(%$OldNodes));
        my $pct   = $nodes ? sprintf("%2.2f",($NbtTotal/$nodes)*100) : 0;
        print "Found $NbtTotal/$nodes ($pct\%) nodes with NetBIOS entries.\n";
        log('netbios',"$NbtTotal/$nodes ($pct\%) nodes w/ NetBIOS. $run_time minutes.",$LogFile[-1]) if $Log;
    }
    
    my $mac_seen = scalar keys(%MacSeen);
    if ($mac_seen){
        
        print "Saw $mac_seen distinct nodes in $MacTotal forwarding table entries.\n";
        log('mac',"$mac_seen distinct nodes.  $MacTotal forwarding table entries.  $run_time minutes.",$LogFile[-1]) if $Log;
    }

    my $discover_count = scalar(keys(%Discovered));
    if ($discover_count){
        print "Discovered $discover_count devices.\n";

        # Check for new/old devices
        my $new = 0;
        my $old = scalar keys %$OldDevices;

        foreach my $device (keys %Discovered){
            $new++ unless defined $OldDevices->{$device};
        }

        foreach my $device (keys %$OldDevices){
            $old-- if defined $Discovered{$device};
        }

        print "Discovered : $new new devices.  Missed: $old old devices.\n";

        log('discover',"$discover_count devices. ($new new) ($old old) $run_time minutes.",$LogFile[-1]) 
            if $Log;

        if (scalar keys %NoCDP){
            print "Devices Found by CDP but without CDP info avail. via SNMP :\n";
            foreach my $dev (keys %NoCDP){
                print "    $dev\n";
            } 
            log('nocdp',join(' ',keys %NoCDP),$LogFile[-1]) if $Log;
        }
        
        if (scalar keys %UnDiscovered) {
            print "Devices Found by CDP but not reachable by SNMP : \n";
            foreach my $dev (keys %UnDiscovered){
                print "    $dev\n";
            } 
            log('nosnmp',join(' ',keys %UnDiscovered),$LogFile[-1]) if $Log;
        }

        if (scalar keys %TimedOut){
            print "Devices timed out : \n";
            foreach my $dev (keys %TimedOut){
                print "    $dev\n";
            }
            log('timeout',join(' ',keys %TimedOut),$LogFile[-1]) if $Log;
        }
    }
    &batch_mode_end;
    if ($DaemonMode){
        return;
    }
    exit;
}

=item load_old_devices()

Populates %Old_Devices with which devices are in the database.

=cut

sub load_old_devices {
    print "load_old_devices()\n" if $DEBUG;
    $OldDevices = sql_column('device',['ip','layers']);
    $Aliases = sql_column('device_ip',['alias','ip']);
}

=item load_old_nodes(days)

Populates %Old_Nodes with which nodes are in the database.

Nodes will have to have been seen in the last DAYS days.

=cut

sub load_old_nodes {
    my $days = shift;
    print "load_old_nodes()\n" if $DEBUG;
    my $where = {active=>1, 
        'mac'=>\\"in (select mac from node where active)" };
    if (defined $days){
        $where->{'age(time_last)'}=\\"<= interval '$days day'"; 
    }
    my $old_nodes = sql_rows('node_ip',['ip'],$where);
    foreach my $n (@$old_nodes){
        my $ip = $n->{ip};
        $OldNodes->{$ip}++;
    }
}

=item parse_oui()

Parses file oui.txt in current directory.  Uses contents to stuff
table "oui".

=cut

sub parse_oui {
    print "parse_oui()\n";
    my $oui_file = "$CONFIG{home}/oui.txt";
    unless (-r $oui_file){
        print "  $oui_file not found!\n";
        die "Please run ''make oui'' to download oui.txt.  Or read INSTALL\n";
    }
    print "Removing old contents of oui table in database.\n";
    sql_do(qq/DELETE FROM oui WHERE true/);
    print "Schlopping contents of oui.txt to database.\n";
    my %OUI;
    open (OUI, "<$oui_file") or die "Can't open OUI. $!\n";
    while (my $line = <OUI>){
        chomp $line;
        if ($line =~ /^(.{2}-.{2}-.{2})\s+\(hex\)\s+(.*)\s*$/i){
            $OUI{$1}=$2;
        } 
    }
    close (OUI);

    my $oui_count = 0;
    foreach my $oui (keys %OUI){
        my $company = $OUI{$oui};
        # make 00-00-00 into 00:00:00
        $oui =~ s/-/:/g;
        $oui = lc($oui);
        print "$oui : $company\n" if $DEBUG;
        insert_or_update('oui',{},{'oui' => $oui, 'company' => $company } );
        $oui_count++;
    }
    print "Added $oui_count entries from oui.txt\n";
    sql_vacuum('oui',full=>1,'print'=>1);
}

=item timeout()

Signal handler for SIGALARM

=cut

sub timeout {
    die "timeout";
}

=back

=head2 SNMP Functions

=over

=item arpnip() 

Connects to device and reads its ARP cache. Then adds entries to C<node_ip> table. 

Cheers to Jim Warner for the original arpnip.

=cut

sub arpnip {
    my $hostname = shift;

    my $ip = getip($hostname);

    print "arpnip($hostname) : ";

    unless (defined $ip){
        print " Name does not resolve with DNS.\n";
        return;
    }

    &mac_getportmacs unless defined $PortMAC;

    my $dev = sql_hash('device',['*'],{'ip'=>$ip});

    unless (defined $dev->{ip}) { 
        print "  Device not found in database.  Try ``netdisco -N -r $hostname''\n";
        return;
    }

    if (in_device($dev,$CONFIG{arpnip_no}) ||
        ($CONFIG{arpnip_only} && !in_device($dev,$CONFIG{arpnip_only}))) {
        print " Excluded from arpnipping in config file.\n";
        return;
    }

    print "\n";

    my $device = get_device($hostname);
    return unless defined $device;

    # Fetch ARP Cache
    my $at_paddr = $device->at_paddr();
    my $at_netaddr = $device->at_netaddr();

    my $arp_count =0;
    foreach my $arp (keys %$at_paddr){
        my $mac = $at_paddr->{$arp};
        my $ip = $at_netaddr->{$arp};

        next unless defined $ip;

        # BayRS routers report incomplete MAC addresses for frame relay DLCI
        # interfaces.  Include this check for this case plus any others.
        unless (&is_mac($mac)) {
            print " $mac malformed ... skipping\n" if $DEBUG;
            next;
        }
        # Skip network broadcast addresses.  Some devices use this and then the
        # broadcast IP will show up in the node table.
        next if uc($mac) eq 'FF:FF:FF:FF:FF:FF';
        
        # Skip Passport 8600 CLIP MAC addresses, they will be used as root IP if
        # present so the IP will be identified.  Do not let the bogus MAC make
        # them show up in the node table.
        next if uc($mac) eq '00:00:00:00:00:01';
    
        # Skip VRRP addresses - don't want them showing up as nodes.  Don't know
        # what else to do with these right now.  What about HSRP IP's?
        if ($mac =~ /^00:00:5e:00:/i) {
            print " $mac is a VRRP address ... skipping\n" if $DEBUG;
            next;
        }

        if (defined $PortMAC->{$mac}) {
            print "  $mac is a port on device $PortMAC->{$mac} ... skipping\n"
                if $DEBUG;
            next;
        }   

        print "  $ip : $mac\n" if $DEBUG;
        add_arp($mac,$ip);
        $arp_count++;
    }
    print "  Processed $arp_count ARP Cache entries.\n";
    $ArpTotal += $arp_count;
    
    insert_or_update('device',{'ip'=> $dev->{ip} },{'last_arpnip'=> scalar localtime});

    # Fetch Subnets
    get_subnets($device);
}

=item arpwalk() 

Visits every Layer 3 device and trys to get its ARP Cache.  

Calls arpnip() for each device.  

=cut

sub arpwalk {
    $start_time = time;
    
    my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime();
    my $month = sprintf("%d%02d",$year+1900,$mon+1);
    &batch_mode("logs/$month/arp",1);
    print "Grabbing Arp Cache from all layer 3 devices (". localtime() . ")...\n";

    # Get our old devices, IP->Layer mapping
    &load_old_devices;

    # Grab existing mac addresses for switch ports
    &mac_getportmacs;

    foreach my $device (keys %$OldDevices){
        my $has_3 = has_layer($OldDevices->{$device},3);
        arpnip($device) if ($has_3);
    }

    sql_vacuum('node_ip','print'=>1);

    &end;
}

=item create_device(%args)

All %args are passed straight through to SNMP::Info except 'Class' which when set 
turns off C<AutoSpecify>.

 my $dev = create_device(
            'DestHost'     => host,
            'Community'    => public,
            'Version'      => 2,
            'Retries'      => 2,
            'Class'        => 'SNMP::Info::Layer2',
            'VersionForce' => 1,

Connect to a device via SNMP::Info with a given host and community string.

If optional C<Version> and C<Class> are given, no device type discovery is done.

If a more specific device type is not found C<-1> is returned.
The target device is probably not a network device.

If C<VersionForce> is true, no fallback to snmpv1 will happen.

=cut

sub create_device {
    my %args = @_;
    return undef unless defined $args{DestHost} and defined $args{Community};

    # Default Values
    $args{Debug}         = $DEBUG;
    $args{Version}       = $args{Version}       || $CONFIG{snmpver} || 2;
    $args{Retries}       = $CONFIG{snmpretries} || 2   unless defined $args{Retries};
    $args{Timeout}       = $CONFIG{snmptimeout} || 1000000 unless defined $args{Timeout};
    $args{MibDirs}       = $CONFIG{mibdirs}            if     defined $CONFIG{mibdirs};
    $args{BulkWalk}      = 0                           if     defined $CONFIG{bulkwalk_off} and $CONFIG{bulkwalk_off};
    # Turn off bulkwalk if we're using Net-SNMP 5.2.3 or 5.3.1.
    #  Even though the version numbers are now floats, previous
    #  versions reported as strings so we can't use "==".
    if ((!defined($args{BulkWalk}) || ($args{BulkWalk} == 1)) &&
	($SNMP::VERSION eq '5.0203' || $SNMP::VERSION eq '5.0301')) {
	print "! Turning off bulkwalk due to buggy Net-SNMP $SNMP::VERSION\n";
	$args{BulkWalk} = 0;
    }
    $args{BulkRepeaters} = $CONFIG{bulkwalk_repeaters} if     defined $CONFIG{bulkwalk_repeaters};
    $args{AutoSpecify}   = defined $args{Class} ? 0 : 1;
    $args{NonIncreasing} = defined $CONFIG{nonincreasing} ? $CONFIG{nonincreasing} : 1; # remove loops in bulkwalks
    my $class            = $args{Class}   || 'SNMP::Info';
    my $version_force    = $args{VersionForce}  || 0;

    # Arguments internal to this sub, not passed to SNMP::Info
    delete $args{Class}        if exists $args{Class};
    delete $args{VersionForce} if exists $args{VersionForce};
   
    my $print_comm = $args{Community};
    # If it's vlan, do last letter @ vlan
    if ($print_comm =~ /\@/){
        $print_comm =~ s/^.*(.\@\d+)$/$1/;  # VLAN Comm
    } else {
        # else do last letter
        $print_comm = substr($print_comm,-1,1);
    }
    printf("  create_device(%s,%s,%s,%s,bw:%s)\n",
           $args{DestHost},$print_comm, $version_force ? "$args{Version}*" : $args{Version}, 
           $args{AutoSpecify} ? 'AutoSpecify' : $class,
           defined $args{BulkWalk} ? $args{BulkWalk} : 'default',
          )
         if $DEBUG;


    my $device = new $class( %args );
    

    # Test for connectivity
    my $layers = $device->layers() if defined $device;

    # Try Version 1 if we haven't already
    #   V1 screws up some HP switches that support 2, so we stick w/ 2 first
    #   Don't try V1 if we're forcing a specific version
    if ( (!defined $device or !defined $layers) and 
         $args{Version} != 1 and !$version_force ){
        
        print " [Trying SNMP Version 1] ";
        printf("create_device(%s,%s,1)\n",$args{DestHost},$print_comm) if $DEBUG;
        $args{Version} = 1;
        
        $device = new $class(%args);
    }
    
    unless (defined $device) {
        $DEBUG and print "  Can't connect to $args{DestHost}\n";
        return undef;
    }

    $class = $device->class();
    if (!defined $device or !defined $class){
        $DEBUG and print "  Could not connect to $args{DestHost}.\n";
        return undef;
    }
        
    if ($class eq 'SNMP::Info'){
        my $layers = $device->layers();
        print "  Device Talks SNMP but only has layers $layers.  Skipping\n";
        return -1;
    }

    my $error = $device->error() || '';
    if ($error){
        # Debug already spit it out, no need to see it twice.
        print "  $error" unless $DEBUG;
        return undef;
    }

    $DEBUG and print "  Device Type : $class \n";

    # Tag on some netdisco specific info to the SNMP::Info object.
    $device->{ip}        = &getip($args{DestHost});
    $device->{dns}       = &hostname($device->{ip});

    return $device;
}

=item device_root() 

Looks to see if the device has a master IP instead of the one given.  
Checks for root_ip() method, then tries to lookup the reverse entry for sysName.0

=cut

sub device_root {
    my $device = shift;
    
    my $foundip = $device->{ip};

    # use the device override
    my $root_ip = $device->root_ip();
    return $root_ip if (defined $root_ip and length($root_ip));


    # Check the reverse of sysName.0 and use it for our real_ip?
    if (defined $CONFIG{reverse_sysname} and $CONFIG{reverse_sysname} ){
        my $name   = $device->name();
        my $nameip = &getip($name);

        print "  device_root(sysName.0 IP: $nameip Found IP:$foundip\n" if $DEBUG;
        return $nameip if (defined $nameip and length($nameip));
    }
    
    return $foundip;
}

=item find_neighbors() 

Finds all the CDP information on the device and stores the results in device_node.  

Adds to the @Discover_Queue

=cut

sub find_neighbors {
    my $device = shift;
   
    print "  Fetching Neighbor Information  : ";

    my $ip = $device->{ip};
    my $c_ip       = $device->c_ip();

    unless ($device->hasCDP() or scalar keys %$c_ip){
        # Great, catalyst 2926 doesnt give us cdpRun
        $NoCDP{$ip}++;    
        print "! CDP not Enabled.\n";
        return;
    }

    my $c_if       = $device->c_if();
    my $c_port     = $device->c_port();
    my $c_id       = $device->c_id();
    my $c_platform = $device->c_platform();
    my $interfaces = $device->interfaces();

    foreach my $key (keys %$c_ip){
        print '.';
        # Get our port to iid mapping
        my $iid = $c_if->{$key};
        my $port = $interfaces->{$iid};

        unless (defined $port){
           print "find_neighbors($ip) - Port for IID:$iid not resolved.\n";
           next;
        }

        my $remote_ip   = $c_ip->{$key};

        # Skip unreachable - Cisco cluster
        if ($remote_ip eq '0.0.0.0') {
            print "find_neighbors($ip) - Skipping unreachable (0.0.0.0) address on port $port.\n";
            next;
        }
        # Skip Local Loopback
        if ($remote_ip =~ /^127\./) {
            print "find_neighbors($ip) - Skipping loopback ($remote_ip) address on port $port.\n";
            next;
        }

        my $remote_port = undef;
        my $remote_type = $c_platform->{$key};
        my $remote_id   = $c_id->{$key};

        # Hack for BAY devices where if a BAY device is connected to a
        # non-bay device, we 'hear' other devices on the other end of this
        # port, but we don't know who we're talking to.
        # Therefore, set a loop back to ourselfs as a place marker, but add
        # our found nodes to the discovery queue.
        if (ref $remote_ip eq 'ARRAY'){
            $DEBUG and print "  Port:$port sees multiple neighbors. Setting loopback.\n";
            # Discover neighbors
            foreach my $neighbor (@$remote_ip){
                unless (defined $Discovered{$neighbor}) {
                    $DEBUG and print "  Adding $neighbor to discovery queue.\n";
                    push (@Discover_Queue, $neighbor);
                }
            }
            # Set loopback
            $remote_ip   = $ip;
            $remote_port = $port;

        } else {
            $remote_port = $c_port->{$key};

            if (defined $remote_port) {
                # get rid of any weird characters
                $remote_port =~ s/[^\d\/\.,()\w:]+//gi;

                # Swap catalyst remote port as 2/1 to 2.1
                $remote_port =~ s/\//\./ if ($remote_port =~ /^\d+\/\d+$/);
            } else {
                print "  No remote_port found for Port:$port connected to $remote_ip.\n";
            }
        }

        next unless (defined $remote_ip and length($remote_ip));

        # IP Phone Detection -- Add known phone models in parens.
        if (defined $remote_type and $remote_type =~ /(mitel.5\d{3})/i) {
            $remote_type = 'IP Phone - '.$remote_type if $remote_type !~ /ip phone/i; 
        }

        my $port_exists = sql_scalar('device_port',['true'],{'ip'=>$ip,'port'=>$port});
        unless (defined $port_exists and $port_exists){
            print "  Port $port not in DB -> $remote_ip/$remote_port.\n";
            next;
        }

        my %store;
        $store{'remote_ip'}   = $remote_ip;
        $store{'remote_port'} = $remote_port;
        $store{'remote_type'} = $remote_type;
        $store{'remote_id'}   = $remote_id;
       
        insert_or_update('device_port', {'ip' => $ip , 'port' => $port },
                        \%store);

        unless (defined $Discovered{$remote_ip}) {
            $DEBUG and print "  Adding $remote_ip to discovery queue.\n";
            push (@Discover_Queue, $remote_ip);
        }
    }
    print "\n";
}

=item get_device(host)

Calls create_device() with a community string

If cached values are stored in the database for the SNMP version and community strings,
they are used. 

If no cached values are available, or if they fail, then the values from the config file are
tried.

=cut

sub get_device {
    my $hostname = shift;
    my $device   = undef;
    my $comm     = undef;

    print "  get_device($hostname)\n" if $DEBUG;

    # Check to see if device is in database
    my $ip       = &getip($hostname);
    my $dev_ip   = &root_device($ip);

    # Warn if we are using an alias
    if (defined $dev_ip and $dev_ip ne $ip){
        print "!  $ip is an alias of $dev_ip.\n";
        $dev_ip = undef;
    }

    # Call with stored comm/ver unless supplied $ver
    if (defined $dev_ip) { 
        my $row     = sql_hash('device',['*'],{'ip'=>$dev_ip});
        my $version = $row->{snmp_ver};
        $comm       = $row->{snmp_comm};

        printf("  get_device(%s) - Connecting using cached info: %s/%s/%s\n",$hostname,$dev_ip,substr($comm,-1,1),$version)
            if $DEBUG;

        my %args = ('DestHost'  => $dev_ip,
                    'Community' => $comm,
                    'Version'   => $version, 
                   );

        # Check for bulkwalk disabling
        $args{BulkWalk} = 0 if in_device($row,$CONFIG{bulkwalk_no});

        # Check for forced SNMP Verison
        if (in_device($row,$CONFIG{snmpforce_v1}) ) {
            print "  Forcing SNMPv1 by config file.\n";
            $args{Version}      = 1;
            $args{VersionForce} = 1;
        }
        if (in_device($row,$CONFIG{snmpforce_v2}) ) {
            print "  Forcing SNMPv2c by config file.\n";
            $args{Version}      = 2;
            $args{VersionForce} = 1;
        }
        if (in_device($row,$CONFIG{snmpforce_v3}) ) {
            print "  Forcing SNMPv3 by config file.\n";
            $args{Version}      = 3;
            $args{VersionForce} = 1;
        }

        $device = create_device(%args);
                               
        print "!  Could not connect to $dev_ip with SNMP community and version info in database.\n"
            unless defined $device;
    }

    # Stored community not available, or didn't work. 
    if (!defined $device){

        my %args = ('DestHost'  => $hostname);

        # Check for bulkwalk disabling
        my $no_bw = in_device($hostname,$CONFIG{bulkwalk_no});
        $args{BulkWalk} = 0 if $no_bw;

        # Check for forced SNMP Verison
        if (in_device($hostname,$CONFIG{snmpforce_v1}) ) {
            print "  Forcing SNMPv1 by config file.\n" if $DEBUG;
            $args{Version}      = 1;
            $args{VersionForce} = 1;
        }
        if (in_device($hostname,$CONFIG{snmpforce_v2}) ) {
            print "  Forcing SNMPv2c by config file.\n" if $DEBUG;
            $args{Version}      = 2;
            $args{VersionForce} = 1;
        }
        if (in_device($hostname,$CONFIG{snmpforce_v3}) ) {
            print "  Forcing SNMPv3 by config file.\n" if $DEBUG;
            $args{Version}      = 3;
            $args{VersionForce} = 1;
        }

        # Try each community string
        foreach my $config_comm (@{$CONFIG{community}}) {

            # Don't bother retrying the failed one.
            next if (defined $comm and ($config_comm eq $comm));

            $args{Community} = $config_comm;

            $device = create_device(%args);

            if (defined $device and $device == -1){
                $device = undef;
                last;
            } elsif (defined $device){
                last;
            }
        }
    }
    unless (defined $device) {
        $UnDiscovered{$ip}++ if defined $ip;
        print "! Device Not Supported or I can't connect to it via SNMP.\n";
        return undef;
    }
    return $device;
}

=item get_device_rw(device[,version])

Returns a SNMP::Info object for a given device, using the Read-Write Community
Strings in the config file.

Returns undef or -1 on error.

=cut

sub get_device_rw {
    my ($host,$ver) = @_;
    my $device;

    # Check for bulkwalk disabling
    my $no_bw = in_device($host,$CONFIG{bulkwalk_no});

    foreach my $comm (@{$CONFIG{community_rw}}) {
        %args = ('DestHost'  => $host,
                 'Community' => $comm,
                 'Version'   => $ver
                );
        $args{BulkWalk} = 0 if $no_bw;
        
        $device = create_device(%args);
        last if (defined $device and $device != -1); 
    }
    return $device;
}

=item get_subnets(device)

Grab netmask and ip from device interfaces.  Determine device subnets
mathematically based upon the interface information. 

=cut

sub get_subnets {
    my $device = shift;

    my $ip_netmask   = $device->ip_netmask();

    foreach my $ip (keys %$ip_netmask){
        next if $ip eq '0.0.0.0';
        # Local Host
        next if $ip =~ /^127\./;

        if (defined $CONFIG{ignore_private_nets} and $CONFIG{ignore_private_nets}) {
            my $ignore =0;
            # Class A Private
            $ignore++ if $ip =~ /^10\./;
            # Class B Private
            $ignore++ if $ip =~ /^172\.16\./;
            # Class C private
            $ignore++ if $ip =~ /^192\.168\.0\./;
            print "  Ignoring private address $ip\n" if ($ignore and $DEBUG);
            next if $ignore;
        }

        my $netmask  = $ip_netmask->{$ip};
        my @maskbyte = split /\./, $netmask;
        my @ipbyte = split /\./, $ip;
        my $netaddr = undef;

        for (my $i=0; $i < 4; $i++) {
            my $b1 = $maskbyte[$i]+0;
            my $b2 = $ipbyte[$i]+0;
            my $netbyte = $b1 & $b2;
            if ($i != 0) { 
                $netaddr = $netaddr . "." . $netbyte;
            }
            else {
                $netaddr = $netbyte; 
            }
        }
        my $cidr_mask = mask_to_bits($netmask);
        next if $cidr_mask == 32;
        my $cidr_subnet = "$netaddr/$cidr_mask";
        
        insert_or_update('subnets', {'net' => $cidr_subnet},
                        {'net' => $cidr_subnet , 'last_discover' => scalar(localtime) }
                        );
        $DEBUG and print "Found subnet $cidr_subnet\n";
    }
}

=item mac_getportmacs() 

Fills the global %PortMAC with MAC addresses of ports already discovered.  
This is to make sure we don't mac-suck existing ports, such as VLANs.

=cut

sub mac_getportmacs {
    print "mac_getportmacs() ..." if $DEBUG;
    
    # I probably could have done this in a join but ...

    my $portmacs = sql_rows('device_port',['mac','ip'],{'mac' => \\'is not null'}); 
    foreach my $row (@$portmacs){
        my $mac = $row->{mac};
        my $ip  = $row->{ip};
        $PortMAC->{$mac}=$ip;
    }
    my $devmacs = sql_rows('device',['mac','ip'],{'mac' => \\'is not null'});
    foreach my $row (@$devmacs){
        my $mac = $row->{mac};
        my $ip  = $row->{ip};
        $PortMAC->{$mac}=$ip;
    }

    print " found ",scalar(keys %$PortMAC), " MACs.\n" if $DEBUG;
}

=item macsuck() 

Walks forwarding table for a specific device. 
Gets mac addresses that are listed in physical ports that do not 
have a neighbor listed.   If the device has VLANs, it will walk each
VLAN and get the MAC addresses from there.

=cut

sub macsuck{
    my $hostname = shift;

    my $ip = getip($hostname);

    print "macsuck($hostname) : ";

    unless (defined $ip){
        print " Name does not resolve with DNS.\n";
        return;
    }

    # Get the device info and its interfaces
    my $dev = sql_hash('device',['*'],{'ip'=>$ip});
    my $ports = sql_rows('device_port',['*'],
        {'ip'=>$ip});

    unless (defined $dev->{ip}) { 
        print "\n  Device not found in database.  Try ``netdisco -N -r $hostname''\n";
        return;
    }

    if (in_device($dev,$CONFIG{macsuck_no}) ||
        ($CONFIG{macsuck_only} && !in_device($dev,$CONFIG{macsuck_only}))) {
        print " Excluded from macsucking in config file.\n";
        return;
    }

    &load_old_devices unless (defined $OldDevices);
    &mac_getportmacs  unless (defined $PortMAC);

    # Move the ports from an array to a hash, indexed on port name
    my %dbports = ();
    foreach my $p (@$ports) {
        my $port = $p->{port};
        $dbports{$port}=$p;
    }

    # Make the SNMP connection
    my $time1 = time;
    my $device = get_device($hostname) or return;
    my $entries1 = $MacTotal;

    my $interfaces = $device->interfaces();
    my $fw_cache = {};

    walk_fwtable($device,\%dbports,$interfaces,$fw_cache);

    # For certain Cisco switches you have to connect to each
    # VLAN and get the forwarding table out of it.
    #   Notably the Catalyst 5k, 6k, and 3500 series
    my $cisco_comm_indexing = $device->cisco_comm_indexing() || 0;
    if ($cisco_comm_indexing){
        print " Device supports Cisco community string indexing. Connecting to each VLAN:\n";
        my $v_name   = $device->v_name() || {};
        my $i_vlan   = $device->i_vlan() || {};
        my $ver      = $device->snmp_ver();
        my $comm     = $device->snmp_comm();
        my $obj      = $device->class();
        my $bulkwalk = $device->bulkwalk();

        # Get list of VLANs currently in use by ports
        my %vlans;
        foreach my $key (keys %$i_vlan){
            my $vlan = $i_vlan->{$key};
            $vlans{$vlan}++;
        }
    
        # For each VLAN, connect and then macsuck
        foreach my $vid (sort { my $aa=$a; my $bb=$b; $aa=~ s/^\d+\.//;$bb=~ s/^\d+\.//;
                                # Sort by VLAN id
                                $aa <=> $bb
                              }
                         keys %$v_name)
        {

            my $vlan_name = $v_name->{$vid} || '(Unnamed)';
            # VLAN id comes as 1.142 instead of 142
            my $vlan = $vid;
            $vlan =~ s/^\d+\.//;

            if (defined $CONFIG{macsuck_no_vlan} and defined $CONFIG{macsuck_no_vlan}->{$vlan_name}){
                print " VLAN:$vlan_name ($vlan) Skipped by configuration file.\n";
                next;
            }

            # Only macsuck VLAN if in use by port
            #   but check to see if device serves us that list first
            if (scalar keys(%$i_vlan) and !defined $vlans{$vlan}
                and !$CONFIG{macsuck_all_vlans}){
                print " VLAN:$vlan_name ($vlan) Skipped because not in use by a port.\n";
                next;
            }

            print " VLAN:$vlan_name ($vlan) : ";

            # feeding all the connect info as a speedup, instead of
            #   retrying all the versions and communities
            my %args = ('DestHost'  => $hostname,
                        'Community' => $comm . '@' . $vlan,
                        'Version'   => $ver,
                        'Class'     => $obj,
                       );
            $args{BulkWalk} = $bulkwalk if defined $bulkwalk;
            my $vlan_device = create_device(%args);

            unless (defined $vlan_device){
                print "!\n";
                next;
            }
            walk_fwtable($vlan_device,\%dbports,$interfaces,$fw_cache);

        }
    }
    mac_savecache($fw_cache,\%dbports);

    # Log This
    my $entries2 = $MacTotal;
    my $started = localtime($time1);  my $time2 = time;
    insert_or_update('device',{'ip'=> $ip},{'last_macsuck'=>$started});
    print " Saw : ",$entries2-$entries1, " forwarding table entries.  Took ",$time2-$time1," seconds.\n" if $DEBUG;

}

=item mac_savecache({},{})

Does two things  : 

1. Checks for detected uplinks, warns of such and removes nodes on these uplinks from additions list

2. Stores the found forwarding table entries to the database.

=cut

sub mac_savecache {
    my $fw_cache = shift;
    my $dbports  = shift;

    # No entries to add?
    return unless scalar keys %$fw_cache;

    # Check for detected uplinks
    foreach my $ip (keys %$fw_cache){
        foreach my $port (sort {sort_port} keys %{$fw_cache->{$ip}}){
            my $remote_ip = $dbports->{$port}->{remote_ip} || '';

            # Check for detected uplink
            next unless $remote_ip eq 'uplink';
            print "  Port $port detected as uplink, topology broken.  Not adding nodes from this port.\n";
            delete $fw_cache->{$ip}->{$port};
        }
    }

    foreach my $ip (keys %$fw_cache){
        foreach my $port (sort {sort_port} keys %{$fw_cache->{$ip}}){
            my $macs = $fw_cache->{$ip}->{$port};
            print "  $ip -> $port : ", scalar keys %$macs, " nodes\n" if $DEBUG;
            foreach my $mac (keys %$macs){
                add_node($mac,$ip,$port); 
            }
        }
    }

}


=item macwalk() 

Grabs all the devices out of the database. 
Runs macsuck() on each device that has layer2 capabilites.

=cut

sub macwalk {
    $start_time = time;
    my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime();
    my $month = sprintf("%d%02d",$year+1900,$mon+1);
    &batch_mode("logs/$month/mac",1);
    print "Grabbing Mac Addresses from all Layer 2 Devices (" . localtime() . ")...\n";

    # Get our old devices, IP->Layer mapping
    &load_old_devices;
    
    # Get mac addresses of all the ports 
    &mac_getportmacs;

    my $timeout = $CONFIG{macsuck_timeout} || 90;
    foreach my $device (keys %$OldDevices){
        my $has_2 = has_layer($OldDevices->{$device},2);
        next unless $has_2;
        eval {
            alarm($timeout);
            macsuck($device);
            alarm(0);
        };

        if ($@) {
            if ($@ =~ /timeout/){
                $TimedOut{$device}++;
                print "\n  ! Device $device timed out in macsuck() ($timeout sec)\n";
            } else {
                print "\n$@\n";
            }
        }
    }
    sql_vacuum('node','print'=>1);

    &end;
}

=item port_control(switch,port,direction)

=cut

sub port_control {
    my ($switch,$port,$direction,$job) = @_;
    my $vlan = $job->{subaction};
    my $cmd  = $job->{action};

    unless (defined $switch and defined $port and defined $direction){
        print "Usage : port_control(switch,port,up/down)\n";
        return undef;
    }
    unless (defined $CONFIG{community_rw} and scalar @{$CONFIG{community_rw}}){
        print "No read-write community string has been set. Please add a community_rw setting to the Config file.\n";
        return undef;
    } 

    # Check for device in DB
    my $ip = getip($switch);
    $ip    = root_device($ip);

    # Get dev info from database
    my $db_dev = sql_hash('device',['*'],{'ip' => $ip}) if defined $ip;

    unless (defined $ip and defined $db_dev){
        print "Device $switch not found in netdisco.  Please discover device and try again.\n";
        return undef;
    } 
    
    # Check for port
    my $db_port = sql_hash('device_port',['*'],{ 'ip'=>$ip, 'port'=>$port });

    # Categorize this port
    my $is_phone      = (defined $db_port->{remote_type} and $db_port->{remote_type} =~ /ip.phone/i) ? 1 : 0;
    my $is_vlan       = (defined $db_port->{type} and $db_port->{type} =~ /^(53|propVirtual|l2vlan|l3ipvlan|135|136|137)$/i) ? 1 : 0;
       $is_vlan       = $is_vlan || (defined $db_port->{port} and $db_port->{port} =~ /vlan/i);
       $is_vlan       = $is_vlan || (defined $db_port->{name} and $db_port->{name} =~ /vlan/i);
    my $allow_phones  = (defined $CONFIG{portctl_nophones} and $CONFIG{portctl_nophones}) ? 0 : 1;
    my $allow_uplinks = (defined $CONFIG{portctl_uplinks} and $CONFIG{portctl_uplinks}) ? 1 : 0;
    my $allow_vlans   = (defined $CONFIG{portctl_vlans} and $CONFIG{portctl_vlans}) ? 1 : 0;
    my $change_vlans  = (defined $CONFIG{vlanctl} and $CONFIG{vlanctl} ) ? 1 : 0;

    unless (defined $db_port){
        print "Port : $port not found in database for device $switch\n";
        return undef;
    }

    # Check if uplink port
    if (defined $db_port->{remote_ip} and !$is_phone and !$allow_uplinks){
        print "Port : $port is an uplink port. Control from netdisco not allowed.\n";
        return undef;
    } 
    
    # Check if Phone
    if ($is_phone and !$allow_phones){
        print "Port : $port has an IP Phone connected to it.  Netdisco configured to not allow its change.\n";
        return undef;
    }

    # Check if is VLAN
    if ( ($is_vlan and !$allow_vlans) or ($is_vlan and $cmd eq 'vlan') ){
        print "Port : $port is a VLAN interface.  Netdisco Configured to not allow its change.\n";
        return undef;
    }

    if ( $cmd eq 'vlan' and !$change_vlans) { 
        print "Netdisco configured to not allow the change of VLANs. Set vlanctl=true in netdisco.conf\n";
        return undef;
    }

    # SNMP connect
    my $snmp_ver = $db_dev->{snmp_ver} || 2;
    my $device = get_device_rw($ip,$snmp_ver);

    unless (defined $device){
        print "Could not connect to device with read-write community string.\n";
        return undef; 
    }
    
    my $interfaces = $device->interfaces();
    my %rev_if     = reverse %$interfaces;
    my $iid        = $rev_if{$port};

    # Switch the port
    my $rv = undef;
    if ($cmd eq 'portcontrol') {
        $rv = $device->set_i_up_admin(lc($direction),$iid);
    }
    if ($cmd eq 'vlan') {
        $rv = $device->set_i_vlan($vlan,$iid);
    }
    
    unless (defined $rv){
        my $error = $device->error() || '';
        print "Set failed. $error\n";
        return undef;
    }

    # Mark down change in netdisco
    if ($cmd eq 'portcontrol') {
        insert_or_update('device_port', {'ip'=>$ip,'port'=>$port} , {'up_admin'=>$direction});
        print "Succesfully set Port:$port $direction on $switch\n";
    }
    if ($cmd eq 'vlan') {
        insert_or_update('device_port', {'ip'=>$ip,'port'=>$port} , {'vlan'=>$vlan});
        print "Succesfully change Port:$port to vlan $vlan on $switch\n";
    }

    return 1;
}

=item port_switch({})

Used to shut ports on and off and to change VLANs.

=cut

sub port_switch {
    my $job = shift;

    # Not sent from front-end via admin daemon
    unless (defined $job){
        
    }
    my $user   = $job->{username};
    my $userip = $job->{userip};
    my $ip     = getip($job->{device});
    my $port   = $job->{port};
    my $cmd    = $job->{action};
    my $vlan   = $job->{subaction};
    my ($dir,$reason) = $cmd eq 'portcontrol' ? split('-',$job->{subaction}) :
                        $cmd eq 'vlan'    ? ( 'vlan', $vlan ) : 
                        ('','');
    my $long_reason = '';
    if (defined $reason) {
        $long_reason = $netdisco::PORT_CONTROL_REASONS{$reason}->[0];
    }
    my $log    = $job->{log};
    my $dns    = &hostname($ip);
   
    print "port_switch() - $user @ $userip. c:$cmd d:$dir r:$reason i:$ip d:$dns p:$port l:$log\n" if $DEBUG;
    # Switch the Port
    my $rv = port_control($ip,$port,$dir,$job); 

    if (!defined $rv){
        print "\n[FAILED].\n";
        $log = "[FAILED] - See admin queue job log. \n $log";
        return 1;
    }

    my $action = $dir;
    $action = 'enable'  if $dir eq 'up';
    $action = 'disable' if $dir eq 'down';

    # Send E-Mail to Abuse
    my $portctl_email = $CONFIG{portctl_email};
    if (defined $portctl_email){
        print "Sending notification to $portctl_email\n";
        my $body = '';
        $body = <<"end_portctl" if $cmd eq 'portcontrol';
........ n e t d i s c o .........
  Device : $dns ($ip) 
  Port   : $port
  Action : $action
  User   : $user \@ $userip 
  Reason : [$reason] - $long_reason
  Log    : $log

end_portctl
        $body = <<"end_body" if $cmd eq 'vlan';
........ n e t d i s c o .........
  Device : $dns ($ip) 
  Port   : $port
  Action : Switch VLAN
  User   : $user \@ $userip 
  VLAN   : $vlan
  Log    : $log

end_body

        &mail($portctl_email,"port $action $dns($ip)/$port",$body);
    }
    # Log
    insert_or_update('device_port_log', {},
                     {'ip'=>$ip,'port'=>$port,'log'=>$log,'userip'=>$userip,
                      'username'=>$user,'action'=>$action, 'reason' => $reason }
                    ); 

    return 0;
}


=item store_device() 

Calls all the global methods and sends the results off to the database

=cut

sub store_device {
    my $device = shift;

    print "\n  Fetching Device Info           : \n";

    # Deal w/ devices with multiple IP address like most routers
    my $foundip = $device->{ip};
    my $devip = device_root($device);
    $device->{ip} = $devip;

    if ($devip ne $foundip) {
        print "  Using $devip instead of $foundip \n" if $DEBUG;

        # Set device name to root, not alias
        my $new_dns = &hostname($devip);
        $device->{dns} = $new_dns if (defined $new_dns and length($new_dns));
    }

    my $ip_index   = $device->ip_index();
    my $interfaces = $device->interfaces();
    
    # Remove all alias IP addresses
    sql_do(qq/DELETE from device_ip where ip = '$devip'/);

    # Store all our IPs
    foreach my $ip (keys %$ip_index){
        next if $ip eq $devip;

        next if $ip eq '0.0.0.0';
        # Local Host
        next if $ip =~ /^127\.0\.0\./;

        if (defined $CONFIG{ignore_private_nets} and $CONFIG{ignore_private_nets}) {
            my $ignore =0;
            # Class A Private
            $ignore++ if $ip =~ /^10\./;
            # Class B Private
            $ignore++ if $ip =~ /^172\.16\./;
            # Class C private
            $ignore++ if $ip =~ /^192\.168\.0\./;
            print "  Ignoring private address $ip\n" if ($ignore and $DEBUG);
            next if $ignore;
        }

        my $iid  = $ip_index->{$ip};
        my $port = $interfaces->{$iid}; 
        my $dns  = &hostname($ip);

        insert_or_update('device_ip', {'ip' => $devip,  'alias' => $ip},
                        {'ip' => $devip , 'alias' => $ip, 'port' => $port,
                         'dns' => $dns }
                        );
        $DEBUG and print "  Adding $ip to device_ip\n";
        $Aliases->{$ip} = $devip;
        
        # Mark alias down
        $device->{_alias}->{$ip}++;
    }

    # VTP Management Domain -- assume only one.
    my $vtpdomains = $device->vtp_d_name();
    my $vtpdomain;
    if (defined $vtpdomains and scalar(values(%$vtpdomains))) {
        $vtpdomain = (values(%$vtpdomains))[-1];
    }

    my %store = ();

    $store{ip}          = $device->{ip};
    $store{dns}         = $device->{dns};
    $store{snmp_ver}    = $device->snmp_ver();
    $store{snmp_comm}   = $device->snmp_comm();
    $store{description} = $device->description();
    $store{uptime}      = $device->uptime();
    $store{contact}     = $device->contact();
    $store{name}        = $device->name();
    $store{location}    = $device->location();
    $store{layers}      = $device->layers();
    $store{ports}       = $device->ports();
    $store{mac}         = $device->mac();
    $store{serial}      = $device->serial();
    $store{model}       = $device->model();
    $store{ps1_type}    = $device->ps1_type();
    $store{ps2_type}    = $device->ps2_type();
    $store{ps1_status}  = $device->ps1_status();
    $store{ps2_status}  = $device->ps2_status();
    $store{fan}         = $device->fan();
    $store{slots}       = $device->slots();
    $store{vendor}      = $device->vendor();
    $store{os}          = $device->os();
    $store{os_ver}      = $device->os_ver();
    $store{vtp_domain}  = $vtpdomain;
    #$store{log}         = $device->log();
    $store{last_discover} = localtime;
    
    insert_or_update('device', {'ip' => $device->{ip} },
                    \%store);
}

=item store_interfaces() 

Gets all the interface information using Table Methods in SNMP::Info.  

Deletes the old interface entries in device_port and puts in new ones.

=cut

sub store_interfaces { 
    my $device = shift;
    
    print "  Fetching Interface Information : ";
    my $ip = $device->{ip};

    # Delete old interface information (for dynamic,vlan...)
    sql_do(qq/DELETE from device_port where ip = '$ip'/);

    my $interfaces     = $device->interfaces();
    my $i_type         = $device->i_type();
    my $i_ignore       = $device->i_ignore();
    my $i_descr        = $device->i_description();
    my $i_mtu          = $device->i_mtu();
    my $i_speed        = $device->i_speed();
    my $i_mac          = $device->i_mac();
    my $i_up           = $device->i_up();
    my $i_up_admin     = $device->i_up_admin();
    my $i_name         = $device->i_name();
    my $i_duplex       = $device->i_duplex();
    my $i_duplex_admin = $device->i_duplex_admin();
    my $i_stp_state    = $device->i_stp_state();
    my $i_vlan         = $device->i_vlan();
    my $i_lastchange   = $device->i_lastchange();

    foreach my $if (keys %$interfaces) {
        print '.';
        my %store = ();
        my $port = $interfaces->{$if};
        unless (defined $port and length($port)) {
            $DEBUG and print "\n  Ignoring $if (no port mapping)\n";
            next;
        }
        $store{type}  = $i_type->{$if};
        if(exists $i_ignore->{$if}) {
            $DEBUG and print "\n  Ignoring $if ($store{type})\n";
            next;
        }
        $store{ip}           = $ip;
        $store{port}         = $port;
        $store{descr}        = $i_descr->{$if};
        $store{up}           = $i_up->{$if};
        $store{up_admin}     = $i_up_admin->{$if};
        $store{mac}          = $i_mac->{$if};
        $store{speed}        = $i_speed->{$if};
        $store{mtu}          = $i_mtu->{$if};
        $store{name}         = $i_name->{$if};
        $store{duplex}       = $i_duplex->{$if};
        $store{duplex_admin} = $i_duplex_admin->{$if};
        $store{stp}          = $i_stp_state->{$if};
        $store{vlan}         = $i_vlan->{$if};
        $store{lastchange}   = $i_lastchange->{$if};

        insert_or_update('device_port', { 'ip' => $ip, 'port' => $store{port} }, 
                         \%store );        

    }

    # Get SSIDs for wireless interfaces
    my $ssidlist = $device->i_ssidlist();
    my $ssidbcast = $device->i_ssidbcast();
    my $channel = $device->i_80211channel();

    sql_do(qq/DELETE from device_port_ssid where ip = '$ip'/);

    foreach my $ssididx (keys %$ssidlist) {
        my $if = $ssididx;
        $if =~ s/\.\d+$//;
        my %store = ();
        my $port = $interfaces->{$if};
        unless (defined $port and length($port)) {
            $DEBUG and print "\n  Ignoring $if (no port mapping)\n";
            next;
        }
        $store{ip}           = $ip;
        $store{port}         = $port;
        $store{ssid}         = $ssidlist->{$ssididx};
        $store{broadcast}    = $ssidbcast->{$ssididx};
        $store{channel}      = $channel->{$if};
        insert_or_update('device_port_ssid', { 'ip' => $ip, 'port' => $store{port}, 'ssid' => $store{ssid} }, 
                         \%store );
    }

    print "\n";
}

=item walk_fwtable()  

Walks the Forwarding table from the C<BRIDGE-MIB>
for the given device, and then adds MAC addresses to the C<node> table.

=cut

sub walk_fwtable {
    my ($device,$dbports,$interfaces,$fw_cache) = @_;

    my $ip = $device->{ip};
    my $fw_mac     = $device->fw_mac();
    my $fw_port    = $device->fw_port();
    my $bp_index   = $device->bp_index();

    # To map the port in the forwarding table to the 
    # physical device port we have this triple indirection:
    #      fw_port -> bp_index -> interfaces
    
    foreach my $fw_index (keys %$fw_mac){    
        my $mac    = $fw_mac->{$fw_index};
        my $bp_id  = $fw_port->{$fw_index};

        $MacTotal++;

        unless (defined $bp_id) {
            print "  $mac: $fw_index has no fw_port mapping.  Skipping\n"
                if $DEBUG;
            next;
        }

        my $iid    = $bp_index->{$bp_id};

        unless (defined $iid) {
            print "  $mac: Port $bp_id has no bp_index mapping. Skipping\n"
                if $DEBUG;
            next;
        }

        my $port  = $interfaces->{$iid};

        unless (defined $port) {
            print "  $mac: SNMP iid $iid has no physical port matching. Skipping.\n"
                if $DEBUG;
            next;
        }

        unless (defined $dbports->{$port}){
            print "  $mac: Port ($port) is not in database.  Skipped.\n"
                if $DEBUG;
            next;
        }

        # Check to see if the port is connected to another device,
        #   and if we have that device in the DB.  

        #If we dont see the device in the db, but there is a neighbor, then we capture anyways,
        #   since we want all the macs at the other end. 

        my $remote_ip = $dbports->{$port}->{remote_ip};
        if (defined $remote_ip) {
            if (defined $OldDevices->{$remote_ip} or defined $Aliases->{$remote_ip}) {
                my $ip = $Aliases->{$remote_ip} || $remote_ip;
                print "  $mac: Port $port has neighbor: $ip. Skipped.\n" if $DEBUG;
                next;
            } elsif ($remote_ip eq 'uplink') {
                print "  $mac: Port $port is detected uplink. Skipped.\n" if $DEBUG;
                next;
            } else {
                # Can be edge of network, but that would be a L3 device.
                print "  $mac: Port $port has neighbor: $remote_ip, but not in Netdisco. Included.\n" if $DEBUG;
            } 
        }

        # Check if Port Channel
        if ($port =~ /port.channel/i) {
            print "  Port ($port) is a Port Channel Interface.  Skipped.\n" if $DEBUG;
            next;
        }
        
        # Check if MAC is a switch port
        if (defined $PortMAC->{$mac}) {
            my $switch_ip = $PortMAC->{$mac};
            if ($ip eq $switch_ip){
                print "  $mac: Port on this switch.  Skipped.\n" if $DEBUG;
                next;
            } 

            # TODO: This is an uplink port, mark here and have another process
            #        add a loopback if no topo info is there. 
            #        Also need some sort of process to show all the loopbacks
            
            # Mark port as uplink
            $dbports->{$port}->{remote_ip}='uplink';
    
            my $bleed = $CONFIG{macsuck_bleed} || 0;
            print "  $mac: Port $port -> Device $switch_ip. " if $DEBUG;

            if ($bleed) {
                print "Included.\n" if $DEBUG;
            } else {
                print "Skipped.\n" if $DEBUG;
                next;  
            }
        }

        # Check for Multicast MACs
        if ($mac =~ /^([0-9a-f]{2}):/i and ($1 =~ /.(1|3|5|7|9|b|d|f)/i)){
            print "  $mac:  MULTICAST\n" if $DEBUG;
            next;
        }

        next if $mac eq '00:00:00:00:00:00';
        next if uc($mac) eq 'FF:FF:FF:FF:FF:FF'; 

        if ($DEBUG) { 
            print "  $mac: $bp_id -> $iid -> $port\n";
        } else {
            print ".";
        }
        
        $fw_cache->{$ip}->{$port}->{$mac}++;
        $MacSeen{$mac}++;
    }
    print "\n" unless $DEBUG;
}

=back

=head2 NetBIOS Functions

=over

=item nbtstat(host) 

Connects to node and gets NetBIOS information. Then adds entries to node_nbt table.

Returns whether a node is answering netbios calls or not.

=cut

sub nbtstat {
    tryuse('Net::NBName', die => 1);
    my $host = shift;
    my $ip = getip($host);
    my $nb = Net::NBName->new;
    
    print "nbtstat($host) : ";

	unless (defined $ip) {
		print "No IP match.\n";
		return 0;
	}

    my $ns = $nb->node_status($ip);

    # Check for NetBIOS Info
    unless ($ns) {  
        print "No NetBIOS.\n";
        return 0;
    }

    my $server = 0;
    my $nbname = '';
    my $domain = '';
    my $nbuser = '';

    for my $rr ($ns->names) {
		my $suffix = defined $rr->suffix ? $rr->suffix : -1;
		my $G      = defined $rr->G ? $rr->G : '';
		my $name   = defined $rr->name ? $rr->name : '';

        if ($suffix == 0 and $G eq "GROUP") {
            $domain = $name;
        }
        if ($suffix == 3 and $G eq "UNIQUE") {
            $nbuser = $name;
        }
        if ($suffix == 0 and $G eq "UNIQUE") {
            $nbname = $name unless $name =~ /^IS~/;
        }
        if ($suffix == 32 and $G eq "UNIQUE") {
            $server = 1;
        }
    }
    my $mac = $ns->mac_address || '';
    $mac =~ s/-/:/g;

    unless ($nbname){
        print "No computer name found.\n";
        return 1;
    }
        
    if (!$mac or $mac eq '00:00:00:00:00:00'){
        # Just assume it's the last MAC we saw this IP at.
        $mac = sql_scalar('node_ip',['mac'],{'ip'=>$ip,'active'=>1});
        unless (defined $mac){
            print "No MAC in given or in DB.\n";
            return 1;
        }
        print "(No MAC)" if $DEBUG;
    }

    print "\\\\$domain\\$nbname $nbuser $mac ",$server ? 'server' : 'client', "\n";
    add_nbt($ip,$mac,$nbname,$domain,$server,$nbuser);
    $NbtTotal++;

    return 1;    
}
    
=item nbtwalk() 

Visits every node and trys to get its NetBIOS information.  

Calls nbtstat() for each device.  

=cut

sub nbtwalk {
    $start_time = time;
    $NbtTotal=0;

    my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime();
    my $month = sprintf("%d%02d",$year+1900,$mon+1);
    &batch_mode("logs/$month/netbios",1);
    
    # Get nodes
    my $days = $CONFIG{nbt_days} || 7;
    print "Grabbing NetBIOS from all nodes seen in last $days days. (". localtime() . ")...\n";

    &load_old_nodes($days);
    print "  Searching ",scalar(keys(%$OldNodes))," nodes.\n" if $DEBUG;
    
    foreach my $node (sort sort_ip keys %$OldNodes){
        nbtstat($node) if defined $OldNodes->{$node};
    }
    
    sql_vacuum('node_nbt','print'=>1); 

    &end;
}

=back

=head2 Maintenance Functions

=over

=item alias_clean() 

Routine to clean out devices that are now listed as aliases of another device. This is
usually necessary after a device has been merged into another one.

=cut

sub alias_clean {
    print "Cleaning out Aliases that showed up as devices :\n";
    
    my $aliases = sql_rows('device_ip',['ip','alias','dns']);
    foreach my $row (@$aliases) {
        my $ip = $row->{ip};
        my $alias = $row->{alias};
        my $dns = $row->{dns};
        $dns = defined $dns ? $dns : '[No DNS]';
        my $exists = sql_scalar('device',['true'],{'ip'=>$alias});
        next unless (defined $exists and $exists);
        print "Deleting alias of $ip = $alias ($dns)\n";
        expire_device($alias,1)
    }

    print "Cleaning out Aliases of non-existant devices.\n";
    sql_do(qq/DELETE FROM device_ip WHERE ip NOT IN (SELECT ip FROM device)/);
}

=item arp_dump(dir) 

Dumps node_ip table to files arp_current and arp_archive.

=cut

sub arp_dump {
    my $dir = shift;

    print "Dumping node_ip table to $dir...\n";


    # Force to batch mode to not output to screen.
    my $old_batch = $BatchMode;
    $BatchMode=1;

    # Dump Current
    my $sth = sql_query('node_ip',['mac','ip as remote_ip','active',
                                    'extract(epoch from time_first) as time_first', 
                                    'extract(epoch from time_last) as time_last'],
                          {'active' => 1}, undef, 'order by remote_ip'
                        );

    &batch_mode("$dir/arp_current");
    while (my $row = $sth->fetchrow_hashref()) {
        my $active = $row->{active};
        next unless $active;
        my $mac = $row->{mac};  
        my $ip  = $row->{remote_ip};
        my $time_first = $row->{time_first};
        my $time_last = $row->{time_last};
        printf("%-15s  %-17s  %-10d %-10d\n",
            $ip, $mac, $time_first, $time_last);
    }
    &batch_mode_end;

    # Dump Archive
    $sth = sql_query('node_ip',['mac','ip as remote_ip','active',
                                    'extract(epoch from time_first) as time_first', 
                                    'extract(epoch from time_last) as time_last'],
                          {'active' => 0}, undef, 'order by remote_ip'
                           );
    &batch_mode("$dir/arp_archive");
    while (my $row = $sth->fetchrow_hashref()) {
        my $active = $row->{active};
        next if $active;
        my $mac = $row->{mac};  
        my $ip  = $row->{remote_ip};
        my $time_first = $row->{time_first};
        my $time_last = $row->{time_last};
        printf("%-15s  %-17s  %-10d %-10d\n",
            $ip, $mac, $time_first, $time_last);
    }
    &batch_mode_end;

    $BatchMode=$old_batch;

}

=item change_device_ip(from_ip, to_ip)

Used to move move over all the information from one device 
to a new IP address.  First tries to discover new device, then
proceeds to move over old information.  

=cut

sub change_device_ip {
    my ($from_ip,$to_ip) = @_;
    
    print "change_device_ip($from_ip,$to_ip)\n";

    return unless (defined $from_ip and defined $to_ip);

    &load_old_devices ;

    print "  Checking for Old Device ($from_ip)\n";
    unless (defined $OldDevices->{$from_ip}){
        print "  !$from_ip not found as device.\n";
        return 0;
    }

    if (defined $Aliases->{$from_ip}) {
        print "  !$from_ip is an alias. Using $Aliases->{$from_ip}.\n";
        $from_ip = $Aliases->{$from_ip};
    }
    
    &topo_load_file();

    print "  Adding New Device ($to_ip)\n";

    discover($to_ip); 

    &load_old_devices ;

    unless (defined $OldDevices->{$to_ip}){
        print "  !Device $to_ip did not discover.  Not moving old entries to this one. Fix and run again.\n";
        return 0;
    } 
    
    print "  Removing Old Device its Aliases, and Ports\n";
    expire_device($from_ip);
    
    print "  Moving old Nodes to New Device.\n";
    sql_do(qq/UPDATE node set switch='$to_ip' where switch='$from_ip'/);

    # TODO - Check to see if the port numbers have stayed the same, otherwise 
    #        axe the old nodes.

    return 1;
}

=item db_clean() 

Removes all the entries in C<node> that are switch ports. 

Checks for nodes on non existant ports and prints a warning

Removes nodes that are on uplink ports.

=cut

sub db_clean {
    print "Database Cleanup : \n";

    # See what devices exist
    &load_old_devices ;

    print "  Deleting nodes that are actually device ports...\n";
    my $num = sql_do(q/DELETE FROM node WHERE mac IN (select mac from device_port)
                                 OR mac IN (select mac from device)/);
    print "    $num MAC entries deleted\n";
    $num = sql_do(q/DELETE FROM node_ip WHERE mac IN (select mac from device_port)
                                 OR mac IN (select mac from device)/);
    print "    $num ARP entries deleted\n";
    
    print "  Checking for Nodes that exist on nonexistent ports:\n";
    # This query returns only rows from node that refer to a port
    #  that's not in device_port.
    my $sth = sql_query('node LEFT JOIN device_port ON device_port.ip=node.switch AND device_port.port=node.port',
			['node.mac','node.switch','node.port'],
			{'device_port.ip' => 'IS NULL'});
    while (my $row = $sth->fetchrow_hashref()) {
        my $mac  = $row->{mac};  
        my $ip   = $row->{switch};
        my $port = $row->{port};
        
        my $have_device = defined $OldDevices->{$ip} ? 1 : 0;

        # If the device doesn't exist Delete it.
        # If the device exists and has ports, but not this port, delete the node
        # If the deviec exists and doesn't have ports, do not delete it.  Probably a refresh() error.
        my $nuke = 0;
        if ($have_device){
	    my $ports = sql_scalar('device_port',['count(*)'],{ip=>$ip});
	    if (defined $ports and $ports){
		print "    $mac \@ $ip/$port. Port no longer exists. Removed.\n";
		$nuke++;
	    } else {
		print "    $mac \@ $ip/$port. Device has no ports.  Run -e $ip if appropriate.\n";
	    }
        } else  {
            print "    $mac \@ $ip/$port. Device no longer exists. Removed.\n";
            $nuke++;
        }

        if ($nuke) {
            #print "nuking $mac $ip $port\n" if $DEBUG;
            sql_do(qq/DELETE from node where mac = '$mac' and switch = '$ip' and port = '$port'/);
        }
    }

    print("  Removing nodes that are listed on uplink ports...\n");
    # This query returns only the possible uplink ports
    #  that have nodes on them.
    my $dev_ports = sql_rows('device_port, node',
                ['distinct ip','device_port.port','remote_ip'],
                {'remote_ip' => 'IS NOT NULL',
                 'device_port.ip'=>\'node.switch',
                 'device_port.port'=>\'node.port'});

    foreach my $dev_port (@$dev_ports){
        my $ip        = $dev_port->{ip};
        my $port      = $dev_port->{port};
        my $remote_ip = $dev_port->{remote_ip};
        $remote_ip    = defined $Aliases->{$remote_ip} ? $Aliases->{$remote_ip} : $remote_ip;
        my $layers    = $OldDevices->{$remote_ip};

        print "$ip / $port -> $remote_ip " .
                    (defined($layers) ? "with layers $layers - deleting nodes"
                                      : "(not deleting, not discovered)") . "\n" if $DEBUG;
        next unless defined $layers;
        my $deleted;
        $deleted = sql_do(qq/DELETE FROM node WHERE switch='$ip' and port='$port'/);
        print "    $deleted nodes deleted from $ip / $port\n";
    }
    print "Done.\n"; 

    &expire_ips;
    sql_vacuum('node','print'=>1);
}

=item dev_dump() 

Dumps out the device,device_ip, and topology info from device_port to file 'devices'.

=cut

sub dev_dump {
    my $dir = shift;

    print "Dumping device and device_port tables to $dir...\n";

    # Force to batch mode to not output to screen.
    my $old_batch = $BatchMode;
    $BatchMode=1;
    
    &load_old_devices;
    
    &batch_mode("$dir/devices");

    # Make alias map
    my %alias_map;
    foreach my $alias (keys %$Aliases){
        my $dev = $Aliases->{$alias};

        push @{$alias_map{$dev}},$alias;
    }

    foreach my $dev (sort {sort_ip} keys %$OldDevices){
        print "$dev\n";
        if (defined $alias_map{$dev}){
            foreach my $alias (sort {sort_ip} @{$alias_map{$dev}}){
                print "\talias:$alias\n";
            }
        }

        # topology
        my $neighbors = sql_rows('device_port',['remote_ip','remote_port','port'],
                                {'remote_ip'=>'is not null','ip'=>$dev});

        foreach my $neighbor (sort {sort_ip} @$neighbors){

            my $port = $neighbor->{port};
            my $remote_ip = $neighbor->{remote_ip};
            my $remote_port = $neighbor->{remote_port};
            print "\tlink:$port,$remote_ip,$remote_port\n";
        }
    }

    &batch_mode_end;

    $BatchMode=$old_batch;
}

=item expire_data(type,days,archive_only)

C<type> can be : node,device

C<days> is a positive integer number of days in which an entry
has not been updated.

C<archive_only> for node only.

Removes devices and nodes that haven't been updated in C<days> days.
Called from nightly() and controlled through the C<expire_*> directives
in the config file.

Cheers to Brian Wilson for his patch for the start of this feature.

=cut

sub expire_data {
    my ($type, $days, $archive_only) = @_;
    $archive_only ||=0;

    unless (defined $type and $type =~ /^(node|device)$/i){
        print "expire_data : Data type (1st argument) must be either node or device.\n";
        return;
    }
    
    unless (defined $days and $days =~ /^\d+$/ and $days > 0){
        print "expire_data : Age of data must be a positive number of days (2nd argument).\n";
        return;
    }
    
    print "expire_data($type,$days days,archive_only:$archive_only)\n";

    if ($type eq 'device'){
        my $devices = sql_rows('device',['ip','dns','age(last_discover) as age'],
                               {'age(last_discover)' => \\ "> interval '$days days'"}
                              );
        foreach my $dev (sort {sort_ip} @$devices){
            my $name = $dev->{dns} || $dev->{ip};
            printf("Removing %-15s %25s   Last Seen: %s\n",$dev->{ip},$name,$dev->{age});

            # TODO - Ping device first.  Some devices stop responding to SNMP but still exist.
            #        then issue warning and don't delete?

            expire_device($dev->{ip},1);
        }   
    }

    if ($type eq 'node'){
        my $sql = qq/DELETE FROM node WHERE AGE(time_last) > INTERVAL '$days days'/;
        $sql .= " AND NOT active" if $archive_only;

        my $rows = '';
        $rows = sql_do($sql);

        # note:expire_ips() should be run after this, and is in nightly() through db_clean()
        print "Deleted $rows rows from node.\n";

        $sql = qq/DELETE from node_ip where age(time_last) > interval '$days days'/;
        $sql .= " AND NOT active" if $archive_only;
        
        $rows = sql_do($sql);
        print "Deleted $rows rows from node_ip.\n";

        $sql = qq/DELETE from node_nbt where age(time_last) > interval '$days days'/;
        $sql .= " AND NOT active" if $archive_only;
        
        $rows = sql_do($sql);
        print "Deleted $rows rows from node_nbt.\n";
    }
}

=item expire_device(device,expire_nodes?)

Removes device from the database

Set second argument to true to remove all the connected nodes and their 
IP mappings as well.

=cut

sub expire_device {
    my ($devname,$expire_nodes) = @_;
    my $ip  = getip($devname);

    print "Expire Device $devname ($ip)\n";

    unless (length $ip) {
        print "  Device $devname doesn't resolve.\n";
        return;
    }

    my $dev = sql_hash('device',['*'],{'ip'=>$ip} );

    unless (defined $dev){
        print "  Device $devname ($ip) not found in database!\n";
        return;
    }

    my $dns = $dev->{dns} || '';
    print "  Removing $dns ($ip)...\n";
    # Get rid of device info
    sql_do(qq/DELETE from device where ip = '$ip'/);
    print "  Removing Aliases of $dns ($ip)...\n";
    # Get rid of aliases
    sql_do(qq/DELETE from device_ip where ip = '$ip'/);
    # Remove Ports
    sql_do(qq/DELETE from device_port where ip = '$ip'/);

    if (defined $expire_nodes and $expire_nodes){
      &expire_nodes($ip);  
    }

}

=item expire_nodes(device,archive_only,port)

Removes entries from node and node_ip for a given device.

Set port to limit the expiration to a specific port.

Set archive_only to 1 to archive the nodes on the device.

=cut

sub expire_nodes {
    my ($dev,$archive,$port) = @_;
    my $ip  = getip($dev);

    print "Expire Nodes($dev)\n";
    unless (length $ip) {
        print "  Device $dev doesn't resolve.\n";
        return;
    }

    my %where_hash = ('switch' => $ip);
    my $where = "switch='$ip'";
    $where .= " AND port='$port'" if defined $port; 
    $where_hash{port} = $port if defined $port;
    
    # grab mac count
    my $macs = sql_rows('node',['count(mac)'],\%where_hash,undef,"GROUP BY mac");
     
    my $count = $macs->[0]->{count} || 0;
    if (defined $archive and $archive){
        # De-activate nodes
        print "  Archiving $count entries for $where\n";
        sql_do(qq/UPDATE node SET active=false WHERE $where/);
    } else {
        # Delete nodes
        print "  Deleting $count entries for $where\n";
        sql_do(qq/DELETE FROM node WHERE $where/);
    }
}

=item expire_nodes_subnet(subnet)

Subnet is in CIDR format, or any other format that Postgres likes.

    192.168.0.0/24

Runs expire_ips afterwards to cleanup.

=cut

sub expire_nodes_subnet {
    my $subnet  = shift;
    my $confirm = shift;
    
    print "expire_nodes_subnet($subnet)\n";
    my $dbsubnet = dbh_quote($subnet);

    my $devices = sql_rows('device',['ip','dns','location'],{'ip' => \\"<< $dbsubnet"});

    unless (defined $devices and scalar @$devices){
        print "No devices found in subnet $subnet.\n";
        print "Are you sure you specified the subnet CIDR format? Eg. 192.168.0.0/24\n";
        return;
    }

    print "Found Matching Devices : \n";
    foreach my $dev (sort { ($a->{dns}||$a->{ip}) cmp ($b->{dns}||$b->{ip}) } @$devices){
        my $name = $dev->{dns} || $dev->{ip};
        $name =~ s/\Q$CONFIG{domain}\E//;
        my $ip   = $dev->{ip};
        my $location = $dev->{location} || '';
        printf "  %-15s %-15s %s\n",$ip, substr($name,0,15), substr($location,0,46);
    }

    my $dev_count = scalar(@$devices);

    unless (defined $confirm){
        print "Enter 'delete' to confirm Exipration of nodes on these $dev_count devices.\n";
        print "Confirm : ";
        $confirm = <STDIN>;
        chomp $confirm;               
    } 
    
    unless ($confirm eq 'delete'){
        print "Never Mind.\n";
        return;
    }

    foreach my $dev (@$devices){
        my $ip = $dev->{ip};
        expire_nodes($ip);
    }

    &expire_ips;

}

=item expire_ips()

Expires IPs not in use in node.

 delete from node_ip where 
    mac not in
        (select mac from node) 

=cut

sub expire_ips {
    print "expire_ips()\n";
            
    my $rows = sql_do("DELETE FROM node_ip WHERE mac NOT IN (SELECT mac FROM node)");
    $rows = $rows || 0;
    print "Deleted $rows rows.\n";
    sql_vacuum('node_ip','print'=>1);
}

=item mac_dump() 

Dumps the node table out to mac_current.txt and mac_archive.txt.
Adds a day stamp, no time-stamp.

=cut

sub mac_dump {
    my $dir=shift;

    print "Dumping node table to $dir...\n";

    # Force to batch mode to not output to screen.
    my $old_batch = $BatchMode;
    $BatchMode=1;

    # Dump Current
    my $sth = sql_query('node',['mac','switch','port','active',
                                    'extract(epoch from time_first) as time_first', 
                                    'extract(epoch from time_last) as time_last'],
                           {'active' => 1}, undef, 'order by mac'
                        );

    &batch_mode("$dir/mac_current");

    while (my $row = $sth->fetchrow_hashref()) {
        my $active = $row->{active};
        next unless $active;
        my $mac = $row->{mac};  
        my $ip  = $row->{switch};
        my $port = $row->{port};
        my $time_first = $row->{time_first};
        my $time_last = $row->{time_last};
        printf("%-17s  %-15s  %-25s %-10d %-10d\n",
            $mac, $ip, $port, $time_first, $time_last);
    }
    &batch_mode_end;

    # Dump Archive
    $sth = sql_query('node',['mac','switch','port','active',
                                    'extract(epoch from time_first) as time_first', 
                                    'extract(epoch from time_last) as time_last'],
                           {'active' => 0}, undef, 'order by mac'
                           );

    &batch_mode("$dir/mac_archive");

    while (my $row = $sth->fetchrow_hashref()) {
        my $active = $row->{active};
        next if $active;
        my $mac = $row->{mac};  
        my $ip  = $row->{switch};
        my $port = $row->{port};
        my $time_first = $row->{time_first};
        my $time_last = $row->{time_last};
        printf("%-17s  %-15s  %-25s %-10d %-10d\n",
            $mac, $ip, $port, $time_first, $time_last);
    }

    &batch_mode_end;

    $BatchMode=$old_batch;
}

=item netbios_dump() 

Dumps the node_nbt table out to netbios_current.txt and netbios_archive.txt.
Adds a day stamp, no time-stamp.

=cut

sub netbios_dump {
    my $dir=shift;

    print "Dumping node_nbt table to $dir...\n";

    # Force to batch mode to not output to screen.
    my $old_batch = $BatchMode;
    $BatchMode=1;

    # Dump Current
    my $sth = sql_query('node_nbt',['mac','nbname','domain','server','nbuser','active',
                                    'extract(epoch from time_first) as time_first', 
                                    'extract(epoch from time_last) as time_last'],
                           {'active' => 1}, undef, 'order by mac'
                        );

    &batch_mode("$dir/netbios_current");

    while (my $row = $sth->fetchrow_hashref()) {
        my $active = $row->{active};
        next unless $active;
        my $mac    = $row->{mac};  
        my $name   = $row->{nbname};
        my $domain = $row->{domain};
        my $server = $row->{server};
        my $user   = $row->{nbuser};
        my $time_first = $row->{time_first};
        my $time_last = $row->{time_last};
        printf("%-17s  %-16s  %-16s %-1d %-16s %-10d %-10d\n",
            $mac, $name, $domain, $server, $user, $time_first, $time_last);
    }
    &batch_mode_end;

    # Dump Archive
    $sth = sql_query('node_nbt',['mac','nbname','domain','server','nbuser','active',
                                    'extract(epoch from time_first) as time_first', 
                                    'extract(epoch from time_last) as time_last'],
                           {'active' => 0}, undef, 'order by mac'
                           );

    &batch_mode("$dir/netbios_archive");

    while (my $row = $sth->fetchrow_hashref()) {
        my $active = $row->{active};
        next if $active;
        my $mac    = $row->{mac};  
        my $name   = $row->{nbname};
        my $domain = $row->{domain};
        my $server = $row->{server};
        my $user   = $row->{nbuser};
        my $time_first = $row->{time_first};
        my $time_last = $row->{time_last};
        printf("%-17s  %-16s  %-16s %-1d %-16s %-10d %-10d\n",
            $mac, $name, $domain, $server, $user, $time_first, $time_last);
    }

    &batch_mode_end;

    $BatchMode=$old_batch;
}

=item nightly(no_batch)

Nightly maintance routine that creates backups of the device,node, and node_ip tables. 

Calls expire_data(), nmis_dump(),
mac_dump(), arp_dump(), dev_dump(), netbios_dump(),
db_clean() and VACUUM ANALYZE

=cut

sub nightly {
    my $no_batch = shift || 0;
    # Log backup
    my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime();
    my $month = sprintf("%d%02d",$year+1900,$mon+1);
    &batch_mode("logs/$month/nightly",1) unless (defined $no_batch and $no_batch);
    print "nightly() - Starting nightly cleanup and backup routines\n";

    print "  Cleaning and clearing data...\n";

    # Expire Devices that are X days old
    if (defined $CONFIG{expire_devices} and $CONFIG{expire_devices} =~ /^\d+$/
        and $CONFIG{expire_devices} > 0) 
    {
        print "  expire_devices: Deleting Devices that are older than $CONFIG{expire_devices} days old.\n\n";
        expire_data('device',$CONFIG{expire_devices});
    }
    
    # Expire Archived Node Data X days old
    if (defined $CONFIG{expire_nodes_archive} and $CONFIG{expire_nodes_archive} =~ /^\d+$/
        and $CONFIG{expire_nodes_archive} > 0) 
    {
        print "  expire_nodes_archive: Deleting Archived Node data older than $CONFIG{expire_nodes_archive} days old.\n\n";
        expire_data('node',$CONFIG{expire_nodes_archive},1);
    }

    # Expire Nodes that are X days old
    if (defined $CONFIG{expire_nodes} and $CONFIG{expire_nodes} =~ /^\d+$/
        and $CONFIG{expire_nodes} > 0) 
    {
        print "  expire_nodes: Deleting Nodes older than $CONFIG{expire_nodes} days old.\n\n";
        expire_data('node',$CONFIG{expire_nodes});
    }
    
    # This will clean all node entries on unused ports and uplinks etc. Also runs expire_ips()
    &db_clean;

    my $datadir = homepath('datadir', 'data');
    print "  Backing up Data to $datadir\n";

    die "Can't write to Data Directory.\n" unless -w $datadir;

    &nmis_dump;

    &mac_dump("mac/$month");

    &arp_dump("arp/$month");

    &dev_dump("dev/$month");

    &netbios_dump("netbios/$month");

    print "  Running Database Vacuum...\n";
    sql_vacuum('','print'=>1);

    &batch_mode_end unless $no_batch;
}

=item nmis_dump()

Dumps the device table out to NMIS (http://www.sins.com.au/nmis/) style config file.

=cut

sub nmis_dump {
    
    my $dump_file = $CONFIG{nmis_dump};
    unless (defined $dump_file){
        $DEBUG and print "nmis_dump() Config option nmis_dump not set.\n";
        return;
    }

    print "nmis_dump() - Dumping to $dump_file.csv \n";

    # Force to batch mode to not output to screen.
    local $CONFIG{logextension} = 'csv';
    my $old_batch = $BatchMode;
    $BatchMode=1;
    &batch_mode($dump_file,0,1);    # no header, no timestamp
print << "end_print";
#
# Netdisco - NMIS config file dump
#
# Header
#
node	community	snmpport	net	devicetype	role	group	collect	active
#
# Data
#
end_print
    my $devices = sql_rows('device',['ip','dns','snmp_comm','layers']);

    foreach my $dev (sort { ($a->{dns}||$a->{ip}) cmp ($b->{dns}||$b->{ip}) } @$devices){
        my $ip = $dev->{ip};
        my $layers = $dev->{layers};
        my $device_type = 'switch';
           $device_type = 'router' if has_layer($layers,3);
        my $node        = $dev->{dns}           || $ip;
        my $community   = $dev->{snmp_comm}     || 'public';
        my $snmpport    = $CONFIG{nmis_port}    || 161;
        my $net         = $CONFIG{nmis_net}     || 'lan';
        my $role        = $CONFIG{nmis_role}    || 'core';
        my $group       = $CONFIG{nmis_group}   || 'Network';
        my $collect     = $CONFIG{nmis_collect} || 'true'; 
        my $active      = $CONFIG{nmis_active}  || 'true';
        print join("\t",($node,$community,$snmpport,$net,$device_type,$role,$group,$collect,$active)),"\n";
    }
    batch_mode_end(1);      # dont compress
    $BatchMode=$old_batch;

}

=back

=head2 Graphing Functions

=over

=item graph(no_batch) 

Creates netmap of network.  Calls Netdisco::make_graph() and graph_each()

=cut

sub graph {
    my $no_batch = shift || 0;

    my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime();
    my $month = sprintf("%d%02d",$year+1900,$mon+1);
    &batch_mode("logs/$month/graph") unless $no_batch;
    print "graph() - Creating Graphs.\n";

    tryuse('GraphViz', ver => '2.02', die => 1);

    my $G = make_graph();

    unless (defined $G){
        print "graph() - make_graph() failed.  Try running with debug (-D)\n";
        return;
    }

    my @S = $G->connected_components;

    # Count number of nodes in each subgraph
    my %S_count;
    for (my $i=0;$i< scalar @S;$i++){
        $S_count{$i} = scalar @{$S[$i]};
    }
    
    foreach my $subgraph (sort { $S_count{$b} <=> $S_count{$a} } keys %S_count){
        my $SUBG = $G->copy;
        print "\$S[$subgraph] has $S_count{$subgraph} nodes.\n";
        
        # Remove other subgraphs from this one
        my %S_notme = %S_count;
        delete $S_notme{$subgraph};
        foreach my $other (keys %S_notme){ 
            print "Removing Non-connected nodes: ",join(',',@{$S[$other]}),"\n";
            $SUBG->delete_vertices(@{$S[$other]})
        }
        
        # Create the subgraph
        my $timeout = defined $CONFIG{graph_timeout} ? $CONFIG{graph_timeout} : 60;

        eval {
            alarm($timeout*60);
            graph_each($SUBG,'');
            alarm(0);
        };
        if ($@) {
            if ($@ =~ /timeout/){
                print "! Creating Graph timed out!\n";
            } else {
                print "\n$@\n";
            }
        }
        
        # Facility to create subgraph for each non-connected network segment.  
        # Right now, let's just make the biggest one only.
        last;
    }

    &batch_mode_end unless $no_batch;
}

=item graph_each(Graph_obj, name) 

Generates subgraph. Called from graph().  Calls graph_node().  

Does actual GraphViz calls.

=cut

sub graph_each  {
    my ($G,$name) = @_;

    print "Creating new Graph\n";

    my $graph_defs = {
                     'bgcolor' => $CONFIG{graph_bg}        || 'black',
                     'color'   => $CONFIG{graph_color}     || 'white',
                     'overlap' => $CONFIG{graph_overlap}   || 'scale',
                     'fontpath'=> homepath('graph_fontpath',''),
                     'ranksep' => $CONFIG{graph_ranksep}   || 0.3,
                     'nodesep' => $CONFIG{graph_nodesep}   || 2,
                     'ratio'   => $CONFIG{graph_ratio}     || 'compress',
                     'splines' => $CONFIG{graph_splines} ? 'true' : 'false',
                     'fontcolor' => $CONFIG{node_fontcolor} || 'white',
                     'fontname'  => $CONFIG{node_font}      || 'lucon',
                     'fontsize'  => $CONFIG{node_fontsize}  || 12,
                     };
    my $node_defs = { 
                    'shape'     => $CONFIG{node_shape}     || 'box',
                    'fillcolor' => $CONFIG{node_fillcolor} || 'dimgrey',
                    'fontcolor' => $CONFIG{node_fontcolor} || 'white',
                    'style'     => $CONFIG{node_style}     || 'filled',
                    'fontname'  => $CONFIG{node_font}      || 'lucon',
                    'fontsize'  => $CONFIG{node_fontsize}  || 12,
                    'fixedsize' => $CONFIG{node_fixedsize} || 'true',
                    };
    my $edge_defs = {
                    'color' => $CONFIG{edge_color}         || 'wheat',
                    };

    my $epsilon = undef;
    if (defined $CONFIG{graph_epsilon}){
        $epsilon = "0." . '0' x $CONFIG{graph_epsilon} . '1';
    }
    
    my %gv = (
               directed => 0,
               layout   => $CONFIG{graph_layout} || 'twopi',
               graph    => $graph_defs,
               node     => $node_defs,
               edge     => $edge_defs,
               width    => $CONFIG{graph_x}      || 30,
               height   => $CONFIG{graph_y}      || 30,
               epsilon  => $epsilon,
              );

    my $gv = new GraphViz(%gv);

    my %node_map = ();
    my @nodes = $G->vertices;
    foreach my $dev (@nodes){
        my $node_name = graph_addnode($gv,$dev);
        $node_map{$dev} = $node_name;
    }

    my $root_ip = defined $CONFIG{root_device} ? getip($CONFIG{root_device}) : undef;
    if (defined $root_ip and defined $node_map{$root_ip}){
        my $gv_root_name = $gv->_quote_name($root_ip);
        if (defined $gv_root_name){
            $gv->{GRAPH_ATTRS}->{root}=$gv_root_name;
        }
    }

    my @edges = $G->edges;

    while (my $e = shift @edges){
        my $link = $e->[0];
        my $dest = $e->[1];
        my $speed = $netdisco::GRAPH_SPEED{$link}->{$dest}->{speed};
        if (!defined($speed)) {
            print "  ! No link speed for $link -> $dest\n";
            $speed = 0;
        }
        my %edge = ();
        my $val = ''; my $suffix = '';
        if ($speed =~ /^([\d.]+)\s+([a-z])bps$/i) {
            $val = $1; $suffix = $2;
        }
        if ( ($suffix eq 'k') or ($speed =~ m/(t1|ds3)/i) ){
            $edge{color} = 'green';
            $edge{style} = 'dotted';
        }
        if ($suffix eq 'M'){
            if ($val < 10.0){
                $edge{color} = 'green';
                #$edge{style} = 'dotted';
                $edge{style} = 'dashed';
            } elsif ($val < 100.0){
                $edge{color} = '#8b7e66'; 
                #$edge{style} = 'normal';
                $edge{style} = 'solid';
            } else {
                $edge{color} = '#ffe7ba';
                $edge{style} = 'solid';
            }
        }
        if ($suffix eq 'G'){
            #$edge{style} = 'bold';
            $edge{color} = 'cyan1';
        }

        $gv->add_edge($link => $dest, %edge );
    }

    print "Ignore all warnings about node size.\n";

    if (defined $CONFIG{graph_raw} and $CONFIG{graph_raw}){
        my $graph_raw = homepath('graph_raw');
        print "  Creating raw graph: $graph_raw\n";
        $gv->as_canon($graph_raw);
    }
    if (defined $CONFIG{graph} and $CONFIG{graph}){
        my $graph_gif = homepath('graph');
        print "  Creating graph: $graph_gif \n";
        $gv->as_gif($graph_gif);
    }
    if (defined $CONFIG{graph_png} and $CONFIG{graph_png}){
        my $graph_png = homepath('graph_png');
        print "  Creating png graph: $graph_png\n";
        $gv->as_png($graph_png);
    }
    if (defined $CONFIG{graph_map} and $CONFIG{graph_map}){
        my $graph_map = homepath('graph_map');
        print "  Creating CMAP : $graph_map\n";
        $gv->as_cmap($graph_map);
    }

    if (defined $CONFIG{graph_svg} and $CONFIG{graph_svg}){
        my $graph_svg = homepath('graph_svg');
        print "  Creating SVG : $graph_svg\n";
        $gv->as_svg($graph_svg);
    }
}

=item graph_addnode(graphviz_obj,node_ip) 

Checks for mapping settings in config file and adds node to the GraphViz object.

=cut

sub graph_addnode {
    my $gv = shift;
    # non lexical on purpose
    use vars qw/$ip $label $isdev $devloc/;
    $ip    = shift;
    $label = $netdisco::GRAPH{$ip}->{dns};
    $isdev = $netdisco::GRAPH{$ip}->{isdev};
    $devloc = $netdisco::GRAPH{$ip}->{location};

    my %node = ();

    $label = "($ip)" unless defined($label);
    my $domain = $CONFIG{domain};
    $label =~ s/\Q$domain\E//;
    # hack
    $label =~  s/\.resnet//;

    $node{label} = $label;

    # Dereferencing the scalar by name below
    #   requires that the variable be non-lexical (not my)
    #   we'll create some local non-lexical versions 
    #   that will expire at the end of this block
    # Node Mappings
    foreach my $map (@{$CONFIG{node_map}}){
        my ($var,$regex,$attr,$val) = split(':',$map);

        { no strict 'refs';
           $var =  ${"$var"}; 
        }

        next unless defined $var;

        if ($var =~ /$regex/) {
            print "Giving node $ip $attr = $val\n" if $DEBUG;
            $node{$attr} = $val;
        }
    }

    # URL for image maps
    if ($isdev) {
        $node{URL} = "device.html?ip=$ip";
    } else {
        $node{URL} = "node.html?node=$ip";
        # Overrides any colors given to nodes above. Bug 1094208
        $node{fillcolor} = $CONFIG{node_problem} || 'red';
    }

    if ($CONFIG{graph_clusters} && $devloc) {
        # This odd construct works around a bug in GraphViz.pm's
        # quoting of cluster names.  If it has a name with spaces,
        # it'll just quote it, resulting in creating a subgraph name
        # of cluster_"location with spaces".  This is an illegal name
        # according to the dot grammar, so if the name matches the
        # problematic regexp we make GraphViz.pm generate an internal
        # name by using a leading space in the name.
        #
        # This is bug ID 16912 at rt.cpan.org -
        # http://rt.cpan.org/NoAuth/Bug.html?id=16912
        #
        # Another bug, ID 11514, prevents us from using a combination
        # of name and label attributes to hide the extra space from
        # the user.  However, since it's just a space, hopefully it
        # won't be too noticable.
        my($loc) = $devloc;
        $loc = " " . $loc if ($loc =~ /^[a-zA-Z](\w| )*$/);
        $node{cluster} = { name => $loc };
    }

    my $rv = $gv->add_node($ip, %node);
    return $rv;
}

=back

=head2 Admin Daemon

=over

=item admin_daemon_ctl(cmd)

start,stop,restart,status

=cut

sub admin_daemon_ctl {
    my $cmd = shift;

    if ($cmd eq 'restart') {
        &admin_daemon_ctl('stop');
        &admin_daemon_ctl('start');
    }

    if ($cmd eq 'start'){
        &admin_daemon; 
    }

    if ($cmd eq 'status'){
        my $status = &admin_daemon_status;
        if ($status) {
            print "Admin Daemon is running under pid $status.\n";
        } else {
            print "Admin Daemon is not currently running.\n";
        }
    }

    if ($cmd eq 'stop'){
        my $pid = &admin_daemon_status;
        if ($pid) {
            print "Stopping admin daemon ($pid).\n\n Waiting until current job completes ";
            kill INT => $pid;
            while(admin_daemon_status($pid)){
                print ".";
                sleep(1);
            }
            print "\n";
        } else {
            print "Admin daemon is not currently running!\n";
        }
    }

}

=item admin_daemon_status(pid)

Returns 0 if daemon is not running or returns pid number if running.

pid argument is optional, used in stop function

=cut

sub admin_daemon_status {
    my $pid = shift || &admin_daemon_pid;

    if (defined $pid){
        if (kill 0 => $pid) {
            print "Admin Daemon is already running. ($pid)\n" if $DEBUG;
            return $pid;
        } elsif ($! == EPERM) {             # changed uid
            warn "Admin Daemon ($pid) is running under another user, out of our control.\n";
            return $pid;
        } elsif ($! == ESRCH) {
            print "Admin Daemon ($pid) is deceased, starting new one.\n" if $DEBUG;  # or zombied
            return 0;
        } else {
            warn "No status of $pid: $!\n";
            return 0;
        }
    }
    return 0;
}

=item admin_daemon() 

Resident copy of netdisco to handle requests from the admin panel.

=cut

sub admin_daemon {
    my $pid = undef;
    # Check if we're already running
    if ($pid = &admin_daemon_status){
        print "Admin Daemon is already running. ($pid)\n";
        return;
    }

    $DaemonMode = 1;
    $BatchMode = 1;
    my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime();
    my $month = sprintf("%d%02d",$year+1900,$mon+1);
    &batch_mode("logs/$month/daemon",1);

    my $end_flag = 0;

    local %SIG;
    $SIG{INT} = $SIG{USR1} = $SIG{TERM} = 
        sub {$end_flag++;};
    $SIG{PIPE} = 'IGNORE';

    # Throw Daemon in bg if wanted.
    if (defined $CONFIG{daemon_bg} and $CONFIG{daemon_bg} ){
        die "Can't fork: $!\n" unless defined($pid = fork());
        # Exit parent thread
        exit if $pid;
        print "Running Daemon in Background.\n" if $DEBUG;
    }

    $pid = $$;
    print "Starting new admin panel daemon ($pid)\n";

    # Write out pid file
    &admin_daemon_pid($pid);

    my $poll_interval = $CONFIG{daemon_poll} || 2;

    # Create log dir
    my $datadir = $CONFIG{datadir};
    #system("mkdir -m 0775 -p $datadir/admin") unless (-d "$datadir/admin");

    # Mark left over jobs as bad
    sql_do("UPDATE admin SET status='error' WHERE status = 'running';"); 
    # hmm, looks like insert_or_update() doesnt work for this sort of thing, assumes insert cuz no cases exist.

    # Event Loop
    until ($end_flag){
        # TODO - Die if the database isn't there. 

        my $jobs = sql_rows('admin',['job','extract(epoch from entered) as entered',
                                     'device','action','status', 'username','debug','subaction',
                                     'port','userip','log'],
                            {'status' => 'queued'} );

        # Run each Job
        foreach my $job (sort {$a->{entered} <=> $b->{entered}} @$jobs) {
            admin_daemon_job($job);
            last if $end_flag;
        }

        sleep($poll_interval) unless $end_flag;
    }

    print "Daemon ending ($pid).\n";
}

=item admin_daemon_pid(pid_to_write)

If not supplied arguments, Reads pid of daemon pid from F<netdisco_daemon.pid>

If supplied arguments, writes the pid out to that file.

=cut

sub admin_daemon_pid {
    my $pid = shift;
    my $pid_file = homepath('daemon_pid', 'netdisco_daemon.pid');

    if (defined $pid) {
        print "Writing pid:$pid to $pid_file\n" if $DEBUG;
        open (PIDFILE,"> $pid_file") or die "Can't open $pid_file. $!\n";
        print PIDFILE $pid;
        close (PIDFILE) or die "Can't write $pid_file. $!\n";
    } else {
        print "Reading pid from $pid_file\n" if $DEBUG;
        open (PIDFILE,"< $pid_file") or return undef;
        my $pid = (<PIDFILE>);
        chomp($pid);
        close (PIDFILE);
        return $pid;
    }
}

=item admin_daemon_job(job_obj)

Runs each job. Redirects output to data/admin/job-num-date.log
job_obj is the sql hash object for each job.

=cut

sub admin_daemon_job {
    my $job = shift;
    my $id     = $job->{job};
    my $cmd    = $job->{action};
    my $dev    = $job->{device};
    my $debug  = $job->{debug};
    my $subaction = $job->{subaction};

    print "Daemon: Working on job : $id\n" if $DEBUG;

    # Set to running
    insert_or_update('admin',{'job'=>$id },{'status'=>'running', 'started' => scalar(localtime)});

    # Capture output
    &batch_mode("admin/job-$id");
    my $old_debug = $DEBUG;
    $DEBUG = $debug;

    # Make sure we don't get our output yanked out from under us
    $BatchMode = 0;

    # Device tasks
    my $job_error = 0;
    if ($cmd eq 'macsuck') {
        &load_old_devices;
        &mac_getportmacs;
        &macsuck($dev);
    }

    elsif ($cmd eq 'arpnip') {
        &mac_getportmacs;
        &arpnip($dev);
    }

    elsif ($cmd eq 'refresh') {
        &topo_load_file;
        &discover($dev);
    }

    elsif ($cmd =~ /^delete(\+nodes)?$/) {
        my $del_nodes = $1 eq '+nodes' ? 1 : 0;
        &expire_device($dev,$del_nodes); 
    }

    elsif ($cmd =~ /^nodes-(del|arc)$/){
        my $subcmd = $1;
        my $port = $subaction;
        &expire_nodes($dev, $subcmd eq 'arc' ? 1 : 0, $port);
    }

    elsif ($cmd eq 'portcontrol' or $cmd eq 'vlan'){
        $job_error = port_switch($job); 
    }

    # Discover Tasks

    elsif ($cmd eq 'discover'){
        &discover($subaction);
    }
    
    elsif ($cmd eq 'discover_run'){
        &run($subaction); 
    }

    elsif ($cmd eq 'discover_new'){
        local $New_Only = 1; 
        &run($subaction);
    }

    # Global Tasks
    elsif ($cmd eq 'expire_ips'){
        &expire_ips;
    }

    elsif ($cmd eq 'graph'){
        &graph(1);    
    }

    elsif ($cmd eq 'backup'){
        &nightly(1);
    }

    elsif ($cmd eq 'change_ip'){
        &change_device_ip($dev,$subaction);
    }

    elsif ($cmd eq 'clean_nodes'){
        &db_clean;
    }

    elsif ($cmd eq 'clean_alias'){
        &alias_clean;
    }
    
    else {
        print "Command $cmd not supported.\n";
        $job_error++;
    }

    # Clean Up
    $DEBUG = $old_debug;
    $BatchMode = 1;
    my $output_file = &batch_mode_end('no compress');
    open(OUTFILE, "<$output_file") or die "admin_daemon_job() Can't open $output_file. $!\n";

    # Slurp in log countents to a scalar.
    my $log = undef;
    {
        local $/ = undef;
        $log = <OUTFILE>;
    }
    close (OUTFILE);

    # Mark job done
    my $status = $job_error ? 'error' : 'done';
    insert_or_update('admin',{'job'=>$id },{'status'=>$status, 
                              'finished' => scalar(localtime), 'log'=>$log}
                    );
    return undef;
}

=back

=cut

sub test {
}

sub header{
    print "n e t  d i s c o\n";
    print '-'x50 . "\n";
}

sub version {
    &header;
    my $perl = defined $^V ? join('.',map {ord} split(//,$^V)) : $];
    print "Netdisco Version   : $VERSION\n";
    print "SNMP::Info Version : $SNMP::Info::VERSION\n";
    print "Net-SNMP Version   : $SNMP::VERSION\n";
    print "Perl Version       : $perl\n";
    exit;
}

sub usage{
    print <<"_end_usage_";
Netdisco - Network Discovery and Management ($VERSION)

netdisco [Options] Command(s)

Options:
    -b --batchmode              Batch Mode - Redirect stdout to log files
    -C --configfile   file      Specify path to config file
    -n --nodestoo               Delete nodes when using --expiredevice
    -N --newonly                For --discoverall and --discoverfile
    -P --port         port      Restrict --expirenodes to a single port 
    -V --archive                Archive instead of deleting in --expirenodes
    -D --debug                  DEBUG - Copious output
    -L --nologging              DEBUG - No logging
    -S --dumpsql                DEBUG - Dump SQL commands

Network Commands:
    -r --discoverall  device    Discover network starting from device
    -F --discoverfile file      Discover/Refresh devices from file
    -T --topofile               Import Topology info from topofile
    -R --refresh                Refresh all Devices
    -m --macwalk                Macsuck whole network
    -a --arpwalk                Arpnip whole network
    -w --nbtwalk                Nbtwalk whole network

Device Commands:
    -d --discover     device    Refresh single device
    -M --macsuck      device    Macsuck single device
    -A --arpnip       device    Arpnip  single device
    -W --nbtstat      node      Nbtstat single node
    -E --expiredevice device    Delete device
    -e --expirenodes  device    Delete/Archive nodes on a device
    --expire-nodes-subnet
                      subnet    Runs --expirenodes for all devices in a subnet
    -I --expireips              Expire IPs not seen on switch ports 
    -i --changeip     old new   Change IP address of device and its nodes

Administration:
    -B --backup                 Backups data and runs database cleanup 
    -g --graph                  Create network map files 
    -k --cleanalias             Deletes devices listed as aliases of another
    -K --cleannodes             Clean out nodes listed on uplink ports
    -O --oui                    Import oui.txt into Netdisco
    -p (start,stop,status,restart) Admin Daemon Control
    -u [user] [pw] [port] [admin]  Add/Change User 
    -v --version                Version info for Netdisco components

_end_usage_
    exit;
}

=head1 COPYRIGHT AND LICENCE

Changes in code from 0.92 on:
Copyright (c) 2003,2004 Max Baker - All Rights Reserved

Original Code:
Copyright (c) 2002,2003 Regents of the University of California
All rights reserved.

Redistribution and use in source and binary forms, with or without 
modification, are permitted provided that the following conditions are met:

    * Redistributions of source code must retain the above copyright notice,
      this list of conditions and the following disclaimer.
    * Redistributions in binary form must reproduce the above copyright notice,
      this list of conditions and the following disclaimer in the documentation
      and/or other materials provided with the distribution.
    * Neither the name of the University of California, Santa Cruz nor the 
      names of its contributors may be used to endorse or promote products 
      derived from this software without specific prior written permission.

THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
ANY EXPRESS 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 COPYRIGHT OWNER OR 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.
