Net-Interface
view release on metacpan or search on metacpan
Interface.pm view on Meta::CPAN
package Net::Interface;
use strict;
#use lib qw(blib/lib blib/arch);
use vars qw(
$VERSION
@ISA
%EXPORT_TAGS
@EXPORT_OK
);
#use AutoLoader qw(AUTOLOAD);
require Exporter;
require DynaLoader;
@ISA = qw(Exporter DynaLoader);
require Net::Interface::NetSymbols; # just for the EXPORT symbol arrays
@EXPORT_OK = (
@Net::Interface::NetSymbols::EXPORT_OK,
qw(
cidr2mask
full_inet_ntop
ipV6compress
mac_bin2hex
mask2cidr
net_symbols
type
scope
inet_aton
inet_ntoa
inet_pton
inet_ntop
_NI_AF_TEST
)
);
%EXPORT_TAGS = %Net::Interface::NetSymbols::EXPORT_TAGS;
$EXPORT_TAGS{constants} = $EXPORT_TAGS{ifs}; # deprecated form
$EXPORT_TAGS{inet} = [qw(
inet_aton
inet_ntoa
inet_pton
inet_ntop
)];
$VERSION = do { sprintf "%d.%03d", (q$Revision: 1.16 $ =~ /\d+/g) };
bootstrap Net::Interface $VERSION;
# register the conditionally compiled family modules
Net::Interface::conreg();
# provide AF family data for use in this module
my $AF_inet = eval { 0 + AF_INET() } || 0;
my $AF_inet6 = eval { 0 + AF_INET6() } || 0;
sub af_inet { return $AF_inet; }
sub af_inet6 { return $AF_inet6; }
sub net_symbols() {
no strict;
my %sym;
my $max = AF_MAX();
foreach (
@{$EXPORT_TAGS{afs}},
@{$EXPORT_TAGS{pfs}},
@{$EXPORT_TAGS{ifs}},
@{$EXPORT_TAGS{iftype}},
@{$EXPORT_TAGS{scope}},
) {
my $v = &$_;
next if $v > $max;
$sym{$_} = &$_;
}
return \%sym;
}
########## begin code ############
*broadcast = \&destination;
use overload
'""' => sub { $_[0]->name(); };
our $full_format = "%02X%02X:%02X%02X:%02X%02X:%02X%02X:%02X%02X:%02X%02X:%02X%02X:%02X%02X";
our $ipv6_format = 1;
our $mac_format = "%02X:%02X:%02X:%02X:%02X:%02X";
sub import {
if (grep { $_ eq ':lower' } @_) {
$full_format = lc($full_format);
$ipv6_format = 0;
$mac_format = lc($mac_format);
@_ = grep { $_ ne ':lower' } @_;
}
if (grep { $_ eq ':upper' } @_) {
$full_format = uc($full_format);
$ipv6_format = 1;
$mac_format = uc($mac_format);
@_ = grep { $_ ne ':upper' } @_;
}
Net::Interface->export_to_level(1,@_);
}
sub DESTROY () {}
#1;
#__END__
# create blessed object for testing
#
sub _bo($) {
my $proto = shift;
my $class = ref($proto) || $proto;
bless {}, $class;
}
Interface.pm view on Meta::CPAN
B<ARRAY context>
Returns a list of addresses assigned to this interface.
If a C<$family> is not specified then AF_INET is assumed or AF_INET6 if
there are no AF_INET addresses present.
=item * I<-E<gt>netmask([$family],[$index]);>
Similar to I<-E<gt>address([$family],[$index]);> above. Netmasks are reported in the
same order as the addresses above, in matching positions in the returned
array.
=item * I<-E<gt>destination([$family],[$index]);>
=item * I<-E<gt>broadcast([$family],[$index]);>
These to methods are identical in execution. The returned address
attribute(s) will be destination or broadcast addresses depending on the
status of the POINTOPOINT flag.
Similar to I<-E<gt>address([$family],[$index]);> above. If an address attribute is
unknown, the array slot will contain I<undef>.
=cut
sub address ($;$$) {
unshift @_, 'addr';
# can't use 'goto', work around for broken perl 5.80-5.85 @_ bug
return &_address
if wantarray;
return scalar &_address;
}
sub netmask ($;$$) {
unshift @_, 'netm';
# can't use 'goto', work around for broken perl 5.80-5.85 @_ bug
return &_address
if wantarray;
return scalar &_address;
}
sub destination ($;$$) {
unshift @_, 'dsta';
# can't use 'goto', work around for broken perl 5.80-5.85 @_ bug
return &_address
if wantarray;
return scalar &_address;
}
sub _address {
my($k,$if,$f,$i) = @_;
my $idx = $i || 0;
$f = 0 unless $f;
my $fam = 0 + $f;
unless ($f) { # if the family is missing
if (exists $if->{args}->{&af_inet}) {
$fam = &af_inet; # select default, AF_INET
}
else {
$fam = &af_inet6; # or AF_INET6 if present
}
}
if (! exists $if->{args}->{$fam} || # there is no such family
$idx < 0 || $idx > $#{$if->{args}->{$fam}->{addr}}) { # or the index is out of range
return () if wantarray; # PUNT!
return undef;
}
return @{$if->{args}->{$fam}->{$k}}
if wantarray;
return $if->{args}->{$fam}->{$k}->[$idx];
}
=item * I<-E<gt>hwaddress([$hwaddr]);>
Returns the binary value of the MAC address for the interface. Optionally, where
supported, it allows setting of the MAC address.
i.e. $old_binmac = $if->hwaddress($new_binmac);
$new_binmac = $if->hwaddress();
=item * I<-E<gt>flags([$new_flags]);>
Get or Set (where supported) the flags on the interface.
i.e. down an interface.
$flags = $if->flags();
$mask = ~IFF_UP;
$old_fg = $if->flags($flags & $mask);
$flags = $if->flags();
UPDATES the if object
NOTE: returns undef if the interface is down or not configured.
=item * I<-E<gt>mtu([$new_mtu]);>
Get or Set (where supported) the mtu of the interface.
$mtu = $if->mtu();
$old_mtu = $if->mtu($new_mtu);
UPDATES the if object
NOTE: returns undef if the interface is down or not configured.
=item * I<-E<gt>metric([$new_metric]);>
Get or Set (where supported) the metric for the interface.
$metric = $if->metric();
$old_metric = $if->metric($new_metric);
UPDATES the if object
NOTE: returns undef if the interface is down or not configured.
=item * I<-E<gt>index();>
Interface.pm view on Meta::CPAN
$index = $if->index();
=item * I<-E<gt>mask2cidr([$naddrmsk]);>
=item * $cidr = mask2cidr($naddrmsk);
Returns the CIDR (prefix length) for the netmask C<$naddrmsk>.
When no I<$naddrmsk> is specified the method will return the first address
in the first family starting with AF_INET, AF_INET6, etc... This is
particularly useful for interfaces with only a single address assigned.
May be called as a METHOD or a FUNCTION.
=item * I<-E<gt>mac_bin2hex();>
=item * $mac_txt = mac_bin2hex($bin_mac);
Converts a binary MAC address into hex text.
i.e. A1:B2:C3:D4:E5:F6
May be called as a METHOD or a FUNCTION.
=item * I<-E<gt>info();>
Returns a pointer to a hash containing information about the interface as
follows:
$info = {
name => 'eth0',
index => 1,
mtu => 1500,
metric => 1,
flags => 1234,
mac => binary_mac_address,
$fam0 => {
number => of_addresses,
size => of_address,
},
$fam1 => etc....
};
where $famX is one of AF_INET, AF_INET6, etc...
=cut
sub info ($) {
my $if = shift;
my $name = $if->{name};
my ($mtu,$metric,$flags,$mac,$index) = @{$if->{args}}{qw(mtui metk flag maci indx)};
my $info = {
name => $name,
mtu => $mtu,
metric => $metric,
flags => $flags,
mac => $mac,
index => $index,
};
my $af_inet6 = eval { &af_inet6 } || 0;
foreach(&af_inet,$af_inet6) {
next unless $_;
if (exists $if->{args}->{$_}) {
$info->{$_}->{size} = $if->{args}->{$_}->{size};
$info->{$_}->{number} = @{$if->{args}->{$_}->{addr}};
}
}
return $info;
}
=item * I<-E<gt>type([$naddr6]);>
=item * $type = type($naddr6);
B<ipV6> method. Returns attributes of an IPV6 address that may be tested
with these bit masks:
IPV6_ADDR_ANY unknown
IPV6_ADDR_UNICAST unicast
IPV6_ADDR_MULTICAST multicast
IPV6_ADDR_ANYCAST anycast
IPV6_ADDR_LOOPBACK loopback
IPV6_ADDR_LINKLOCAL link-local
IPV6_ADDR_SITELOCAL site-local
IPV6_ADDR_COMPATv4 compat-v4
IPV6_ADDR_SCOPE_MASK scope-mask
IPV6_ADDR_MAPPED mapped
IPV6_ADDR_RESERVED reserved
IPV6_ADDR_ULUA uniq-lcl-unicast
IPV6_ADDR_6TO4 6to4
IPV6_ADDR_6BONE 6bone
IPV6_ADDR_AGU global-unicast
IPV6_ADDR_UNSPECIFIED unspecified
IPV6_ADDR_SOLICITED_NODE solicited-node
IPV6_ADDR_ISATAP ISATAP
IPV6_ADDR_PRODUCTIVE productive
IPV6_ADDR_6TO4_MICROSOFT 6to4-ms
IPV6_ADDR_TEREDO teredo
IPV6_ADDR_ORCHID orchid
IPV6_ADDR_NON_ROUTE_DOC non-routeable-doc
i.e. if ($type & $mask) {
print $mask,"\n";
...
... will print the string shown to the right of the bit mask.
When no I<$naddr6> is specified the method will return the first AF_INET6
address found. This is particularly useful for interfaces with only a single
address assigned.
May be called as a METHOD or a FUNCTION with an $naddr6 argument.
=item * I<-E<gt>scope([$naddr6]);>
=item * $scope = scope($naddr6);
Returns the RFC-2373 scope of an IPV6 address that may be equated to these
constants.
RFC2373_GLOBAL global-scope 0xE
RFC2373_ORGLOCAL org-local 0x8
RFC2373_SITELOCAL site-local 0x5
RFC2373_LINKLOCAL link-local 0x2
RFC2373_NODELOCAL loopback 0x1
One additional constant is provided as there is an out of band
scope value mapped returned when determining scope. If you want B<standard>
RFC2373 scope only, && the return value with 0xF
LINUX_COMPATv4 lx-compat-v4 0x10
i.e. if ($scope = $const) {
print $const,"\n";
...
... will print the string shown to the right of the constant.
When no I<$naddr6> is specified the method will return the first AF_INET6
address found. This is particularly useful for interfaces with only a single
address assigned.
May be called as a METHOD or a FUNCTION with an $naddr6 argument.
=back
=cut
sub _family {
my $len = length($_[0]);
if ($len == 4) {
return &af_inet;
}
elsif ($len == 16) {
return &af_inet6;
}
return 0;
}
=head1 FUNCTIONS
Unless otherwise specified, errors for all methods return either B<undef> or
and empty array depending on the expected return context.
=over 4
=item * $naddr = inet_aton($host or $dotquad);
Converts a hostname or dotquad ipV4 address into a packed network address.
=cut
# if Socket lib is broken in some way, check for overange values
#
my $overange = yinet_aton('256.1') ? 1:0;
sub inet_aton {
if (! $overange || $_[0] =~ /[^0-9\.]/) { # hostname
return &yinet_aton;
}
my @dq = split(/\./,$_[0]);
foreach (@dq) {
return undef if $_ > 255;
}
return &yinet_aton;
}
=item * $dotquad = inet_ntoa($naddr);
Convert a binary IPV4 address into a dotquad text string.
=item * $ipV6_txt = full_inet_ntop($naddr6);
Returns an uncompressed text string for a net6 address.
i.e. FE80:02A0:0000:0000:0000:0000:0123:4567
=item * $minimized = ipV6compress($ipV6_txt);
Compress an ipV6 address to the minimum RFC-1884 format
i.e. FE80:02A0:0000:0000:0000:0000:0123:4567
to FE80:2A0::123:4567
=cut
sub _ipv6_acommon {
my($ipv6) = @_;
return undef unless $ipv6;
local($1,$2,$3,$4,$5);
if ($ipv6 =~ /^(.*:)(\d{1,3})\.(\d{1,3})\.(\d{1,3})\.(\d{1,3})$/) { # mixed hex, dot-quad
return undef if $2 > 255 || $3 > 255 || $4 > 255 || $5 > 255;
$ipv6 = sprintf("%s%X%02X:%X%02X",$1,$2,$3,$4,$5); # convert to pure hex
( run in 0.523 second using v1.01-cache-2.11-cpan-39bf76dae61 )