### Local Variables: ***
### mode:perl ***
### comment-column:0 ***
### comment-start: "### " ***
### comment-end: "***" ***
### End: ***
#
# ****************DO NOT MOVE OR CHANGE LINES ABOVE THIS*********************
#
# The first set of lines runs perl from any shell. The second set of lines 
# identifies the rest of the file as PERL for EMACS autoformatting. 
# See end of copyright for more information.
#
# 
# -------------------------------------------------------------------
#                                   X-BONE
#
#                          http://www.isi.edu/xbone
#                USC Information Sciences Institute (USC/ISI)
#                   Marina del Rey, California 90292, USA
#                          Copyright (c) 1998-2005
# 
# -------------------------------------------------------------------
#
# Copyright (c) 1998-2005 by the University of Southern California.
# All rights reserved.
#
# Permission to use, copy, modify, and distribute this software and
# its documentation in source and binary forms for non-commercial
# purposes and without fee is hereby granted, provided that the above
# copyright notice appear in all copies and that both the copyright
# notice and this permission notice appear in supporting
# documentation, and that any documentation, advertising materials,
# and other materials related to such distribution and use acknowledge
# that the software was developed by the University of Southern
# California, Information Sciences Institute.  The name of the
# University may not be used to endorse or promote products derived
# from this software without specific prior written permission.
# 
# THE UNIVERSITY OF SOUTHERN CALIFORNIA MAKES NO REPRESENTATIONS ABOUT
# THE SUITABILITY OF THIS SOFTWARE FOR ANY PURPOSE.  THIS SOFTWARE IS
# PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED WARRANTIES,
# INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF
# MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE.
#
# Other copyrights might apply to parts of this software and are so
# noted when applicable.
#
# -------------------------------------------------------------------
#
# Effort partly sponsored by the Defense Advanced Research Projects
# Agency (DARPA) and Air Force Research Laboratory, Air Force Materiel
# Command, USAF, under agreement numbers F30602-98-1-0200 (X-Bone) and
# F30602-01-2-0529 (DynaBone). The views and conclusions contained
# herein are those of the authors and should not be interpreted as
# necessarily representing the official policies or endorsements,
# either expressed or implied, of the Defense Advanced Research
# Projects Agency (DARPA), the Air Force Research Laboratory, or the
# U.S. Government.
#
# This work was partly supported by the NSF STI-XTEND (ANI-0230789)
# and NETFS (ANI-0129689) projects. Any opinions, findings, and
# conclusions or recommendations expressed in this material are those
# of the authors and do not necessarily reflect the views of the
# National Science Foundation.
#
# -------------------------------------------------------------------
#  $RCSfile: XB_Tunnel.pm,v $
#
# $Revision: 1.76 $
#   $Author: pingali $
#     $Date: 2005/04/21 00:21:23 $
#    $State: Exp $
# ----------------------------------------------------------------------------
#
# Primary Author: Lars Eggert

package XB_Tunnel;

require Exporter;
@ISA = qw(Exporter);
@EXPORT = qw();
@EXPORT_OK = qw(up down init);

use strict;
use sigtrap;

use Net::IP::XB_IP; 

use FindBin;

use XB_Params;
use XB_Route;
use XB_Log;
use XB_Utils;

use Net::IP; 

###############################################################################
# UTILITY FUNCTIONS
###############################################################################

# Used by: ALL
# Description: 
#	Configures the given route
# Arguments:
#       @args -- ifconfig command + overlay-specific info
# Returns:
#	1 if successful
#       0 if not
# Exceptions:
#	"exec_command" on error, nothing to clean up by caller
sub exec_command(@) {
  my (@args) = @_;
  my $proc = "exec_command";
  
  XB_Log::log "info" => "-> $proc @args";
  
  eval {
    my $rc = 0xff & system (@args);
    $rc == 0 or
      XB_Log::log "err" => "Configuration of host has failed. Unable ".
	  "create tunnel interfaces. The command is ".
	  "@args failed with $?" and die "ifconfig";
  };

  XB_Log::log "info" => "<- $proc $@";

  return 1 unless $@;

  XB_Log::log "err" => "$proc: caught error: $@"; 
  die "$proc"
} # sub exec_command(@);


