############################################################
#
#   $Id: Handle.pm 976 2007-03-04 20:47:36Z nicolaw $
#   Parse::DMIDecode::Handle - SMBIOS Structure Handle Object Class
#
#   Copyright 2006 Nicola Worthington
#
#   Licensed under the Apache License, Version 2.0 (the "License");
#   you may not use this file except in compliance with the License.
#   You may obtain a copy of the License at
#
#       http://www.apache.org/licenses/LICENSE-2.0
#
#   Unless required by applicable law or agreed to in writing, software
#   distributed under the License is distributed on an "AS IS" BASIS,
#   WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
#   See the License for the specific language governing permissions and
#   limitations under the License.
#
############################################################

package Parse::DMIDecode::Handle;
# vim:ts=4:sw=4:tw=78

use strict;
use Parse::DMIDecode::Constants qw(@TYPES %GROUPS %TYPE2GROUP);
#use Scalar::Util qw(refaddr);
#use Storable qw(dclone);
use Carp qw(croak cluck confess carp);
use vars qw($VERSION $DEBUG);

$VERSION = '0.03' || sprintf('%d', q$Revision: 976 $ =~ /(\d+)/g);
$DEBUG ||= $ENV{DEBUG} ? 1 : 0;

my $objstore = {};


#
# Methods
#

sub new {
	ref(my $class = shift) && croak 'Class name required';
	croak 'Odd number of elements passed when even was expected' if @_ % 2;

	my $stor = {@_};
	my @validkeys = qw(raw nowarnings);
	my $validkeys = join('|',@validkeys);
	my @invalidkeys = grep(!/^$validkeys$/,keys %{$stor});
	delete $stor->{$_} for @invalidkeys;
	cluck('Unrecognised parameters passed: '.join(', ',@invalidkeys))
		if @invalidkeys && $^W;

	return unless defined defined $stor->{raw};
	for (split(/\n/,$stor->{raw})) {
		if (/^Handle ([0-9A-Fx]+)(?:, DMI type (\d+), (\d+) bytes?\.?)?\s*$/) {
			$stor->{handle} = $1;
			$stor->{dmitype} = $2 if defined $2;
			$stor->{bytes} = $3 if defined $3;
		} elsif (defined $stor->{handle} &&
				/^\s*DMI type (\d+), (\d+) bytes?\.?\s*$/) {
			$stor->{dmitype} = $1 if defined $1;
			$stor->{bytes} = $2 if defined $2;
		} else {
			$stor->{raw_entries} = [] unless defined $stor->{raw_entries};
			push @{$stor->{raw_entries}}, $_;
		}
	}

	my ($data,$keywords) = _parse($stor)
		if $stor->{raw_entries};

	my @objects;
	for my $name (keys(%{$data})) {
		my $self = bless \(my $dummy), $class;
		push @objects, $self;

		$objstore->{_refaddr($self)} = _deepcopy($stor);
		my $stor = $objstore->{_refaddr($self)};

		$stor->{description} = substr($name,4);
		$stor->{data} = $data->{$name} || {};
		$stor->{keywords} = $keywords->{$name} || {};

		DUMP('$self',$self);
		DUMP('$stor',$stor);
	}

	DUMP('\@objects',\@objects);
	return @objects;
}


no warnings 'redefine';
sub UNIVERSAL::a_sub_not_likely_to_be_here { ref($_[0]) }
use warnings 'redefine';


sub _blessed ($) {
	local($@, $SIG{__DIE__}, $SIG{__WARN__});
	return length(ref($_[0]))
			? eval { $_[0]->a_sub_not_likely_to_be_here }
			: undef
}


sub _refaddr($) {
	my $pkg = ref($_[0]) or return undef;
	if (_blessed($_[0])) {
		bless $_[0], 'Scalar::Util::Fake';
	} else {
		$pkg = undef;
	}
	"$_[0]" =~ /0x(\w+)/;
	my $i = do { local $^W; hex $1 };
	bless $_[0], $pkg if defined $pkg;
	return $i;
}


sub _deepcopy{
	my $this = shift;
	if (!ref($this)) {
		$this;
	} elsif (ref($this) eq 'ARRAY') {
		[ map _deepcopy($_), @{$this} ];
	} elsif (ref($this) eq 'HASH'){
		scalar { map { $_ => _deepcopy($this->{$_}) } keys %{$this} };
	} else {
		confess "What type is $_?";
	}
}


