Solaris::DeviceTree::OBP - Utility functions for OBP access

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

  $aliases = obp_aliases($tree);
  my $disk = $aliases->{'disk'};
  $chosen_boot_device = obp_chosen_boot_device($tree);
  @boot_devices = obp_boot_devices($tree);
  @diag_devices = obp_diag_devices($tree);

  $resolved_path = obp_resolve_path( aliases => $aliases, path => "disk:c" );

  use Solaris::DeviceTree::OBP;
  use Solaris::DeviceTree::Libdevinfo;
  my $tree = Solaris::DeviceTree::Libdevinfo->new;
  $bootpath = $tree->find_prop( devfs_path => "/chosen", prom_prop_name => "bootpath" );
  $resolved_path = obp_resolve_path( aliases => $tree->aliases, path => $bootpath->string );
  print "Last boot from $resolved_path\n";

#
# $Header: /cvsroot/devicetool/Solaris-DeviceTree/lib/Solaris/DeviceTree/OBP.pm,v 1.8 2003/12/10 12:46:06 honkbude Exp $
#

package Solaris::DeviceTree::OBP;

use strict;
use warnings;

require Exporter;
my @boot_functions = qw( obp_chosen_boot_device obp_boot_devices obp_diag_devices );
my @alias_functions = qw( obp_aliases );
my @path_functions = qw( obp_resolve_path );
our %EXPORT_TAGS = (
  'all' => [ @boot_functions, @alias_functions, @path_functions ],
  'boot' => \@boot_functions,
  'aliases' => \@alias_functions,
  'path' => \@path_functions,
);
our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );
our @ISA = qw( Exporter );
our $VERSION = do { my @r = (q$Revision: 1.8 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r }; # must be all one line, for MakeMaker

use Carp;

# SplitComponent - Split OBP path component into parts
sub _split_component {
  my $component = shift;
  my $hex = '[0-9a-f]';
  my ($node_name, $unit_addr1, $unit_addr2, $arg) =
    ( $component =~ /
                    ([^@]+)		# the part before '@' or all if no '@'
                    (?:@(${hex}+)		# address part before ','
                    (?:,(${hex}+)?)?)?	# address part after ','
                    (?::(.*))*		# everything after ':'
                /xo);
  return [ node_name => $node_name,
           unit_addr1 => $unit_addr1,
           unit_addr2 => $unit_addr2,
           arg => $arg ];
}

# Main functions

sub _left_split {
  my ($string, $char) = @_;

  my ($initial, $remainder) = ($string =~ /^([^${char}]*)${char}?(.*)$/);
  return ($initial, $remainder);
}

sub _right_split {
  my ($string, $char) = @_;

  my ($initial, $remainder);
  if( $string =~ /$char/ ) {
    ($initial, $remainder) = ($string =~ /^(.*)${char}([^${char}]*)$/);
  } else {
    $initial = $string;
    $remainder = "";
  }
  return ($initial, $remainder);
}

# 1275.pdf - 4.3.1 Path resolution procedure (top level procedure)
sub obp_resolve_path {
  my %options = @_;

  if( !exists $options{path} || !exists $options{aliases} ) {
    carp "The options 'path' and 'aliases' must be specified";
  }
  my $path_name = $options{path};
  my $aliases = $options{aliases};

  # If the pathname does not begin with "/", and its first node name
  # component is an alias, replace the alias with its expansion.
  if( $path_name !~ m[^/] ) {
    my ($head, $tail) = _left_split( $path_name, '/' );
    my ($alias_name, $alias_args) = _left_split( $head, ':' );
    if( exists $aliases->{ $alias_name } ) {
      $alias_name = $aliases->{ $alias_name };
      if( $alias_args ne '' ) {
        my ($alias_head, $alias_tail) = _right_split( $alias_name, '/' );
        my $dead_args;
        ($alias_tail, $dead_args) = _right_split( $alias_tail, ':' );
        if( $alias_head ne '' ) {
          $alias_tail = $alias_head . '/' . $alias_tail;
        }
        $alias_name = $alias_tail . ':' . $alias_args;
      }
      if( $tail eq '' ) {
        $path_name = $alias_name;
      } else {
        $path_name = $alias_name . '/' . $tail;
      }
    }
  }
  $path_name;
}

sub obp_aliases {
  my $this = shift;

  my $alias_node = $this->find_nodes( devfs_path => '/aliases' );
  my %aliases;
  if( defined $alias_node ) {
    my $props = $alias_node->prom_props;
    foreach my $prop (keys %$props) {
      # The 'name' property is always present, but it is not an alias.
      # Skip it.
      next if( $prop eq 'name' );
      $aliases{$prop} = $props->{$prop}->string;
    }
  } else {
    die "The '/aliases'-node in the devicetree could not be found.";
  }
  return \%aliases;
}

sub obp_chosen_boot_device {
  my $this = shift;
  return $this->find_prop( devfs_path => '/chosen', prom_prop_name => 'bootpath' );
}

sub obp_boot_devices {
  my $this = shift;
  my $prop = $this->find_prop( devfs_path => '/options', prom_prop_name => 'boot-device' );
  my @boot_devices = split /\s+/, $prop->string;
  return @boot_devices;
}

sub obp_diag_devices {
  my $this = shift;
  my $prop = $this->find_prop( devfs_path => '/options', prom_prop_name => 'diag-device' );
  my @diag_devices = split /\s+/, $prop->string;
  return @diag_devices;
}

1;