# Description:
#       Try to demand-create new interface (for Linux only ) of type $type.
# Arguments:
#       $type   interface type to create a new instance of
# Returns:
#       1 on success
#       undef on failure to create (but no critical error)
# Exceptions:
#       "XB_Tunnel::add" on error, nothing to clean up by caller
sub add ($) {
  my $if_type = shift;
  my $created = undef;

  # print trace line
  XB_Log::log "info", "-> XB_Tunnel::add $if_type";

  eval {
    if($if_type eq "tunl") {
      # load the module always
      if (1) {
        # only install ipip if not there yet
        my $pipe = "lsmod |";
        # pipe to lsmod
        open PIPE, $pipe or XB_Log::log "err", "cannot open pipe $pipe: $!"
          and die "open";
        # see if ipip module already there
        my $found = 0;
        while(<PIPE>)
        {
          if(/ipip/)
          {
            $found = 1;
            XB_Log::log "debug3", "ipip module already installed";
            last;
          }
        }
        # done with pipe
        close PIPE or XB_Log::log "err", "cannot close pipe $pipe: $!"
          and die "close";
        # if we didn't find it, load ipip
        unless($found) {
          # no ipip loaded yet, load it
          my @cmd = ("modprobe", "ipip");
          XB_Log::log "debug3", "@cmd";
          my $rc = 0xff & system(@cmd);
	  ($rc == 0) or 
	    XB_Log::log "err", 
		"Unable to prepare the host for creating tunnels. Command:\n@cmd failed: $!"
            and die "insmod";
        }
      }
      # add a new tunnel (arbitrarily assign remote and local to make it
      # P-to-P; change them later)
      # remote and local ADDR is physical addr
      my @cmd = ("ip", "tunnel", "add", "mode", "ipip", "remote",
                 "192.168.0.1", "local", "192.168.0.1", "ttl", "30");
      XB_Log::log "debug3", "Command:\n@cmd";
      my $rc = 0xff & system(@cmd);
      ($rc == 0) or
	XB_Log::log "err",
	    "Unable to create tunnel at end point. @cmd failed: $!"
	     and die "ip";
      # check if the new tunnel created sucessfully
      my @new_ifs = if_list (0);
      my $new_if = shift @new_ifs;
      if($new_if){
        my $pipe = "ip tunnel show $new_if |";
        open NPIPE, $pipe or 
	  XB_Log::log "err", 
	      "Unable to verify whether the tunnel was created. ". 
	      "Error! cannot open pipe $pipe: $!"
          and die "open";
        while(<NPIPE>){ if (/$new_if/) { $created = 1; } }
        close NPIPE or 
	  XB_Log::log "err", "Error while cleaning up after ". 
	      "creating tunnel endpoints. cannot close pipe ".
	      "$pipe: $!"
          and die "close";
      }
      unless ($created == 1){
        XB_Log::log "err", "Unable to create a tunnel at host.";
	die "ip";
      }
    }
  };
  #print trace line
  XB_Log::log "info", "<- XB_Tunnel::add $if_type";

  return $created unless $@; #success if no exception
  # exception handling
  unless($@ =~ /^(open|close|insmod|ip|)/) {
    # unknown exception caught, log and pass up a defined one
    XB_Log::log "warning", "XB_Tunnel::add: caught unexpected exception $@";
  }
  # pass defined exceptions up to caller
  die "XB_Tunnel::add";
}


# Description: 
#	Return a list of used or unused interfaces.
# Arguments:
#	$which 1 to return used ( = configured or up), 0 to look for
#	unused, -1 for all
# Returns:
#	array of interace names
# Exceptions:
#	"XB_Tunnel::if_list" on error, nothing to clean up by caller
#
sub if_list ($) {
  my $which = shift;
  my @ifs;
  my $if="";
  my $configured = undef;
  my $pipe;

  # print trace line
  XB_Log::log "info", "-> XB_Tunnel::if_list $which";

  eval{
    if ($XB_Params::node_opts{os} =~ /linux/i) {
    # Linux OS
      $pipe = "ifconfig -a |";
      # look at ifconfig output
      open PIPE, $pipe or 
	XB_Log::log "err", "Unable to obtain network interface ".
	    "information while creation/deletion of tunnels. ".
	    "Cannnot open pipe $pipe: $!"
        and die "open";
      while(<PIPE>) {
        # if a new interface follows in the next lines
        if(/^(\w+\d+(:\d+)?)\s+/) {
          my $new_if = $1;
          # remember previous interface (it's one we're looking for)
          if($if and $configured == $which and ($if !~ /eth\d+/) and
            # on Linux, tunl0 cannot be made pointopoint, so skip it
            ($if ne "tunl0") and ($if ne "sit0") and ($if !~ /ip6tnl\d+/)) {
            push @ifs, $if;
          }
          # reset state for scanning the next interface
          $configured = 0;
          $if = $new_if;
        }
        elsif(/\s+inet\s(addr:)?
                (\d{1,3})\.(\d{1,3})\.(\d{1,3})\.(\d{1,3})/x) {
          # if current interface has an inet address, mark configured
          if($2 or $3 or $4 or $5) { $configured = 1; }
        }
      }
      if ($if and $configured == $which and $if ne "tunl0" and 
        $if ne "sit0" and ($if !~ /ip6tnl\d+/)) {push @ifs, $if;}
      close PIPE or 
	XB_Log::log "err", "Unable to cleanup after creating tunnel. ".
	    "Cannot close pipe $pipe: $!"
       and die "close";
      XB_Log::log "debug", "ifs = @ifs";
    } 
    elsif ($XB_Params::node_opts{os} =~ /cisco/i) {
    # Cisco IOS way of doing it
      my $tunnel;
      my @cmd = ("show running-config | include (interface | ip address)");
      my @output = XB_CiscoSSH::show_cmd @cmd;
      my @result = split "\n", $output[0];
      while(@result) {
        my $res = shift @result;
        if ($res =~ /(Tunnel\d+)/) {
          my $res2 = shift @result;
	  $tunnel = $1;
	  if ($which == -1) {
	    push @ifs, $tunnel;
	  } elsif ($which == 1 and $res2 =~ /\d+/ ) {
	    push @ifs, $tunnel;
	  } elsif ($which == 0 and $res2 =~ /no\s+ip\s+address/) {
	    push @ifs, $tunnel;
	  }
	}
      }
    }
    else {
    # Default (FreeBSD)
      # translate $which into ifconfig parameter
      if ($which == 1)     { $which = "-lu"; }
      elsif ($which == 0)  { $which = "-ld"; }
      elsif ($which == -1) { $which = "-l"; }
      else { die "which"; }

      # look at ifconfig output
      my $pipe = "ifconfig $which |";
      XB_Log::log "debug3", "open pipe $pipe";
      open PIPE, $pipe or 
	XB_Log::log "err", "Unable to obtain the network interface information. ". 
	    "Cannnot open pipe $pipe: $!"
      and die "open";

      # get results
      my $if = <PIPE>;
      if (defined $if){
        chomp $if;
        XB_Log::log "debug3", $if;
      } else {
	$if = "";
      }

      # done with pipe
      close PIPE or 
	XB_Log::log "err", "Unable to cleanup after creating tunnel end point. ".
	    "cannot close pipe $pipe: $!"
        and die "close";
      XB_Log::log "debug3", "close pipe $pipe";
      @ifs =  split " ", $if;
    }
  };

  # print trace line
  XB_Log::log "info", "<- XB_Tunnel::if_list $which";
  return @ifs unless $@; # success if no exception

  # exception handling
  unless($@ =~ /^(open|close|XB_CiscoSSH::show_cmd)/) {
    # unknown exception caught, log and pass up a defined one
    XB_Log::log "warning", "XB_Tunnel::if_list: caught unexpected " .
      "exception $@";
  }
  # pass defined exceptions up to caller
  die "XB_Tunnel::if_list";
}