sub parsed_structures {
	my $self = shift;
	croak 'Not called as a method by parent object'
		unless ref $self && UNIVERSAL::isa($self, __PACKAGE__);
	return _deepcopy($objstore->{_refaddr($self)}->{data});
}


sub keyword {
	my $self = shift;
	croak 'Not called as a method by parent object'
		unless ref $self && UNIVERSAL::isa($self, __PACKAGE__);
	croak sprintf('%s elements passed when one was expected',
		(@_ > 1 ? 'Multiple' : 'No')) if @_ != 1;
	return $objstore->{_refaddr($self)}->{keywords}->{$_[0]};
}


sub keywords {
	my $self = shift;
	croak 'Not called as a method by parent object'
		unless ref $self && UNIVERSAL::isa($self, __PACKAGE__);
	return sort(keys(%{$objstore->{_refaddr($self)}->{keywords}}));
}


sub raw {
	my $self = shift;
	croak 'Not called as a method by parent object'
		unless ref $self && UNIVERSAL::isa($self, __PACKAGE__);
	return $objstore->{_refaddr($self)}->{raw};
}


sub description {
	my $self = shift;
	croak 'Not called as a method by parent object'
		unless ref $self && UNIVERSAL::isa($self, __PACKAGE__);
	return $objstore->{_refaddr($self)}->{description};
}


sub bytes {
	my $self = shift;
	croak 'Not called as a method by parent object'
		unless ref $self && UNIVERSAL::isa($self, __PACKAGE__);
	return $objstore->{_refaddr($self)}->{bytes};
}


sub type { &dmitype; }
sub dmitype {
	my $self = shift;
	croak 'Not called as a method by parent object'
		unless ref $self && UNIVERSAL::isa($self, __PACKAGE__);
	return $objstore->{_refaddr($self)}->{dmitype};
}


sub address { &handle; }
sub handle {
	my $self = shift;
	croak 'Not called as a method by parent object'
		unless ref $self && UNIVERSAL::isa($self, __PACKAGE__);
	return $objstore->{_refaddr($self)}->{handle};
}


sub _parse {
	my $stor = shift;
	return unless defined $stor->{raw_entries};

	my $name_indent = 0;
	my $key_indent  = 0;
	my $name = '';
	my $name_cnt = 0;
	my $key = '';
	my $legacy_dmidecode_binary_data = 0;

	my @errors;
	my %data;
	my %keywords;

#	DUMP('$stor->{raw_entries}',$stor->{raw_entries});

	for (my $l = 0; $l < @{$stor->{raw_entries}}; $l++) {
		local $_ = $stor->{raw_entries}->[$l];
		my ($indent) = $_ =~ /^(\s+)/;
		$indent = '' unless defined $indent;
		$indent = length($indent);

		# Old version of dmidecode - we don't support this very well
#Handle 0xD402
#|   DMI type 212, 47 bytes.
#70 00 71 00 03 40 59 6d d8 00 55 7f 80 d9 00 55 |   p.q..@Ym..U....U
#7f 00 00 c0 5c 00 0a 03 c0 67 00 05 83 00 76 00 |   ....\....g....v.
#00 84 00 77 00 00 ff ff 00 00 00                |   ...w.......
		if ((!$name || $legacy_dmidecode_binary_data) && /^(([a-f0-9]{2} )+)\s*\t[[:print:]]{1,16}\s*$/) {
			my $data = $1;
			chop $data;
			$name ||= sprintf('%03d|%s',++$name_cnt,'OEM-specific Type');
			$key = 'Header and Data';
			$legacy_dmidecode_binary_data = 1;
			$data{$name}->{$key}->[1] = [] unless defined $data{$name}->{$key}->[1];
			push @{$data{$name}->{$key}->[1]}, $data;
			next;
		}

		$name_indent = $indent if $l == 0;
		if ($l == 1) {
			if ($indent > $name_indent) { $key_indent = $indent; }
			else { push @errors, "Parser warning: key_indent ($indent) <= name_indent ($name_indent): $_"; }
		}

		# data
		if (/^\s{$name_indent}(\S+.*?)\s*$/) {
			$name = sprintf('%03d|%s',++$name_cnt,$1);
			$data{$name} = {};
			$key = '';

		} elsif ($name && /^\s{$key_indent}(\S.*?)(?::|:\s+(\S+.*?))?\s*$/) {
			$key = $1;
			$data{$name}->{$key}->[0] = $2;
			$data{$name}->{$key}->[1] = [] unless defined $data{$name}->{$key}->[1];
			$keywords{$name}->{_keyword($stor,$key)} = $data{$name}->{$key}->[0]
				if defined $TYPE2GROUP{$stor->{dmitype}}

		} elsif ($name && $key && $indent > $key_indent && /^\s*(\S+.*?)\s*$/) {
			push @{$data{$name}->{$key}->[1]}, $1;
			$keywords{$name}->{_keyword($stor,$key)} = $data{$name}->{$key}->[1]
				if defined $TYPE2GROUP{$stor->{dmitype}};# && !defined $data{$name}->{$key}->[0];

		# unknown
		} else {
			push @errors, "Parser warning: $_";
		}
	}

	sub _keyword {
		my ($stor,$key) = @_;
		(my $keyword = $key) =~ s/[^a-z0-9]/-/gi;
		$keyword = lc("$TYPE2GROUP{$stor->{dmitype}}-$keyword");
		return $keyword;
	}

	#if ($^W && @errors) {
	if (@errors && !$stor->{nowarnings}) {
		carp $_ for @errors;
	}

	return (\%data,\%keywords);
}


