File Coverage

blib/lib/Solaris/DeviceTree/Libdevinfo.pm

Criterion	Covered	Total	%
statement	16	18	88.8
branch			n/a
condition			n/a
subroutine	6	6	100.0
pod			n/a
total	22	24	91.6

#
# $Header: /cvsroot/devicetool/Solaris-DeviceTree/lib/Solaris/DeviceTree/Libdevinfo.pm,v 1.9 2003/12/12 11:11:55 honkbude Exp $
#

package Solaris::DeviceTree::Libdevinfo;

use 5.006;
use strict;
use warnings;
use Carp;
use English;

our @ISA = qw( Solaris::DeviceTree::Node );
our $VERSION = do { my @r = (q$Revision: 1.9 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r }; # must be all one line, for MakeMaker

use Solaris::DeviceTree::Libdevinfo::Impl;
use Solaris::DeviceTree::Libdevinfo::MinorNode;
use Solaris::DeviceTree::Libdevinfo::Property;
use Solaris::DeviceTree::Libdevinfo::PromProperty;

# Package global containing a reference to the Libdevinfo tree (singleton)
our $_ROOT_NODE;

# Package global containing a reference to the system PROM handle (singleton)
our $_PROM_HANDLE;

=pod

=head1 NAME

Solaris::DeviceTree::Libdevinfo - Perl interface to the Solaris devinfo library

=head1 SYNOPSIS

Construction and destruction:

  use Solaris::DeviceTree::Libdevinfo;
  $tree = Solaris::DeviceTree::Libdevinfo->new;

Data access methods:

  $path = $node->devfs_path;
  $nodename = $node->node_name;
  $bindingname = $node->binding_name;
  $busaddr = $node->bus_addr;
  @cnames = $devtree->compatible_names;
  $drivername = $devtree->driver_name;
  %ops = $devtree->driver_ops;
  $inst = $node->instance;
  %state = $node->state;
  $id = $node->nodeid;
  if( $node->is_pseudo_node ) { ... }
  if( $node->is_sid_node ) { ... }
  if( $node->is_prom_node ) { ... }
  $props = $node->props;
  $promprops = $node->prom_props;
  @minor = $node->minor_nodes;

=head1 DESCRIPTION

This module implements the L interface
and allows access to the Solaris devinfo library L.
The devicetree is represented as a hierarchical collection of nodes
in the kernel.

The implementation closely resembles the API of the C library. However,
due to the object interface and the beauty of Perl there a few differences to keep in mind
when using this library after reading the manual pages of the original
L:

=over 4

=item *

The 'di_'-prefix of the function names from the C API has been stripped.

=item *

The functions C and C for generation and destruction of
devicetrees are now called implicitly during contruction and destruction repectively.

=item *

Accessing the nodes by driver via C and C
is not implemented in favor of the much more expressive C
added in Perl.

=item *

The function C is not implemented because treewalking
in Perl using C is much easier than in C and is therefore
not needed.

=item *

Getting child nodes via subsequent calls to C has been
simplified to a single call to C returning an array of
all child nodes.

=item *

Access to C is currently not implemented as the returned
value is meaningless without access to L, which I have not done (yet).
Requests welcome.

=back

     di_binding_name               di_bus_addr
     di_child_node                 di_compatible_names
     di_devfs_path                 di_devfs_path_free
     di_devid                      di_driver_name
     di_driver_ops                 di_drv_first_node
     di_drv_next_node              di_fini
     di_init                       di_instance
     di_minor_class                di_minor_devt
     di_minor_name                 di_minor_next
     di_minor_nodetype             di_minor_spectype
     di_minor_type                 di_node_name
     di_nodeid                     di_parent_node
     di_prom_fini                  di_prom_init
     di_prom_prop_data             di_prom_prop_lookup_bytes
     di_prom_prop_lookup_ints      di_prom_prop_lookup_strings
     di_prom_prop_name             di_prom_prop_next
     di_prop_bytes                 di_prop_devt
     di_prop_ints                  di_prop_lookup_bytes
     di_prop_lookup_ints           di_prop_lookup_strings
     di_prop_name                  di_prop_next
     di_prop_strings               di_prop_type
     di_sibling_node               di_state
     di_walk_minor                 di_walk_node

=head1 METHODS

For tree traversal methods see the base class L.

The following methods are available:

=head2 new

The constructor returns a reference to the root node object, which is a
L object.
The methods are all read-only.

=cut

sub new {
  my ($pkg, %params) = @_;

  # We always want to access all information from the complete tree.
  # If only a subset of information is needed we handle it on the
  # perl end. This might be a performance issue when lots of trees
  # are generated, but as the methods are all read-only a singleton
  # tree should be sufficient.

  if( !defined $_ROOT_NODE ) {
    $_ROOT_NODE = bless {
      _data => di_init( "/", $DINFOCPYALL ),
      _parent => undef,
    }, $pkg;
  }
  return $_ROOT_NODE;
}

# Special constructor for internal nodes
sub _new_internal {
  my ($pkg, %params) = @_;

  # The parameter 'data' has the SWIG-type di_node_t and points to
  # the C data structure needed to access the node from the C library.
  # The parameter 'parent' points to the parent Perl object of this
  # node in the device tree. This is done in favor of using di_parent_node
  # from the library for two reasons: first it's a lot easier, second
  # it is good to have at most one object per node from the devicetree.
  # Checking the identity of a node can than be done by comparing the
  # references.
  # Both parameters should only be used when nodes inside the tree
  # are created from within methods of this class.

  die "No data specified." if( !defined $params{data} );
  die "No parent specified." if( !defined $params{parent} );

  my $this = bless {
    _data => $params{data},
    _parent => $params{parent},
  }, $pkg;

  return $this;
}

# This helper function generates a persistent prom handle on demand
# and returns it.
sub _prom_handle {
  if( !defined $_PROM_HANDLE ) {
    $_PROM_HANDLE = di_prom_init();
    if( isDI_PROM_HANDLE_NIL( $_PROM_HANDLE ) ) {
       # Maybe an exception should be thrown here.
#      warn "Cannot access PROM device: $ERRNO";
      $_PROM_HANDLE = undef;
    }
  }
  return $_PROM_HANDLE;
}

#=pod
#
#=head3 $tree->DESTROY;
#
#This is the destructor method. It should not be necessary to
#call this method directly.
#
#This is the equivalent of calling C from the C API.
#
#=cut

sub DESTROY {
  my $this = shift;

  # We need weak references for singletons. Fix this some time...
  if( !defined $this->{_parent} ) {
    di_prom_fini( $this->{_prom_handle} ) if( defined $this->{_prom_handle} );
    $this->{_prom_handle} = undef;
    di_fini( $this->{_data} ) if( defined $this->{_data} );
    $this->{_data} = undef;
  }
}

# tree traversal documented in Solaris::DeviceTree::Node
sub child_nodes {
  my ($this, %options) = @_;

  # The children of each node are cached
  if( !exists $this->{_children} ) {
    # Cache is empty, fill it.
    my @result = ();
    my $child = di_child_node( $this->{_data} );

    # Iterate over all children and generate objects accordlingly
    while( !isDI_NODE_NIL( $child ) ) {
      push @result, Solaris::DeviceTree::Libdevinfo->_new_internal(
        data => $child, parent => $this );
      $child = di_sibling_node( $child );
    }

    # Store result in cache
    $this->{_children} = \@result;
  }

  # Always return contents of cache
  return @{$this->{_children}};
}

# tree traversal documented in Solaris::DeviceTree::Node
sub parent_node {
  my $this = shift;

  # We directly return the parent node. Especially we don't use
  # di_parent_node from the C library. See the description of
  # the constructor for the reason.
  return $this->{_parent};
}

# tree traversal documented in Solaris::DeviceTree::Node
sub root_node {
  my $this = shift;

  # Since we have a singleton the same reference to the object is
  # always returned.
  return $_ROOT_NODE;
}

# tree traversal documented in Solaris::DeviceTree::Node
sub sibling_nodes {
  my $this = shift;

  my $parent = $this->parent_node;

  # Read all siblings including $this
  my @siblings = defined $parent ? $parent->child_nodes : ();

  # Strip out current node
  my @sib = grep { $_ ne $this } @siblings;

  return @sib;
}

=pod

=head2 devfs_path

Returns the physical path assocatiated with this node.

=cut

sub devfs_path {
  my $this = shift;
  return di_devfs_path( $this->{_data} );
}

=pod

=head2 node_name

Returns the name of the node.

=cut

sub node_name {
  my $this = shift;
  return di_node_name( $this->{_data} );
}

=pod

=head2 binding_name

Returns the binding name for this node. The binding name
is the name used by the system to select a driver for the device.

=cut

sub binding_name {
  my $this = shift;
  return di_binding_name( $this->{_data} );
}

=pod

=head2 bus_addr

Returns the address on the bus for this node. C is returned
if a bus address has not been assigned to the device. A zero-length
string may be returned and is considered a valid bus address.

=cut

sub bus_addr {
  my $this = shift;
  my $busaddr = di_bus_addr( $this->{_data} );
  return $busaddr;
}

=pod

=head2 compatible_names

Returns the list of names from compatible device for the current node.
See the discussion of generic names in L for
a description of how compatible names are used by Solaris to achieve
driver binding for the node.

=cut

sub compatible_names {
  my $this = shift;
  my $node = $this->{_data};

  my $namehandle = newStringHandle();
  my $lastIndex = di_compatible_names( $node, $namehandle ) - 1;
  my @compatibleNames =
    map { getIndexedString( $namehandle, $_ ) } 0..$lastIndex;
  freeStringHandle( $namehandle );

  @compatibleNames;
}

#sub devid {
#  my $this = shift;
#  my $devid = di_devid( $this->{_data} );
#  return (isDevidNull( $devid ) == 0 ? $devid : 0);
#}

=pod

=head2 driver_name

Returns the name of the driver for the node or C if the node
is not bound to any driver.

=cut

sub driver_name {
  my $this = shift;
  return di_driver_name( $this->{_data} );
}

=pod

=head2 driver_ops

Returns a hash whos keys indicate, which entry points of the
device driver entry points are supported by the driver bound
to this node. Possible keys are:

  BUS
  CB
  STREAM

=cut

sub driver_ops {
  my $this = shift;

  my $ops = di_driver_ops( $this->{_data} );
  my %ops;

  $ops{BUS}    = 1 if( $ops & $DI_BUS_OPS );
  $ops{CB}     = 1 if( $ops & $DI_CB_OPS );
  $ops{STREAM} = 1 if( $ops & $DI_STREAM_OPS );
  return %ops;
}

=pod

=head2 instance

Returns the instance number for this node of the bound driver.
C is returned if no instance number has been assigned.

=cut

sub instance {
  my $this = shift;
  my $instance = di_instance( $this->{_data} );
  # if instance number is -1 then no instance was bound
  $instance = undef if( $instance == -1 );
  return $instance;
}

=pod

=head2 state

Returns the driver state attached to this node as hash.
The presence of the keys in the hash represent the states
of the driver. The following keys in the hash can be present:

  DRIVER_DETACHED
  DEVICE_OFFLINE
  DEVICE_DOWN
  BUS_QUIESCED
  BUS_DOWN

=cut

sub state {
  my $this = shift;

  my $state = di_state( $this->{_data} );
  my %state;

  $state{DRIVER_DETACHED} = 1 if( $state & $DI_DRIVER_DETACHED );
  $state{DEVICE_OFFLINE}  = 1 if( $state & $DI_DEVICE_OFFLINE );
  $state{DEVICE_DOWN}     = 1 if( $state & $DI_DEVICE_DOWN );
  $state{BUS_QUISCED}     = 1 if( $state & $DI_BUS_QUIESCED );
  $state{BUS_DOWN}        = 1 if( $state & $DI_BUS_DOWN );

  return %state;
}

=pod

=head2 nodeid

Returns the type of the node. Three different strings identifying
the types can be returned or C if the type is unknown:

  PSEUDO
  SID
  PROM

Nodes of the type C may have additional PROM properties that
are defined by the PROM. The properties can be accessed with L.

=cut

sub nodeid {
  my $this = shift;
  my %_nodeid = (
    $DI_PSEUDO_NODEID => 'PSEUDO',
    $DI_SID_NODEID => 'SID',
    $DI_PROM_NODEID => 'PROM',
  );

  my $nodeid = di_nodeid( $this->{_data} );
  my $result = ( exists $_nodeid{ $nodeid } ? $_nodeid{ $nodeid } : undef );
  return $result;
}

=pod

=head2 is_pseudo_node
=head2 is_sid_node
=head2 is_prom_node

Returns C if the node is of type pseudo / SID / PROM or C if not.

=cut

sub is_pseudo_node {
  my $this = shift;
  return di_nodeid( $this->{_data} ) == $DI_PSEUDO_NODEID ? 'PSEUDO' : undef;
}

sub is_sid_node {
  my $this = shift;
  return di_nodeid( $this->{_data} ) == $DI_SID_NODEID ? 'SID' : undef;
}


sub is_prom_node {
  my $this = shift;

  return di_nodeid( $this->{_data} ) == $DI_PROM_NODEID ? 'PROM' : undef;
}

=pod

=head2 props

Returns a reference to a hash which maps property names to property values.
The property values are of class L.

=cut

sub props {
  my $this = shift;
  my $node = $this->{_data};

  if( !exists $this->{_props} ) {
    my %props;
    my $prop = di_prop_next( $node, makeDI_PROP_NIL() );
    while( !isDI_PROP_NIL( $prop ) ) {
      my $propObj = new Solaris::DeviceTree::Libdevinfo::Property( $prop );
      $props{ $propObj->name } = $propObj;
      $prop = di_prop_next( $node, $prop );
    }
    $this->{_props} = \%props;
  }
  return $this->{_props};
}

=pod

=head2 prom_props

Returns a reference to a hash which maps PROM property names to property values.
The property values are of class L.
If the PROM device can not be opened (most likely because the process does
not have the permission to access C) then C is returned.

=cut

sub prom_props {
  my $this = shift;
  my $node = $this->{_data};

  if( !exists $this->{_prom_props} ) {
    my %props;
    my $ph = $this->_prom_handle;
    if( defined $ph ) {
      my $handle = newUCharTHandle();
      my $prop = di_prom_prop_next( $ph, $node, makeDI_PROM_PROP_NIL() );
      while( !isDI_PROM_PROP_NIL( $prop ) ) {
        my $name = di_prom_prop_name( $prop );
        my $count = di_prom_prop_data( $prop, $handle );
        my $data = pack "C" x $count, map { getIndexedByte( $handle, $_ ) } 0 .. $count-1;
        $props{ $name } = Solaris::DeviceTree::Libdevinfo::PromProperty->new( $data );

        $prop = di_prom_prop_next( $ph, $node, $prop );
      }
      freeUCharTHandle( $handle );
      $this->{_prom_props} = \%props;
    } else {
      $this->{_prom_props} = undef;
    }
  }

  return $this->{_prom_props};
}

=pod

=head2 minor_nodes

Returns a reference to a list of all minor nodes which are associated with this node.
The minor nodes are of class L.

=cut

sub minor_nodes {
  my $this = shift;
  my $node = $this->{_data};

  if( !exists $this->{_minorNodes} ) {
    my @minorNodes;
    my $minor = di_minor_next( $node, makeDI_MINOR_NIL() );
    while( !isDI_MINOR_NIL( $minor ) ) {
      push @minorNodes, new Solaris::DeviceTree::Libdevinfo::MinorNode( $minor, $this );
      $minor = di_minor_next( $node, $minor );
    }
    $this->{_minorNodes} = \@minorNodes;
  }
  return $this->{_minorNodes};
}

=pod

=head1 AUTHOR

Copyright 1999-2003 Dagobert Michelsen.

=head1 SEE ALSO

L, L,
L,
L,
L.

=cut

1;