### 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.
#
# -------------------------------------------------------------------
#
##################################################
#
#
# XBone API utilities used both by the OM and the GUI
#
# Principal author: Gregory Finn
#
##################################################
package XB_XOL;
require Exporter;
@ISA = qw(Exporter);
@EXPORT = qw();
@EXPORT_OK = qw();
use strict;
#use Data::Dumper; # Used for debugging, comment out for release.
#use XB_Log; # Problematic. Both GUI and OM use this package.
use XB_Params;
#######################################################################
#
# XB_qstring ( string )
#
# Returns a properly quoted version of its string argument. If string
# contains whitespace or single quotes, it is returned double quoted.
#######################################################################
sub XB_qstring ($)
{
my ($arg) = @_;
$arg =~ s/^\s+//; # Eliminate leading and trailing whitespace
$arg =~ s/\s+$//;
if ($arg =~ /^".+"$/)
{ return ($arg); }
elsif ($arg =~ /^'.+'$/)
{ return ($arg); }
elsif ($arg =~ /\s+/)
{ return ("\'$arg\'"); };
return ($arg);
}
#######################################################################
#
# XB_build_criterions ( key, value, key, value, ... )
#
# Accepts as an argument a list (key value key value ...) where
# each key/value pair is a CRITERION. For each pair the
# syntactically correct CRITERION string "(key value)" is created.
#
# Normally a reference to the string containing all the CRITERION
# strings is returned. A value of undef is returned if the argument
# list is not balanced, that is, some key is missing its corresponding
# value.
#######################################################################
sub XB_build_criterions (@)
{
my ($key, $value, $string);
if (scalar (@_) % 2) { return (undef); };
$string = "";
while (1)
{
$key = shift;
$value = shift;
if (!defined ($key))
{ return (\$string); };
$string .= " (" . XB_qstring ($key) . " " .
XB_qstring ($value) . ") ";
}
}
######################################################################
#
# sub XB_check_criterion_values ( href keylist ... )
#
# href references a hash that contains CRITERION key/value pairs.
# keylist is a series of key names. Associated with each key name
# is a syntax requirement on its value. Each key passed in keylist
# is used to access that key/value pair in the href hash. The values
# are checked against their corresponding requirements.
#
# A non-zero return is an explanatory error string. A zero return
# implies that all key names in keylist had proper values.
######################################################################
sub XB_check_criterion_values ($@)
{
my ($href, $key, $value, $ix);
$href = shift (@_);
for ($ix = 0; $ix < scalar (@_); $ix++)
{
$key = $_[$ix];
if (!exists ($href->{$key}))
{ next; };
if (!defined ($href->{$key}))
{ return ("Illegal undefined value for key: $key"); }
$value = $href->{$key};
if ( ($key eq 'dynamic_routing') ||
($key eq 'two_phase' )
)
{
if ($value !~ /^yes|no$/i)
{ return ("A $key value is either: yes or no"); }
next;
};
if ($key eq 'topology')
{
if ($value !~ /^ring|line|star$/i)
{ return ("A $key value is either: ring, line or star"); }
next;
};
if ( ($key eq 'release') ||
($key eq 'protocol')
)
{
if ($value !~ /^[0-9]+\.[A-Za-z0-9-]+$/)
{ return ("A $key number has the form \"number.alphanumeric\""); }
next;
};
if ( ($key eq 'timeout') ||
($key eq 'node_count') ||
($key eq 'max_tunnels') ||
($key eq 'tunnel_count') ||
($key eq 'max_overlays') ||
($key eq 'max_interfaces') ||
($key eq 'overlays') ||
($key eq 'interfaces') ||
($key eq 'search_radius')
)
{
if ($value !~ /^[0-9]+$/)
{ return ("An $key value is a non-negative integer"); }
next;
};
if ($key eq 'status')
{
if ($value !~ /^in|out|up|down$/)
{ return ("A $key value is either: in or out"); }
next;
};
if ($key eq 'auth_type')
{
if ($value !~ /^x509$/i)
{ return ("Only x509 $key is supported"); }
next;
};
if ($key eq 'authentication')
{
my (@fields, $field);
$_ = $value;
@fields = split;
foreach $field (@fields)
{
if ($field !~ /md5|sha1|none/i)
{
return
("An $key value is either: md5, sha1 or none");
}
}
next;
};
if ($key eq 'encryption')
{
my (@fields, $field);
$_ = $value;
@fields = split;
foreach $field (@fields)
{
if ($field !~ /des|3des|none/i)
{
return ("An $key value is either: des, 3des or none");
}
}
next;
};
if ($key eq 'class')
{
if ($value !~ /^host|router$/i)
{ return ("A $key value is either: host or router"); }
next;
};
if ($key eq 'creator_name')
{
if ($value !~ /^[A-Z. \'\-]+$/i)
{ return ("The string $value is not a proper $key"); }
next;
};
if ( ($key eq 'creator_email') ||
($key eq 'user_id') )
{
if ($value !~ /^[A-Z0-9_\.]+@[A-Z0-9-_\.]+$/i)
{ return ("The string $value is not a proper $key"); }
next;
};
if ( ($key eq 'os') ||
($key eq 'host_os') ||
($key eq 'router_os') )
{
my ($os, $found, $matchos);
my (@values);
@values = split /\|/, $value; # String is "os0|os1|...|osn"
$found = 0;
foreach $os (@XB_Params::ALLOWED_NODEOS)
{
foreach $matchos (@values)
{
if ($matchos =~ /^$os$/) { $found = 1; last; };
}
}
if (!$found)
{ return
("The OS $value is not a supported operating system");
}
next;
};
if ( ($key eq 'ip_address') ||
($key eq 'local_ip_addr') ||
($key eq 'remote_ip_addr') )
{
if ($value =~ /\./)
{
if (!XB_check_IPv4_syntax ($value))
{ return ("Incorrect IPv4 address string: $value "); };
}
else
{
if (!XB_check_IPv6_syntax ($value))
{ return ("Incorrect IPv6 address string: $value "); };
};
next;
};
if ($key eq 'overlay_name')
{
if ($value =~ /\s+/)
{ return ("Embedded whitespace not allowed in $key"); }
next;
};
if ($key eq 'application')
{
next;
};
if ($key eq 'error')
{
next;
};
if ($key eq 'command')
{
next;
};
};
return (0);
}
######################################################################
#
# sub XB_check_IPv4_syntax ( addr )
#
# Performs basic check on addr passed as an IPv4 numeric address.
# Returns either true or false.
######################################################################
sub XB_check_IPv4_syntax ($)
{
my ($addr) = @_;
if ($addr =~ /^[0-9]{1,3}\.[0-9]{1,3}\.[0-9]{1,3}\.[0-9]{1,3}$/ )
{
return (1);
};
return (0);
}
######################################################################
#
# sub XB_check_IPv6_syntax ( addr )
#
# Performs basic check on addr passed as an IPv6 numeric address.
# Returns true if the syntax is OK. Otherwise, it returns false.
######################################################################
sub XB_check_IPv6_syntax ($)
{
my ($addr) = @_; my (@fields, $ix);
############################
# Break apart on colon chars
# and eliminate empty fields
############################
@fields = split /:/, $addr;
$ix = 0;
while (defined ($fields[$ix]))
{
if (!$fields[$ix])
{ splice @fields, $ix; }
$ix++;
};
#################################
# Should now only have hex fields
#################################
$ix = scalar (@fields);
if (($ix < 1) || ($ix > 8)) # Limit number of fields
{ return (0); };
$ix = 0;
while (defined ($fields[$ix]))
{
if ($fields[$ix] !~ /^[A-F0-9]{1,4}$/i)
{ return (0); }
$ix++;
};
return (1);
}
######################################################################
#
# sub XB_build_api_errmsg ( command, error_message, auth_type, user_id )
#
# Builds a message with the indicated command and one criterion pair
# error/error_message. The auth_type and user_id fields are optional.
# If they are not supplied, they will not be included in the message.
#
# A reference to the message string is returned.
######################################################################
sub XB_build_api_errmsg ($$;$$)
{
my ($command, $error_message, $auth_type, $user_id) = @_;
my ($string, $cs_ref, @args);
$string = "( xbone $XB_Params::XBONE_PROTOCOL $XB_Params::XBONE_RELEASE\n";
$string .= "\t($command ";
@args = ();
push @args, 'error', $error_message;
if (defined ($auth_type)) { push @args, 'auth_type', $auth_type; };
if (defined ($user_id)) { push @args, 'user_id', $user_id; };
print "ARGS: @args\n";
$cs_ref = XB_XOL::XB_build_criterions ( @args );
if (!defined ($cs_ref))
{
#LOG FATAL ERROR MESSAGE
};
$string .= $$cs_ref;
$string .= ")\n"; # End ( list_overlays
$string .= ")\n"; # End ( xbone
$string .= "XboneEOC\n"; # End record
return (\$string);
}
1; # Insure TRUE return if module is interpreted.
syntax highlighted by Code2HTML, v. 0.9.1