sub TRACE {
	return unless $DEBUG;
	carp(shift());
}


sub DUMP {
	return unless $DEBUG;
	eval {
		require Data::Dumper;
		local $Data::Dumper::Indent = 2;
		local $Data::Dumper::Terse = 1;
		carp(shift().': '.Data::Dumper::Dumper(shift()));
	}
}

1;



=pod

=head1 NAME

Parse::DMIDecode::Handle - SMBIOS Structure Handle Object Class

=head1 SYNOPSIS

 use Parse::DMIDecode qw();
 my $decoder = new Parse::DMIDecode;
 $decoder->probe;
 
 for my $handle ($decoder->get_handles) {
     printf("Handle %s of type %s is %s bytes long (minus strings).\n".
            "  > Contians the following keyword data entries:\n",
             $handle->handle,
             $handle->dmitype,
             $handle->bytes
         );
 
     for my $keyword ($handle->keywords) {
         my $value = $handle->keyword($keyword);
         printf("Keyword \"%s\" => \"%s\"\n",
                 $keyword,
                 (ref($value) eq 'ARRAY' ?
                     join(', ',@{$value}) : ($value||''))
             );
     }
 }

=head1 DESCRIPTION

=head1 METHODS

=head2 new

Create a new struture handle object. This is called by L<Parse::DMIDecode>'s
I<parse()> (and indirectly by I<probe()>) methods.

=head2 raw

 my $raw_data = $handle->raw;

Returns the raw data as generated by I<dmidecode> that was
parsed to create this handle object.

=head2 bytes

 my $bytes = $handle->bytes;

=head2 address

 my $address = $handle->address;

Returns the address handle of the structure.

=head2 handle

Alias for address.

=head2 dmitype

 my $dmitype = $handle->dmitype;

=head2 type

Alias for dmitype.

=head2 description

 my $description = $handle->description;

=head2 keywords

 my @keywords = $handle->keywords;

Returns a list of keyword data pairs available for retreival from
this handle object.

=head2 keyword

 for my $keyword ($handle->keywords) {
     printf("Keyword \"%s\" => \"%s\"\n",
             $keyword,
             $handle->keyword($keyword)
         );
 }

=head2 parsed_structures

 use Data::Dumper;
 my $ref = $handle->parsed_structures;
 print Dumper($ref);

Returns a copy of the parsed structures. This should be used with care
as this is a cloned copy of the parsed data structures that the
I<Parse::DMIDecode::Handle> object uses internally, and as such may
change format in later releases without notice.

=head1 SEE ALSO

L<Parse::DMIDecode>

=head1 VERSION

$Id: Handle.pm 976 2007-03-04 20:47:36Z nicolaw $

=head1 AUTHOR

Nicola Worthington <nicolaw@cpan.org>

L<http://perlgirl.org.uk>

If you like this software, why not show your appreciation by sending the
author something nice from her
L<Amazon wishlist|http://www.amazon.co.uk/gp/registry/1VZXC59ESWYK0?sort=priority>? 
( http://www.amazon.co.uk/gp/registry/1VZXC59ESWYK0?sort=priority )

=head1 COPYRIGHT

Copyright 2006 Nicola Worthington.

This software is licensed under The Apache Software License, Version 2.0.

L<http://www.apache.org/licenses/LICENSE-2.0>

=cut


__END__