xref: /trunk/main/solenv/bin/modules/GenInfoParser.pm (revision 9780544f)

#**************************************************************
#
#  Licensed to the Apache Software Foundation (ASF) under one
#  or more contributor license agreements.  See the NOTICE file
#  distributed with this work for additional information
#  regarding copyright ownership.  The ASF licenses this file
#  to you 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.
#
#**************************************************************



#*************************************************************************
#
# GenInfoParser - Perl extension for parsing general info databases
#
# usage: see below
#
#*************************************************************************

package GenInfoParser;

use strict;

use Carp;

#####  profiling #####
# use Benchmark;

##### ctor #####

sub new {
    my $proto = shift;
    my $class = ref($proto) || $proto;
    my $self = {};
    $self->{'LIST'} = undef;
    $self->{'DATA'} = {};
    bless ($self, $class);
    return $self;
}

##### methods #####

sub load_list
{
    # load list into memory
    my $self        = shift;
    my $list_file   = shift;

    if ( $self->parse_list($list_file) ) {
        return 1;
    }
    return 0;
}

sub get_keys
{
	# return a sorted list of keys, the sorting is case insensitive
    my $self        = shift;
    my $access_path = shift;

    my ($key, $value, $sub_data_ref) = $self->walk_accesspath($access_path);

    my @keys = ();
	if ( $sub_data_ref ) {
		my @normalized_keys = keys %$sub_data_ref;
		foreach my $normalized_key (sort keys %$sub_data_ref) {
			push(@keys, $$sub_data_ref{$normalized_key}[0]);
        }
    } elsif ( $value ) {
        chomp $value;
        push @keys, ($value);
    }
    return @keys;
}

sub get_key
{
    # returns the key corresponding to the access_path
    my $self        = shift;
    my $access_path = shift;

    my ($key, $value, $sub_data_ref) = $self->walk_accesspath($access_path);
    return undef if !$key;
    return $key;
}

sub get_value
{
    # returns the value corresponding to the access_path
    my $self        = shift;
    my $access_path = shift;

    my ($key, $value, $sub_data_ref) = $self->walk_accesspath($access_path);
    return undef if !$key;
	$value = "" if !defined($value);
    # trim line ends
    $value =~ tr/\r\n//d;
    # trim trailing whitespace
    $value =~ s/\s+$//;
    return $value;
}

##### private methods #####

sub parse_list
{
    # parse complete list
    my $self        = shift;
    my $list_file   = shift;
    my @list_data;

    return 0 if ! -r $list_file;

    open(FILE, "<$list_file") or croak("can't open $list_file: $!");
    # my $t0 = new Benchmark;
    $self->parse_block(\*FILE, $self->{'DATA'});
    # my $t1 = new Benchmark;
    # print STDERR "parsing $list_file took: ", timestr(timediff($t1, $t0)), "\n";
    close(FILE);
}

sub parse_block
{
	# parse each sub block and place it in a hash
	# used data structure:
	# $hash{$normalized_key} = [ $key, $value, 0 | $sub_hash_ref ]
    my $self        = shift;
    my $glob_ref    = shift;
    my $data_ref    = shift;

    my $current_key = 0;
    my $line;
    while( $line = <$glob_ref> ) {
        # this is the inner loop, any additional pattern matching will
        # have a notable affect on runtime behavior
        # clean up of $value is done in get_value()
        my ($key, $value) = split(' ', $line, 2);
        next if !$key;                  # skip empty lines
        my $chr = substr($key, 0, 1);
        next if $chr eq '#';            # skip comment lines
        last if $chr eq '}';            # return from block;
        if ( $chr eq '{' ) {
            if ( !$current_key ) {
                croak("unexpected block start");
            }
            else {
				# create empty hash and start sub block parse
                $$data_ref{$current_key}[2] = {};
                $self->parse_block($glob_ref, $$data_ref{$current_key}[2]);
                next;
            }
        }
        # sanity check
        croak("key $key is not well formed") if $key =~ /\//;
		# normalize key for hash lookup
		$current_key = lc($key);
		# but we have to keep the original - not normalized - key, too
        $$data_ref{($current_key)} = [$key, $value, 0];
    }
}

sub walk_accesspath
{
	# returns the key, value and sub_data_ref which
    # corresponds to the access_path

    my $self        = shift;
    my $access_path = shift;

    my $sub_data_ref = $self->{'DATA'};

    if ( $access_path ) {
        my $lookup_ref = 0;
        # normalize key
        $access_path = lc($access_path);
        my @key_sequence = split(/\//, $access_path);
        foreach my $key_element (@key_sequence) {
            # at least one more key element, but no sub_hash, accesspath invalid
            return () if !$sub_data_ref;
			$lookup_ref = $$sub_data_ref{$key_element};
			# lookup failed, accesspath invalid
			return () if !defined($lookup_ref);
			# we've got a valid key
			$sub_data_ref = $$lookup_ref[2];
        }
	    return ($$lookup_ref[0], $$lookup_ref[1], $sub_data_ref);
    }
    else {
        # empty access path is only vlaid for getting top level key list
        return ( undef, undef, $sub_data_ref );
    }
}

##### finish #####

1; # needed by use or require

__END__

=head1 NAME

GenInfoParser - Perl extension for parsing general info databases

=head1 SYNOPSIS

    # example that will load a general info database called 'stand.lst'

    use GenInfoParser;

    # Create a new instance of the parser:
    $a = GenInfoParser->new();

    # Load the database into the parser:
    $a->load_list('ssrc633.ini');

    # get top level keys from database
    @top_level_keys = $a->get_keys();

    # get sub list keys
    @sub_list_keys = $a->get_keys('src633/Drives/o:/Projects');

    # get key/value pair
    $key = $a->get_key('src633/Comment/build');
    $value = $a->get_value('src633/Comment/build');

=head1 DESCRIPTION

GenInfoParser is a perl extension to load and parse General Info Databses.
It uses a simple object oriented interface to retrieve the information stored
in the database.

Methods:

GenInfoParser::new()

Creates a new instance of the parser. Can't fail.


GenInfoParser::load_list($database)

Loads and parses $database. Returns 1 on success and 0 on failure


GenInfoParser::get_keys($path)

Returns a sorted list of keys from the path $path. Returns an emtpy list if $path
has no sublist. If there is no $path spcified, the method will return the
primary key list. $path can be specified case insensitive. Sorting is done case
insensitive.

GenInfoParser::get_key($path)

Returns the key to $path or 'undef' if an invalid path is given.
Example: $path = 'src633/comment/build' will return 'Build' as key.
Note: $path can be specified case insensitive, but the returned key will
have the exact case as in the database.

GenInfoParser::get_value($path)

Returns the value to $path or 'undef' is invalid path is given.


=head2 EXPORT

GenInfoParser::new()
GenInfoParser::load_list($database)
GenInfoParser::get_keys($path)
GenInfoParser::get_key($path)
GenInfoParser::get_value($path)


=head1 AUTHOR

Jens-Heiner Rechtien, rechtien@sun.com

=head1 SEE ALSO

perl(1).

=cut