# Description: 
#	Return a list of used or unused interfaces of a certain type.
#       Tries to create a new interface dynamically if none is available.
# Arguments:
#	$type	type of interface to check for
# Returns:
#	array of interace names
# Exceptions:
#	"XB_Tunnel::grab" on error, nothing to clean up by caller
#
sub grab ($) {
  my $type = shift;

  # print trace line
  XB_Log::log "info", "-> XB_Tunnel::grab $type";

  my @ifs;
  eval {
    if ($XB_Params::node_opts{os} =~ /linux/i) {
      # Linux OS
      # get a list of used (up) or unused (down) interfaces
      # process output and remove interfaces of types we don't want
      @ifs = grep /$type\d+/, if_list 0;
      # get rid of unused interface with active alias (for linux tunl)
      # get a list of active interfaces & aliases of the given type
      my @used_ifs = grep /$type\d+/, if_list 1;
      my @new_list;
      foreach my $i (@ifs){
        my @dup = grep /$i:\d+/, @used_ifs;
        if((not defined $dup[0]) || ($dup[0] eq "")){
          # no aliases found, save to use it
          push @new_list, $i;
        }
      }
      @ifs = @new_list;

      if($#ifs == -1) {
        # if we're looking for an unused interface, try creating one if we could
        # not find one
        add $type;
        @ifs = grep /^$type\d+/, if_list 0;
      }
    }
    elsif ($XB_Params::node_opts{ os} =~ /cisco/i) {
      my @used_ifs = if_list (1);
      my $last_used_if = pop @used_ifs;
      my $number;
      if (defined ($last_used_if) and ($last_used_if =~ /^\D+(\d+)/))
	{ $number = $1 + "1"; }
      else { $number = "0"; }
      my $new_if = "Tunnel" . "$number";
      if($new_if){
        my @cmd = ("interface $new_if \n exit \n exit \n");
        my $created = XB_CiscoSSH::cmd @cmd;
        push @ifs, $new_if;
      }
    }
    else {
      # Default OS (FreeBSD)
      # get a list of used (up) or unused (down) interfaces
      # process output and remove interfaces of types we don't want
      @ifs = grep /^$type\d+/, if_list 0;

      if($#ifs == -1) {
        # if we're looking for an unused interface, try creating one if we could
        # not find one
        my $pipe = "ifconfig $type create |";
        XB_Log::log "debug3", "open pipe $pipe";
        open PIPE, $pipe or
	  XB_Log::log "err",
	      "Unable to create tunnel end point. ".
	      "Cannnot open pipe $pipe: $!"
	  and die "open";

        # get results
        my $if = <PIPE>;
        chomp $if;
        push @ifs, $if;
        XB_Log::log "debug3", $if;

        # done with pipe
        close PIPE or 
	  XB_Log::log "err",
	      "Unable to cleanup after configuring the tunnels. ".
	      "Cannot close pipe $pipe: $!"
	  and die "close";
        XB_Log::log "debug3", "close pipe $pipe";
      }
    }
  };

  # print trace line
  XB_Log::log "info", "<- XB_Tunnel::grab $type";

  return @ifs unless $@; # success if no exception

  # exception handling
  unless($@ =~ /^(open|close|XB_Tunnel::if_list|XB_Tunnel::add
	|XB_CiscoSSH::cmd)/) {
    # unknown exception caught, log and pass up a defined one
    XB_Log::log "warning", "XB_Tunnel::grab: caught unexpected exception $@";
  }
  # pass defined exceptions up to caller
  die "XB_Tunnel::grab";
}


