#
# $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;
=pod
=head1 NAME
Solaris::DeviceTree::OBP - Utility functions for OBP access
=head1 SYNOPSIS
Value 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);
Path transformation:
$resolved_path = obp_resolve_path( aliases => $aliases, path => "disk:c" );
=head1 DESCRIPTION
The C<Solaris::DeviceTree::OBP> module implements functions for manipulating OBP pathes according to IEEE 1275.
For most of the functions you need to specify a devicetree containing PROM property nodes,
which are most likely to find in an L<Solaris::DeviceTree::Libdevinfo> tree.
=head1 EXPORT
The following functions are exported on demand:
=cut
# 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);
}
=pod
=head2 obp_resolve_path
This functions transforms the specified path in an alias-free
path using the path resolution procedure described in
C<1275.pdf - 4.3.1 Path resolution procedure> according to the specified
reference to an alias mapping.
=cut
# 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;
}
=pod
=head2 aliases
This method returns a reference to a hash which maps all aliases to their
corresponding values.
=cut
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;
}
=pod
=head2 obp_chosen_boot_device
This method returns the device from which the system has most recently booted.
=cut
sub obp_chosen_boot_device {
my $this = shift;
return $this->find_prop( devfs_path => '/chosen', prom_prop_name => 'bootpath' );
}
=pod
=head2 obp_boot_devices
This method returns a list with all boot devices entered in the OBP.
=cut
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;
}
=pod
=head2 obp_diag_devices
This method returns a list with all diag devices entered in the OBP.
=cut
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;
}
=pod
The following export tags are defined:
=over 4
=item boot
L</obp_chosen_boot_device>, L</obp_boot_devices>, L</obp_diag_devices>.
=item alias
L</obp_aliases>.
=item path
L</obp_resolve_path>.
=back 4
=head1 EXAMPLES
In the following example the resolved physical pathname of the
device last booted from is printed:
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";
=head1 AUTHOR
Dagobert Michelsen, E<lt>dam@baltic-online.deE<gt>
=head1 SEE ALSO
Open Firmware Homepage L<http://playground.sun.com/1275/home.html>,
L<eeprom(1m)>.
=cut
1;