File Coverage

blib/lib/Win32/IPConfig.pm

Criterion	Covered	Total	%
statement	13	15	86.6
branch			n/a
condition			n/a
subroutine	5	5	100.0
pod			n/a
total	18	20	90.0

package Win32::IPConfig;

use 5.006;
use strict;
use warnings;

our $VERSION = '0.10';

use Carp;
use Win32::TieRegistry qw/:KEY_/;
use Win32::IPConfig::Adapter;

sub new
{
    my $class = shift;
    my $host = shift || "";
    my $access = shift || "ro";

    my $hklm = $Registry->Connect($host, "HKEY_LOCAL_MACHINE",
            { Access => $access eq 'rw' ? KEY_READ|KEY_WRITE : KEY_READ })
        or return undef;

    $hklm->SplitMultis(1); # return REG_MULTI_SZ as arrays

    my $osversion = $hklm->{"SOFTWARE\\Microsoft\\Windows NT\\CurrentVersion\\\\CurrentVersion"} or return undef;

    my $self = {};
    $self->{"osversion"} = $osversion;
    $self->{"access"} = $access;

    # Remember the necessary registry keys
    my $services_key = $hklm->{"SYSTEM\\CurrentControlSet\\Services\\"}
        or return undef;
    $self->{"netbt_params_key"} = $services_key->{"Netbt\\Parameters\\"}
        or return undef;
    $self->{"tcpip_params_key"} = $services_key->{"Tcpip\\Parameters\\"}
        or return undef;

    # Retrieve each network card's config
    my $networkcards_key = $hklm->{"SOFTWARE\\Microsoft\\Windows NT\\CurrentVersion\\NetworkCards\\"} or return undef;
    for my $nic ($networkcards_key->SubKeyNames) {
        if (my $adapter = Win32::IPConfig::Adapter->new($hklm, $nic, $access)) {
            push @{$self->{"adapters"}}, $adapter;
        }
    }

    bless $self, $class;
    return $self;
}

sub get_adapters
{
    return wantarray ? @{$_[0]->{"adapters"}} : $_[0]->{"adapters"};
}

sub get_configured_adapters
{
    my @adapters = ();
    for my $adapter (@{$_[0]->{"adapters"}}) {
        if (my @ipaddresses = $adapter->get_ipaddresses) {
            push @adapters, $adapter unless $ipaddresses[0] eq "0.0.0.0";
        }
    }
    return wantarray ? @adapters : \@adapters;
}

sub get_osversion { return $_[0]->{"osversion"}; }

# Value: Hostname (REG_SZ)
# NT:    Tcpip\Parameters
# 2000+: Tcpip\Parameters

# Value: NV Hostname (REG_SZ)
# 2000+: Tcpip\Parameters

sub get_hostname
{
    my $self = shift;

    return $self->{"tcpip_params_key"}{"\\Hostname"};
}

# Value: Domain (REG_SZ)
# NT:    Tcpip\Parameters
# 2000+: Tcpip\Parameters (primary)
# 2000+: Tcpip\Parameters\Interfaces\ (connection-specific)

# Value: NV Domain (REG_SZ)
# 2000+: Tcpip\Parameters

# Value: DhcpDomain (REG_SZ)
# NT:    Tcpip\Parameters
# 2000+: Tcpip\Parameters
# 2000+: Tcpip\Parameters\Interfaces\ (connection-specific)

# How do you know when to read the Domain value and when to read the DhcpDomain
# value? The Domain and DhcpDomain values are attributes of a host, but
# the EnableDHCP value is an attribute of an adapter.

# On Windows NT 4.0, when I set the adapter to static, the DhcpDomain
# setting disappears from the registry to leave only the empty Domain setting.
# This also appears to be the case on Windows XP.

# What happens when Domain setting is set statically and an adapter card adds a
# DhcpDomain setting as well - i.e. when both Domain and DhcpDomain exist?

# On Windows NT 4.0, when I set the adapter to dynamic and set a static domain
# setting, the static domain setting is returned by ipconfig /all while both
# settings exist in the registry.

# This suggests: return the Domain setting if it is non-empty. Otherwise
# return the DhcpDomain if it is present. Otherwise, return an empty string.

sub get_domain
{
    my $self = shift;

    my $domain = $self->{"tcpip_params_key"}{"\\Domain"};
    if (! $domain) {
        $domain = $self->{"tcpip_params_key"}{"\\DhcpDomain"} || "";
    }
    return $domain;
}

# Value: SearchList (REG_SZ) (space delimited on NT, comma delimited on 2000+)
# NT:    Tcpip\Parameters
# 2000+: Tcpip\Parameters

# The Windows 2000 Advanced TCP/IP Settings dialog gives you the choice of
# resolving unqualified names by:
# 1. appending primary and connection specific DNS suffixes
# 2. appending a user-specified list of DNS suffixes
# It appears to choose between each method simply by seeing if
# SearchList is set or not: if it is set, use it, otherwise append
# the primary and connection specific DNS suffixes.

# The Windows NT Microsoft TCP/IP Properties dialog simply allows you
# the option of specifying a domain suffix search order.

