IP Fail over script writen in perl

This perl script provides an IP Fail Over enviroment, by testing the routes an jumping from one to another if the current route falls out of service.
More information on script comments.

#!/usr/bin/perl  
#
# (c) Daniel Hilst Selli, 2011, <danielhilst@gmail.com>
#
# IP FAIL OVER 
#
# Desc: Provides a IP FAIL OVER environment by testing the current routing and
#       changing it to next route if it fails. "ip" utility is used to change
#       the routes. 
#
# Usage: You need to configure the routes at @routes array. 
# /\_______update_the_comment_______________________/\
#
#       When ping fails on current route, the script searches for a new valid
#       route. That valid route will be the new default route.
#
#       The entry 0 is the standard route. You can request the script to go back
#       to standar route by sending a SIGUSR to it. The standard route will be
#       checked, if is not yet valid the script will not change the current
#       route.
#
#       $dest_host is the url that you will ping. I have setted it to
#       "www.google.com" but you can change it if needed.
#
#       This script goes to background as soon as possible. As a service should
#       do. You can define the log of it on $daemon_log variable. Its default is
#       the name of the script followed by ".log".
#


use strict;
use warnings; 
use Net::Ping; 
use POSIX qw(setsid);
use Time::localtime;
use Fcntl qw(:flock SEEK_END);


#
# START CONFIGURE HERE
#
my @routes = (
        {
#                iface =>  "ppp0",
                source => "200.171.87.72",
                gateway => "dev ppp0",
  init =>  sub {
      print ctime() .  " Rebooting ppp0\n";
      `ifdown ppp0`;
      `ifup ppp0`;
  },
        },
        {
                iface => "eth2",
                source => undef,
                gateway => "via 192.168.5.1",
        },
);
my $dest_host = "www.google.com";
my $standard_route = 1; # Used as index to @routes. So $routes[0] is the 
                        # standard route   
my $daemon_log = $0 . ".log"; 
#
# STOP CONFIGURE HERE
#



#
# Initialization 
# 
my $continue = 1;
my $pid;
my $indx = undef; 
my $current_route = undef;
my $pid_file = "$0.pid";
my $pid_fh = undef;
my $file_lock_fh = undef;
my $file_lock_fname = "$0.lck";
$| = 1; # unbuffered STDOUT

$SIG{TERM} = sub { $continue = 0 };

$SIG{USR1} = sub {
        print ctime() . " Standard route requested\n";
        if ($routes[$standard_route] == $current_route) {
                print ctime() . " the standard route is already".
                " being used, nothing to do\n";
        } elsif ($routes[$standard_route]->{ping}->ping($dest_host)) {
                print ctime() .  " Standard route is valid, ".
                "backing to it\n";
                $indx = $standard_route;
                set_route();
        } else {
                print ctime() . " Standard route offline, nothing to do\n";
        }
};

sub init_routes {
        for my $r (@routes) {
                if ($r->{source}) {
                        $r->{ping} = Net::Ping->new("icmp", 1);
                        $r->{ping}->bind($r->{source});
  } elsif ($r->{iface}) {
      $r->{ping} = Net::Ping->new("icmp", 1, 64, $r->{iface}); 
  } else {
      die "Route without source and iface member\n".
   "You need at least one of them\n";
  }
        } 

        die "\$standard_out setted to out of bounds of ". 
        "\@routes array\n" if $standard_route > $#routes;

        $indx = $standard_route;
        set_route();
}

sub do_flock {
        open($file_lock_fh, ">$file_lock_fname") or die "Can't open lock file".
 " $file_lock_fname";
        unless(flock($file_lock_fh, LOCK_EX | LOCK_NB)) {
                die "Cannot obtain lock. If there is another instance of".
                "this running kill it and try again";    
        }
}

sub do_funlock {
        my ($fname) = @_; 
        unless(flock($file_lock_fh, LOCK_UN)) {
                die "Cannot release lock, this shouldn't be happening";
        }
        close($file_lock_fh);
}

sub set_route {
        $current_route =  $routes[$indx];
        print ctime() . " Changing route to ".
        "$current_route->{gateway}\n";
 
 $current_route->{init}() if $current_route->{init};

        my $error = `ip route del default`; 
        print " Can't delete default route\n" if $error;

        $error = `ip route add default $current_route->{gateway}`;
        die " Can't add default route" if $error;

 print ctime() . " Route changed\n";
}

# Args
# 1 => Ref to global $indx variable
# 2 => The limmit 
sub next_indx {
        my ($indx, $limit) = @_;
        $$indx++;
        if ($$indx > $limit) {
                $$indx = 0;
        }
}


sub on_fail {
        my $error;
        
        print ctime() . " Ping failed\n";
        print ctime() . " Default route is $current_route->{gateway}. Adding new route\n";
        $error = `ip route del default via $current_route->{gateway}`; 
        die $! if $error;

        next_indx(\$indx, $#routes);
        set_route();

        print ctime() . " New route $current_route->{gateway} added\n";
}


sub daemonise {
        umask 0;
        open STDIN, '/dev/null'   or die "Can't read /dev/null: $!";
        open STDOUT, ">$daemon_log" or die "Can't write to log: $!";
        open STDERR, ">$daemon_log" or die "Can't write to log: $!";
        defined(my $pid = fork)   or die "Can't fork: $!";
        exit if $pid;
        setsid                    or die "Can't start a new session: $!"; }

#
# MAIN LOOP
#


do_flock();
daemonise();
init_routes();
while ($continue) {
        if ($current_route->{ping}->ping($dest_host)) {
#               print ctime();
#   if ($current_route->{source}) {
#       print " $current_route->{source} live\n";
#   } else {
#       print " $current_route->{iface} live\n";
#   }
                sleep(3);
        } else {
                on_fail();
        }
}
do_funlock();


# vim:ft=perl:tabstop=8:shiftwidth=4:smarttab:noexpandtab:softtabstop=4:ai:tw=80