# Description:
#	Check if a configured interface with the same outer (local, remote) 
#       address pair as ($l, $r) exists
# Arguments:
#	$type	type of interface to check for
#       $l      local address
#       $r      remote address
# Returns:
#       tunnel interface handle of the matched gif interface; or    
#       undef if none matched
# Exceptions:
#       "XB_Tunnel::find_outer" on error, nothing to clean up by caller
#
sub find_outer ($$$) {
  my ($type, $l, $r) = @_;
  my $result = undef;
  # print trace line
  XB_Log::log "info", "-> XB_Tunnel::find_outer $l, $r";

  eval {
    if ($XB_Params::node_opts{os} =~ /linux/i) {
        # Linux OS
      my $match = undef;
      my $m = "remote";
      my $o = "local";
      my @uuifs;
      my @uifs;

      my $pipe = "ip tunnel show |";
      # open a pipe to get the outer addresses of existing tunnels
      open LPIPE, $pipe or 
	XB_Log::log "err", 
	    "Unable to obtain tunnel interface information. ".
	    "Cannot open pipe $pipe: $!"
       and die "open";
      # look for assigned "physical" ("outer is more appropriate) addresses
      while (<LPIPE>) {
        if(/^(\D+\d+):\s+ip\/ip\s+$m\s+((\d+\.){3}\d+)\s+$o\s+((\d+\.){3}\d+)/){
          if(($4 eq $l) && ($2 eq $r)){
            $match = $1;
            last;
          }
        }
      }
      close LPIPE or 
	XB_Log::log "err", "Unable to cleanup after obtaining interface ".
	    "status information. cannot close pipe $pipe: $!"
      and die "close";

      # do the following only if we found a match (tunlx)
      if(defined $match){
        # search the unused ones since the primary interface tunlx might be here
        @uuifs = grep /^$match$/, if_list 0;
        # search the used ones to determine the first available alais tunlx:y
        @uifs = grep /^$match(:\d+)?$/, if_list 1;
        # determine the first available alias name
        if(defined $uuifs[0]) {
          $result = $uuifs[0];
        }else{
          my $alias_no = 0;
          foreach my $i (@uifs){
            if($i =~ /$match:(\d+)/){
              if($1 == $alias_no){
                $alias_no++;
              }else{
                $result = $match.":$alias_no";
                last;
              }
            }
          }
          if(! defined $result) { $result = $match.":$alias_no"; }
        }
      }
    }
    elsif ($XB_Params::node_opts{ os} =~ /cisco/i) {
      my @ifs = grep {/^$type\d+/} if_list -1;
      my $ln = new Net::IP ($l);
      my $rn = new Net::IP ($r);
      foreach my $if (@ifs) {
        my ($lv, $rv);
        my @cmd = ("show interface $if");
        my @output = XB_CiscoSSH::show_cmd @cmd;
        @output = split "\n", $output[0];
        foreach my $each (0..($#output-1)) {
          my $line = shift @output;
	  if ($line =~ /\s*Tunnel\s+source\s+((\d{1,3}\.){3}\d{1,3}),\s+destination\s+((\d{1,3}\.){3}\d{1,3})/g){
            $lv = $1;   $rv = $3;
	  }
	}
	my $n1 = new Net::IP($lv);
	my $n2 = new Net::IP($rv);
	next if (not (defined $n1 and defined $n2));
	if (($n1->ip() eq $ln->ip()) and ($n2->ip() eq $rn->ip())){
	  $result = $if;
	  last;
	}
      }
    }
    else {
    # Default OS (FreeBSD)
    
    # get all interfaces (-1 = all)
      my @ifs = grep { /^$type\d+/ } if_list -1;
      my $ln = new Net::IP($l); 
      my $rn = new Net::IP($r); 	  

      foreach my $if (@ifs) {

        my $pipe = "ifconfig $if |";
        XB_Log::log "debug3", "open pipe $pipe";
        open PIPE, $pipe or
	  XB_Log::log "err", "Unable to obtain tunnel interface ".
	      "information. Cannot open pipe $pipe: $!"
	  and die "open";

        # look for assigned "physical" ("outer" is more appropriate)
        # addresses
        while (<PIPE>) {
	  XB_Log::log "debug3", $_;
	
	  if ( /^\s+tunnel/ ){
	    #tunnel inet 172.26.0.1 --> 172.26.0.2
	    #tunnel inet6 3ffe:801:1000:0:2b0:d0ff:fe78:c82f --> 3ffe:801:1000:0:207:e9ff:fe09:4381
	    chomp;
	    my @components = split / +/;
	    my $n1 = new Net::IP($components[2]);
	    my $n2 = new Net::IP($components[4]);
	    next if (not (defined $n1 and defined $n2));
	    if (($n1->ip() eq $ln->ip()) and ($n2->ip() eq $rn->ip())){
	      $result = $if;
	      last;
	    } # match
	  } # tunnel
        } # PIPE

        close PIPE or
	  XB_Log::log "err", "Unable to cleanup after obtained tunnel ".
	      "interface information. Cannot close pipe $pipe: $!"
          and die "close";
        XB_Log::log "debug3", "close pipe $pipe";
      }
    }
  };

  # print trace line
  XB_Log::log "info", "<- XB_Tunnel::find_outer $l $r";

  return $result unless $@; # success if no exception

  die "XB_Tunnel::find_outer $@";
}


###############################################################################
# EXPORTED API
###############################################################################


# Description: 
#	Configure tunnel interface.
# Arguments: pass a hash containing these variables 
#       localaddr       => local virtual address (inner header source)
#       remoteaddr      => remote virtual address (inner header destination)
#       netmask         => netmask for tunnel (on inner addresses) 
#                          (ffff:...:fffc for ipv6
#                          255.255.255.252 for ipv4)
#       physlocaladdr   => local address (outer header source)
#       physremoteaddr  => remote address (outer header destination) 
#       layer           => tunnel layer ("link" or "network")
#       name            => <node name>
#       routing_method  => routing method ("static" or "dynamic")
#
# Returns:
#	tunnel handle
# Exceptions:
#	"XB_Tunnel::up" on error, nothing to clean up by caller
#
sub up ($){

  my $inputhash = shift @_; 

  die if (not defined $inputhash);

  my $lv     = $inputhash->{'virtlocaladdr'};
  my $rv     = $inputhash->{'virtremoteaddr'};
  my $l      = $inputhash->{'physlocaladdr'};
  my $r      = $inputhash->{'physremoteaddr'};
  my $ly     = $inputhash->{'layer'};
  my $oid    = $inputhash->{'oid'};
  my $rm     = $inputhash->{'routing_method'};
  my $nm_arg = $inputhash->{'netmask'};
  my ($nm_opt, $nm, $family) = ("", "", "");

  # print trace line
  XB_Log::log "info", "-> XB_Tunnel::up $lv, $rv, $nm_arg, $l, $r, " .
                      "$ly, $oid, $rm";

  my $tag;

  eval {
    if ($XB_Params::node_opts{os} =~ /linux/i) {
        # Linux OS
      my $dip = new Net::IP::XB_IP($nm_arg);
      die ("Incorrect format: ". $nm_arg) if (not defined $dip);
      if ($dip->version() == 4) {
	$nm_opt = "netmask";
        $nm = $nm_arg; #we assume that the correct netmask is passed 
	               # from the OM.
      } else {
        XB_Log::log "err", "Linux ipv6 is not supported" and
	    die "Linuxv6";
      }

      my $alias = 1;
      my $if;

      # check arguments: well-formedness of IP addresses
      foreach my $addr ($lv, $rv, $l, $r) {
        my $n = new Net::IP($addr);
        if ( not defined $n) {
        XB_Log::log "err", "Syntax error in the message to the ".
	    "resource daemon from the overlay manager. ".
	    "Illegal IP address $addr specified ".
	    "in the command from the overlay. " and die "args";
        }
      }

      # check arguments: layer
      unless ($ly =~ /^(link|network)$/) {
        XB_Log::log "err", "Syntax error in the message to the ".
	    "resource daemon from the overlay manager. ".
	    "Invalid layer $ly" and die "args";
      }

      # check arguments: routing method
      unless ($rm =~ /^(static|dynamic)$/) {
        XB_Log::log "err", "Syntax error in the message to the ".
	    "resource daemon from the overlay manager. ".
	    "Invalid routing method $rm" and die "args";
      }

      # check for interfaces with the same outer end points that we can reuse
      $if = find_outer "tunl", $l, $r;

      unless ($if) {
        # no tunl interface between $l->$r found; try to find an unused one
        my @ifs = grab "tunl";
        $if = pop @ifs;
        $alias = 0;
      }

      unless ($if) {
        # if we still couldn't find one, we're screwed
        XB_Log::log "err", "Syntax error in the message to the ".
	    "resource daemon from the overlay manager. ".
	    "No unused tunneling interfaces" and die "none";
      }

      # ip tunnel change (the remote and local we arbitrarily chose)
      if (!$alias)
      {
        # don't do this if it's an alias since it's outer header is
        # already up
        my @cmd = ("ip", "tunnel", "change", $if, "mode", "ipip",
		   "remote",$r, "local", $l);
        XB_Log::log "debug3", "@cmd";
        my $rc = 0xff & system(@cmd);
	($rc == 0) or 
	  XB_Log::log "err", "Unable to modify tunnel properties. ".
	      "@cmd failed: $!" and die "ip";
      }

      # create tunnel tag encoding all the information needed for tunl_down
      #
      for my $p ($if, $lv, $rv, $ly, $oid, $rm, $nm) {
        # make sure none of the arguments contains the separator
        if ($p =~ /\|/) {
          XB_Log::log "err",
	      "Unable to create state information at the ".
	      "node daemon. Element $p contains separator '|'"
	  and die "none";
        }
      }
      $tag = join "|", ($if, $lv, $rv, $ly, $oid, $rm, $nm);

      # Run the command now
      exec_command  "ifconfig", $if, $lv, "pointopoint", $rv,
            $nm_opt, $nm, "up";
    
      #
      # add $lv as an alias to lo0 only when dynamic routing is not 
      # specified
      if ($XB_Params::REVISITATION == 0 and $rm !~ /(dynamic)/i) {
	exec_command "ifconfig", "lo:0", $lv, "netmask", "255.255.255.255",
	"up";
      } #revisitation
    }
    elsif ($XB_Params::node_opts{os} =~ /cisco/i) {
      # CISCO
      my $dip = new Net::IP::XB_IP($nm_arg);
      die ("Incorrect format: ". $nm_arg) if (not defined $dip);
      if ($dip->version() == 4) { $nm = $nm_arg; }
      else {
        XB_Log::log "err", "Cisco ipv6 is not supported" and die "Ciscov6";
      }
      my ($if, $existing_interface, $cmd);
      $if = find_outer "Tunnel", $l, $r;
      if ($if) {
        $existing_interface = "1";
      } else {
      # no Tunnel interface between $l->$r found; try to find an unused one
        my @ifs = grab "Tunnel";
        $if = pop @ifs;
      }
      unless ($if) {
      # if we still couldn't find one, we're screwed
        XB_Log::log "err", "no unused tunneling interfaces" and die "none";
      }
      # create tunnel tag encoding all the information needed for tun_down
      for my $p ($if, $lv, $rv, $ly, $oid, $rm, $nm) {
      # make sure none of the arguments contains the separator
        if ($p =~ /\|/) {
          XB_Log::log "err", "$p contains separator '|'" and die "none";
        }
      }
      $tag = join "|", ($if, $lv, $rv, $ly, $oid, $rm, $nm);
      #  Run the command now
      if ($existing_interface) {
        $cmd = "ip route $rv 255.255.255.255 $if \n  interface $if \n ip address $lv $nm secondary \n tunnel source $l \n tunnel destination $r \n tunnel mode ipip \n exit \n exit \n";
      } else {
        $cmd = "ip route $rv 255.255.255.255 $if \n  interface $if \n ip address $lv $nm \n tunnel source $l \n tunnel destination $r \n tunnel mode ipip \n exit \n exit \n";
      }
      my @output = XB_CiscoSSH::cmd $cmd;
    }
    else {
        # Default OS (FreeBSD)

      # process the network mask to generate the correct mask, family 
      my $dip = new Net::IP::XB_IP($nm_arg);
      die ("Incorrect format: " . $nm_arg) if (not defined $dip);
      if ($dip->version() == 4){
        $nm_opt = "netmask";
        $nm  = $nm_arg; #$dip->mask;
        $family = "inet";
      } else {
        $nm_opt = "prefixlen";
        $nm  = 128; #$dip->masklen;
        $family = "inet6";
      }

      # check arguments: well-formedness of IP addresses
      foreach my $addr ($lv, $rv, $l, $r) {
        my $n = new Net::IP($addr);
        if ( not defined $n){
	  XB_Log::log "err", "Syntax error in the message to ".
	      "the resource daemon from the overlay manager. ".
	      "Illegal IP address $addr" and die "args";
        }
      }

      # check arguments: layer
      unless ($ly =~ /^(link|network)$/) {
	  XB_Log::log "err", "Syntax error in the message to ".
	      "the resource daemon from the overlay manager. ".
	      "Invalid layer $ly" and die "args";
      }

      # check arguments: routing method
      unless ($rm =~ /^(static|dynamic)$/) {
	  XB_Log::log "err", "Syntax error in the message to ".
	      "the resource daemon from the overlay manager. " .
	      "Invalid routing method $rm" and die "args";
      }

      # check for interfaces with the same outer end points that we
      # can reuse
      my $if = find_outer "gif", $l, $r;
      unless ($if) {
        # no gif interface between $l->$r found; try to find an unused
        # one
        my @ifs = grab "gif";
        $if = pop @ifs;
      }

      unless ($if) {
        # if we still couldn't find one, we're screwed
	  XB_Log::log "err", "Syntax error in the message to ".
	      "the resource daemon from the overlay manager. ".
	      "No unused tunneling interfaces" and die "none";
      }

      #
      # create tunnel tag encoding all the information needed for gif_down
      # 
      for my $p ($if, $lv, $rv, $ly, $oid, $rm, $nm) {
      # make sure none of the arguments contains the separator
        if ($p =~ /\|/) { 
	  XB_Log::log "err", "Syntax error in the message to ".
	      "the resource daemon from the overlay manager. ".
	      "$p contains separator '|'" and die "none";
        }
      }
      $tag = join "|", ($if, $lv, $rv, $ly, $oid, $rm, $nm);

      # 
      # Run the command now.
      #
      exec_command "ifconfig", $if, "$family", "alias", $lv, $rv,
        "tunnel", $l, $r, "$nm_opt", $nm, "alias", "up";

      #
      # Add $lv as an alias to lo0. only if revisitation is not 
      # specified or if dynamic routing is enabled. 
      if ($XB_Params::REVISITATION == 0 and $rm !~ /(dynamic)/i) {
        # revisitation does not work with aliases created. 
        if ($family eq "inet"){ 
  	  exec_command "ifconfig", "lo0", "$family", "alias", $lv, "netmask", "255.255.255.255", "up";
        } else {
	  exec_command "ifconfig", "lo0", "$family", "alias", $lv, "prefixlen", "128", "up";
        }
      } # revisitation 

    }  
  }; #eval

  # print trace line
  XB_Log::log "info", "<- XB_Tunnel::up $lv, $rv, $nm, $l, $r, $ly, $oid, $rm";
  return $tag unless $@; # success if no exception

  # exception handling
  if ($@ =~ /^(exec_command)/) {
    # undo stuff
    eval { down $tag; } 
  } elsif ($@ =~ /^(args|none)/) { 
    # nothingto undo, died before anything was changed
  } else {
    # unknown exception caught, log and pass up a defined one
    XB_Log::log "warning", "XB_Tunnel::up: caught unexpected exception $@";
  }

  # pass defined exceptions up to caller
  die "XB_Tunnel::up";
}


# Description: 
#	Tear down tunnel $tag.
# Arguments:
#	$if	tunnel tag (return value from corresponding XB_Tunnel::up)
# Returns:
#	1 on success
# Exceptions:
#	"XB_Tunnel::down" on error, nothing to clean up by caller
#
sub down ($) {
  my $tag = shift;

  # print trace line
  XB_Log::log "info", "-> XB_Tunnel::down $tag";

  # check tag
  my ($if, $lv, $rv, $ly, $oid, $rm, $nm) = split /\|/, $tag;
  my $fail;

  if ($XB_Params::node_opts{os} =~ /linux/i) {
        # Linux OS
    my $alias_no;
    my $pif;
    eval {
      # check arguments: interface
      unless ($if =~ /^tunl\d+(:\d+)?/) {
	  XB_Log::log "err", "Overlay status information corrupted. ".
	      "invalid interface $if" and die "args";
      }

      # check arguments: well-formedness of IP addresses/netmask
      foreach my $addr ($lv, $rv) {
        my $n = new Net::IP($addr);
        if ( not defined $n) {
	  XB_Log::log "err", "Overlay status information corrupted. ".
	      "Illegal IP address $addr" and die "args";
        }
      }

      # check arguments: layer
      unless ($ly =~ /^(link|network)$/) {
	  XB_Log::log "err", "Overlay status information corrupted. ".
	      "Invalid layer $ly" and die "args";
      }

      # check arguments: routing method
      unless ($rm =~ /^(static|dynamic)$/) {
	  XB_Log::log "err", "Overlay status information corrupted. ".
	      "Invalid routing method $rm" and die "args";
      }
    }; 

    # if we've had an error before here, the tag is invalid - bail out
    # now, there's nothing we can do without all the tag info
    goto DONE if $@;
    #
    # tear the tunnel down, and ignore errors along the way
    #
    $fail = 0;
    eval {
      # delete the given alias with "ifconfig down" first, don't do
      # remove the tunnel yet, need to know if it's the last one

      $pif = ($if =~ /^(\D+\d+):\d+/ ? $1 : $if);
      # check if any alias exit
      my @uifs = grep /^$pif(:\d+)?$/, if_list 1;
      $alias_no = 0;
      foreach my $i (@uifs) { $alias_no++;}
      XB_Log::log "debug3", "alias_no = $alias_no";
      if($pif eq $if){
        # this means we are the primary interface, don't bring it down unless
        # there are NO other aliases
        # IPv6 arg: pas 0.0.0.0 to ifconfig
        $alias_no--;
        if(! $alias_no) {     # no other alias, bring it down
          exec_command "ifconfig", $if, "0.0.0.0", "down";

        }else{                  # leave it up since other aliases exist
          exec_command "ifconfig", $if, "0.0.0.0";
        }
      }
      else{
       # just an alias, bring it down
        exec_command "ifconfig", $if, "down";
        $alias_no--;
        # check if last one, if yes, bring down the primary as well
        if(! $alias_no)
        {
          exec_command "ifconfig", $pif, "0.0.0.0", "down";
        }
      }
    };
    $fail++ if $@;
    #
    # destroy the interface
    #
    eval {
      # if there are no aliases left on the interface, delete it
      if (!$alias_no) {
        # delete the tunnel interface
        my @cmd = ("ip","tunnel","del",$pif);
        XB_Log::log "debug3", "@cmd";
        my $rc = 0xff & system(@cmd);
	($rc == 0) or XB_Log::log "err", 
	  "Unable to delete the tunnel. ".
	  "@cmd failed: $!"
	  and die "ip tunnel del";
      }
    };
    $fail++ if $@;
    
    #
    # delete the alias added when bringing up tunnels
    eval {
      if ($XB_Params::REVISITATION == 0 and $rm !~ /(dynamic)/i) {
        exec_command "ifconfig", "lo:0", $lv, "down";
      }
    }; #eval
    $fail++ if $@;

  } elsif ($XB_Params::node_opts{ os} =~ /cisco/i) {
    $fail = 0;
    eval {
      my $cmd = "no ip route $rv 255.255.255.255 $if \n interface $if \n no ip address $lv $nm secondary \n exit \n exit \n";
      my @output = XB_CiscoSSH::cmd $cmd;
    };
    $fail++ if $@;
 
    my $count = 0;
    eval {
      my (@l, @r, $interface, @secondary);
      my @cmd = ("show running-config | begin ($if)");
      my @output = XB_CiscoSSH::show_cmd @cmd;
      my @result = split "\n", $output[0];
      foreach my $each (0..($#result-1)) {
        my $line = shift @result;
        if ($line =~ /\s*interface\s+(\w+)/) { $interface = $1; next; }
        if (($line =~ /\s*ip\s+address\s+((\d{1,3}\.){3}\d{1,3})\s+((\d{1,3}\.){3}\d{1,3})\s*(\w*)/) and ($interface eq $if)) {
          push @l, $1;
          push @secondary, $5;  next;
        }
        if($line =~ /\s*ip\s+route\s+((\d{1,3}\.){3}\d{1,3})\s+((\d{1,3}\.){3}\d{1,3})\s+$if/) { push @r, $1; next; }
      }
      if ((defined $r[0]) and (defined $l[0])){
        $count++;
      }
    };
    $fail++ if $@;

    eval {
      if ($count == 0) {
        my @cmd = ("no interface $if \n exit \n");
        XB_Log::log "debug3", "@cmd";
        my @result = XB_CiscoSSH::cmd @cmd;
      }
    };
    $fail++ if $@;
  }
  else {
    # Default OS (FreeBSD)
    #
    # sanity check of the arguments.
    # 
    eval {

      # check arguments: interface
      unless ($if =~ /^gif\d+$/) {
        XB_Log::log "err", "invalid interface $if" and die "args";
      }

      # check arguments: well-formedness of IP addresses/netmask
      foreach my $addr ($lv, $rv) {
        my $n = new Net::IP($addr); 
        if ( not defined $n){ 
	  XB_Log::log "err", "Overlay status information corrupted. ".
	      "Illegal IP address $addr" and die "args";
        }
      }

      # check arguments: layer
      unless ($ly =~ /^(link|network)$/) {
	  XB_Log::log "err", "Overlay status information corrupted. ".
	      "Invalid layer $ly" and die "args";
      }

      # check arguments: routing method
      unless ($rm =~ /^(static|dynamic)$/) {
	XB_Log::log "err", "Overlay status information corrupted. ".
	    "Invalid routing method $rm" and die "args";
      }

    };

    # if we've had an error before here, the tag is invalid - bail out
    # now, there's nothing we can do without all the tag info
    goto DONE if $@;

    #
    # tear the tunnel down, and ignore errors along the way
    #
    $fail = 0;
    eval {
      # delete the given alias with "ifconfig delete" first, don't do
      # remove the tunnel yet, need to know if it's the last one
      my $family = "inet"; 
      my $n = new Net::IP ($lv); 
      if (defined $n and $n->version() == 6){ 
        $family = "inet6"; 
      }
      exec_command "ifconfig", $if, $family, $lv, $rv, "delete";
    };
    $fail++ if $@;

    #
    # now count the remaining xbone aliases - if there aren't any left,
    # we can delete the interface
    # 
    my $count = 0;
    eval {
      my $pipe = "ifconfig $if |";
      XB_Log::log "debug3", "open pipe $pipe";
      open PIPE, $pipe or
	XB_Log::log "err",
	    "Unable to obtain tunnel information. ".
	    "Cannot open pipe $pipe: $!"
        and die "open";

      # look for assigned virtual addresses 
      while (<PIPE>) {
	chomp $_;
        XB_Log::log "debug3", $_;
	
	# strip the initial part of the text.
        if ( /inet/ and /-->/ and not(/tunnel/)){
	  XB_Log::log "debug3", "matched : $_";
	  #inet 172.26.0.1 --> 172.26.0.2
	  #inet6 3ffe:801:1000:0:2b0:d0ff:fe78:c82f --> 3ffe:801:1000:0:207:e9ff:fe09:4381

	  my @components = split / +/;
	  my $n1 = new Net::IP($components[1]);
	  my $n2 = new Net::IP($components[3]);
	  XB_Log::log "debug3", "n1 = $components[1], n2 = $components[3]";
	  if ((defined $n1) and (defined $n2)){
	    $count++; 
	  }
        }
      }; # while ifconfig lines...

      # done with pipe
      close PIPE or 
	XB_Log::log "err", 
	    "Unable to cleanup after deleting tunnel interfaces. ".
	    "cannot close pipe $pipe: $!"
        and die "close";
      XB_Log::log "debug3", "close pipe $pipe";
    };
    $fail++ if $@;
  
    # 
    # destroy the interface 
    # 
    eval {
      # if there are no aliases left on the interface, delete it
      if ($count == 0) {
        # delete the gif interface
        my @cmd = ("ifconfig", $if, "destroy");
        XB_Log::log "debug3", "@cmd";
        my $rc = 0xff & system(@cmd);
	($rc == 0) or
	  XB_Log::log "err", "Unable to destroy tunnel interfaces. ".
	      "@cmd failed: $!"
   	  and die "ifconfig";
      }
    }; 
    $fail++ if $@;
  
    #
    # create an alias on lo0 
    # 
    eval {
      # Delete the alias added when bringing up tunnels.
      if ($XB_Params::REVISITATION == 0 and $rm !~ /(dynamic)/i) {
        my $n = new Net::IP ($lv); 
        my $family = "inet"; 
        if ( defined $n and $n->version() == 6){ $family = "inet6"; };

        exec_command "ifconfig", "lo0", "$family", "-alias", $lv; 
      } # REVISITATION 
    }; #eval..
    $fail++ if $@;
  }

   DONE:
  # print trace line
  XB_Log::log "info", "<- XB_Tunnel::down $tag $@";

  return 1 unless $fail; # success if no exception

  # exception handling, nothing to do, just pass exception up to caller
  die "XB_Tunnel::down";
}


# Description: 
#	Initialize tunneling module. Must be called once prior to using
#       any other funtion in this module.
# Arguments:
#       none 
# Returns:
#	1 on success
# Exceptions:
#	"XB_Tunnel::init" on error, nothing to clean up by caller
#
sub init () {
  # print trace line
  XB_Log::log "info", "-> XB_Tunnel::init";

  # check if we're on a recent KAME (FreeBSD-4.5 or later)
  my @fields = split /\//, 
    XB_Utils::sysctl_read "net.inet6.ip6.kame_version";

  unless ($fields[0] >= 20010528) {
    XB_Log::log "err", "Probe for KAME version failed. Aborting." 
	and die "XB_Tunnel::init";
  }

  # print trace line
  XB_Log::log "info", "<- XB_Tunnel::init";

  return 1;
}


1;