sub get_searchlist
{
    my $self = shift;

    my @searchlist;
    if ($self->{"osversion"} >= 5.0) {
        @searchlist = split /,/, $self->{"tcpip_params_key"}{"\\SearchList"};
    } else {
        @searchlist = split / /, $self->{"tcpip_params_key"}{"\\SearchList"};
    }
    return wantarray ? @searchlist : \@searchlist;
}

# Value: NodeType (REG_DWORD)
# NT:    Netbt\Parameters
# 2000+: Netbt\Parameters

# Value: DhcpNodeType (REG_DWORD) (overidden by NodeType)
# NT:    Netbt\Parameters
# 2000+: Netbt\Parameters

# On Windows NT 4.0, if the adapter receives a DhcpNodeType setting from the
# DHCP server, the DhcpNodeType setting is present. Otherwise neither the
# NodeType nor the DhcpNodeType setting is present. When neither setting is
# present, Windows NT 4.0 reports "Node Type = Broadcast".

# According to the Q120642 and Q314053 the NodeType setting will override the
# DhcpNodeType setting.

# This suggests: use the NodeType value if set. Otherwise check for a
# DhcpNodeType setting. If there is no DhcpNodeType make a stab at getting the
# default NodeType. Check all the adapters present for WINS settings. If there
# are any set, then return H-node, else return B-node.

sub get_nodetype
{
    my $self = shift;

    my %nodetypes = (1=>"B-node", 2=>"P-node", 4=>"M-node", 8=>"H-node");

    # Windows NT 4.0's ipconfig reports these node types as
    # Broadcast, Peer-Peer, Mixed, Hybrid

    my $nodetype;
    if (my $type = $self->{"netbt_params_key"}{"\\NodeType"}) {
        $nodetype = hex($type);
    } elsif ($type = $self->{"netbt_params_key"}{"\\DhcpNodeType"}) {
        $nodetype = hex($type)
    } else {
        my $wins_count = 0;
        for my $adapter ($self->get_adapters) {
            my @wins = $adapter->get_wins;
            $wins_count += @wins;
        }
        $nodetype = $wins_count ? 8 : 1;
    }
    return $nodetypes{$nodetype};
}

# Value: IPEnableRouter (REG_DWORD)
# NT:    Tcpip\Parameters
# 2000+: Tcpip\Parameters

sub is_router
{
    my $self = shift;

    if (my $router = $self->{"tcpip_params_key"}{"\\IPEnableRouter"}) {
        return hex($router);
    } else {
        return 0; # defaults to 0
    }
}

# Value: EnableProxy (REG_DWORD)
# NT:    Netbt\Parameters
# 2000+: Netbt\Parameters

sub is_wins_proxy
{
    my $self = shift;

    if (my $proxy = $self->{"netbt_params_key"}{"\\EnableProxy"}) {
        return hex($proxy);
    } else {
        return 0; # defaults to 0
    }
}

# Value: EnableLMHOSTS (REG_DWORD)
# NT:    Netbt\Parameters
# 2000+: Netbt\Parameters

sub is_lmhosts_enabled
{
    my $self = shift;

    if (my $lmhosts_enabled = $self->{"netbt_params_key"}{"\\EnableLMHOSTS"}) {
        return hex($lmhosts_enabled);
    } else {
        return 1; # defaults to 1
    }
}

# Value: EnableDns (REG_DWORD)
# NT:    Netbt\Parameters
# 2000+: Netbt\Parameters

sub is_dns_enabled_for_netbt
{
    my $self = shift;

    if (my $dns_enabled_for_netbt = $self->{"netbt_params_key"}{"\\EnableDns"}) {
        return hex($dns_enabled_for_netbt);
    } else {
        return 0; # defaults to 0
    }
}

sub get_adapter
{
    my $self = shift;
    my $adapter_name_or_num = shift;

    if ($adapter_name_or_num =~ m/^\d+$/) {
        my $adapter = $self->{"adapters"}[$adapter_name_or_num];
        return $adapter;
    } else {
        for my $adapter ($self->get_adapters) {
            if (uc $adapter->get_name eq uc $adapter_name_or_num) {
                return $adapter;
            }
        }
        return undef; # couldn't find a matching adapter.
    }
}

sub dump
{
    my $self = shift;

    print "hostname=", $self->get_hostname, "\n";
    print "domain=", $self->get_domain, "\n";
    my @searchlist = $self->get_searchlist;
    print "searchlist=@searchlist (", scalar @searchlist, ")\n";
    print "nodetype=", $self->get_nodetype, "\n";
    print "ip router enabled=", $self->is_router ? "Yes":"No", "\n";
    print "wins proxy enabled=", $self->is_wins_proxy ? "Yes":"No", "\n";
    print "LMHOSTS enabled=", $self->is_lmhosts_enabled ? "Yes":"No", "\n";
    print "dns enabled for netbt=", $self->is_dns_enabled_for_netbt ? "Yes":"No", "\n";
    my $i = 0;
    for ($self->get_adapters) {
        print "\nAdapter ", $i++, ":\n";
        $_->dump;
    }
}

1;

__END__