1*9780544fSAndrew Rist#**************************************************************
2*9780544fSAndrew Rist#
3*9780544fSAndrew Rist#  Licensed to the Apache Software Foundation (ASF) under one
4*9780544fSAndrew Rist#  or more contributor license agreements.  See the NOTICE file
5*9780544fSAndrew Rist#  distributed with this work for additional information
6*9780544fSAndrew Rist#  regarding copyright ownership.  The ASF licenses this file
7*9780544fSAndrew Rist#  to you under the Apache License, Version 2.0 (the
8*9780544fSAndrew Rist#  "License"); you may not use this file except in compliance
9*9780544fSAndrew Rist#  with the License.  You may obtain a copy of the License at
10*9780544fSAndrew Rist#
11*9780544fSAndrew Rist#    http://www.apache.org/licenses/LICENSE-2.0
12*9780544fSAndrew Rist#
13*9780544fSAndrew Rist#  Unless required by applicable law or agreed to in writing,
14*9780544fSAndrew Rist#  software distributed under the License is distributed on an
15*9780544fSAndrew Rist#  "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY
16*9780544fSAndrew Rist#  KIND, either express or implied.  See the License for the
17*9780544fSAndrew Rist#  specific language governing permissions and limitations
18*9780544fSAndrew Rist#  under the License.
19*9780544fSAndrew Rist#
20*9780544fSAndrew Rist#**************************************************************
21*9780544fSAndrew Rist
22*9780544fSAndrew Rist
23cdf0e10cSrcweir
24cdf0e10cSrcweir#*************************************************************************
25cdf0e10cSrcweir#
26cdf0e10cSrcweir# GenInfoParser - Perl extension for parsing general info databases
27cdf0e10cSrcweir#
28cdf0e10cSrcweir# usage: see below
29cdf0e10cSrcweir#
30cdf0e10cSrcweir#*************************************************************************
31cdf0e10cSrcweir
32cdf0e10cSrcweirpackage GenInfoParser;
33cdf0e10cSrcweir
34cdf0e10cSrcweiruse strict;
35cdf0e10cSrcweir
36cdf0e10cSrcweiruse Carp;
37cdf0e10cSrcweir
38cdf0e10cSrcweir#####  profiling #####
39cdf0e10cSrcweir# use Benchmark;
40cdf0e10cSrcweir
41cdf0e10cSrcweir##### ctor #####
42cdf0e10cSrcweir
43cdf0e10cSrcweirsub new {
44cdf0e10cSrcweir    my $proto = shift;
45cdf0e10cSrcweir    my $class = ref($proto) || $proto;
46cdf0e10cSrcweir    my $self = {};
47cdf0e10cSrcweir    $self->{'LIST'} = undef;
48cdf0e10cSrcweir    $self->{'DATA'} = {};
49cdf0e10cSrcweir    bless ($self, $class);
50cdf0e10cSrcweir    return $self;
51cdf0e10cSrcweir}
52cdf0e10cSrcweir
53cdf0e10cSrcweir##### methods #####
54cdf0e10cSrcweir
55cdf0e10cSrcweirsub load_list
56cdf0e10cSrcweir{
57cdf0e10cSrcweir    # load list into memory
58cdf0e10cSrcweir    my $self        = shift;
59cdf0e10cSrcweir    my $list_file   = shift;
60cdf0e10cSrcweir
61cdf0e10cSrcweir    if ( $self->parse_list($list_file) ) {
62cdf0e10cSrcweir        return 1;
63cdf0e10cSrcweir    }
64cdf0e10cSrcweir    return 0;
65cdf0e10cSrcweir}
66cdf0e10cSrcweir
67cdf0e10cSrcweirsub get_keys
68cdf0e10cSrcweir{
69cdf0e10cSrcweir	# return a sorted list of keys, the sorting is case insensitive
70cdf0e10cSrcweir    my $self        = shift;
71cdf0e10cSrcweir    my $access_path = shift;
72cdf0e10cSrcweir
73cdf0e10cSrcweir    my ($key, $value, $sub_data_ref) = $self->walk_accesspath($access_path);
74cdf0e10cSrcweir
75cdf0e10cSrcweir    my @keys = ();
76cdf0e10cSrcweir	if ( $sub_data_ref ) {
77cdf0e10cSrcweir		my @normalized_keys = keys %$sub_data_ref;
78cdf0e10cSrcweir		foreach my $normalized_key (sort keys %$sub_data_ref) {
79cdf0e10cSrcweir			push(@keys, $$sub_data_ref{$normalized_key}[0]);
80cdf0e10cSrcweir        }
81cdf0e10cSrcweir    } elsif ( $value ) {
82cdf0e10cSrcweir        chomp $value;
83cdf0e10cSrcweir        push @keys, ($value);
84cdf0e10cSrcweir    }
85cdf0e10cSrcweir    return @keys;
86cdf0e10cSrcweir}
87cdf0e10cSrcweir
88cdf0e10cSrcweirsub get_key
89cdf0e10cSrcweir{
90cdf0e10cSrcweir    # returns the key corresponding to the access_path
91cdf0e10cSrcweir    my $self        = shift;
92cdf0e10cSrcweir    my $access_path = shift;
93cdf0e10cSrcweir
94cdf0e10cSrcweir    my ($key, $value, $sub_data_ref) = $self->walk_accesspath($access_path);
95cdf0e10cSrcweir    return undef if !$key;
96cdf0e10cSrcweir    return $key;
97cdf0e10cSrcweir}
98cdf0e10cSrcweir
99cdf0e10cSrcweirsub get_value
100cdf0e10cSrcweir{
101cdf0e10cSrcweir    # returns the value corresponding to the access_path
102cdf0e10cSrcweir    my $self        = shift;
103cdf0e10cSrcweir    my $access_path = shift;
104cdf0e10cSrcweir
105cdf0e10cSrcweir    my ($key, $value, $sub_data_ref) = $self->walk_accesspath($access_path);
106cdf0e10cSrcweir    return undef if !$key;
107cdf0e10cSrcweir	$value = "" if !defined($value);
108cdf0e10cSrcweir    # trim line ends
109cdf0e10cSrcweir    $value =~ tr/\r\n//d;
110cdf0e10cSrcweir    # trim trailing whitespace
111cdf0e10cSrcweir    $value =~ s/\s+$//;
112cdf0e10cSrcweir    return $value;
113cdf0e10cSrcweir}
114cdf0e10cSrcweir
115cdf0e10cSrcweir##### private methods #####
116cdf0e10cSrcweir
117cdf0e10cSrcweirsub parse_list
118cdf0e10cSrcweir{
119cdf0e10cSrcweir    # parse complete list
120cdf0e10cSrcweir    my $self        = shift;
121cdf0e10cSrcweir    my $list_file   = shift;
122cdf0e10cSrcweir    my @list_data;
123cdf0e10cSrcweir
124cdf0e10cSrcweir    return 0 if ! -r $list_file;
125cdf0e10cSrcweir
126cdf0e10cSrcweir    open(FILE, "<$list_file") or croak("can't open $list_file: $!");
127cdf0e10cSrcweir    # my $t0 = new Benchmark;
128cdf0e10cSrcweir    $self->parse_block(\*FILE, $self->{'DATA'});
129cdf0e10cSrcweir    # my $t1 = new Benchmark;
130cdf0e10cSrcweir    # print STDERR "parsing $list_file took: ", timestr(timediff($t1, $t0)), "\n";
131cdf0e10cSrcweir    close(FILE);
132cdf0e10cSrcweir}
133cdf0e10cSrcweir
134cdf0e10cSrcweirsub parse_block
135cdf0e10cSrcweir{
136cdf0e10cSrcweir	# parse each sub block and place it in a hash
137cdf0e10cSrcweir	# used data structure:
138cdf0e10cSrcweir	# $hash{$normalized_key} = [ $key, $value, 0 | $sub_hash_ref ]
139cdf0e10cSrcweir    my $self        = shift;
140cdf0e10cSrcweir    my $glob_ref    = shift;
141cdf0e10cSrcweir    my $data_ref    = shift;
142cdf0e10cSrcweir
143cdf0e10cSrcweir    my $current_key = 0;
144cdf0e10cSrcweir    my $line;
145cdf0e10cSrcweir    while( $line = <$glob_ref> ) {
146cdf0e10cSrcweir        # this is the inner loop, any additional pattern matching will
147cdf0e10cSrcweir        # have a notable affect on runtime behavior
148cdf0e10cSrcweir        # clean up of $value is done in get_value()
149cdf0e10cSrcweir        my ($key, $value) = split(' ', $line, 2);
150cdf0e10cSrcweir        next if !$key;                  # skip empty lines
151cdf0e10cSrcweir        my $chr = substr($key, 0, 1);
152cdf0e10cSrcweir        next if $chr eq '#';            # skip comment lines
153cdf0e10cSrcweir        last if $chr eq '}';            # return from block;
154cdf0e10cSrcweir        if ( $chr eq '{' ) {
155cdf0e10cSrcweir            if ( !$current_key ) {
156cdf0e10cSrcweir                croak("unexpected block start");
157cdf0e10cSrcweir            }
158cdf0e10cSrcweir            else {
159cdf0e10cSrcweir				# create empty hash and start sub block parse
160cdf0e10cSrcweir                $$data_ref{$current_key}[2] = {};
161cdf0e10cSrcweir                $self->parse_block($glob_ref, $$data_ref{$current_key}[2]);
162cdf0e10cSrcweir                next;
163cdf0e10cSrcweir            }
164cdf0e10cSrcweir        }
165cdf0e10cSrcweir        # sanity check
166cdf0e10cSrcweir        croak("key $key is not well formed") if $key =~ /\//;
167cdf0e10cSrcweir		# normalize key for hash lookup
168cdf0e10cSrcweir		$current_key = lc($key);
169cdf0e10cSrcweir		# but we have to keep the original - not normalized - key, too
170cdf0e10cSrcweir        $$data_ref{($current_key)} = [$key, $value, 0];
171cdf0e10cSrcweir    }
172cdf0e10cSrcweir}
173cdf0e10cSrcweir
174cdf0e10cSrcweirsub walk_accesspath
175cdf0e10cSrcweir{
176cdf0e10cSrcweir	# returns the key, value and sub_data_ref which
177cdf0e10cSrcweir    # corresponds to the access_path
178cdf0e10cSrcweir
179cdf0e10cSrcweir    my $self        = shift;
180cdf0e10cSrcweir    my $access_path = shift;
181cdf0e10cSrcweir
182cdf0e10cSrcweir    my $sub_data_ref = $self->{'DATA'};
183cdf0e10cSrcweir
184cdf0e10cSrcweir    if ( $access_path ) {
185cdf0e10cSrcweir        my $lookup_ref = 0;
186cdf0e10cSrcweir        # normalize key
187cdf0e10cSrcweir        $access_path = lc($access_path);
188cdf0e10cSrcweir        my @key_sequence = split(/\//, $access_path);
189cdf0e10cSrcweir        foreach my $key_element (@key_sequence) {
190cdf0e10cSrcweir            # at least one more key element, but no sub_hash, accesspath invalid
191cdf0e10cSrcweir            return () if !$sub_data_ref;
192cdf0e10cSrcweir			$lookup_ref = $$sub_data_ref{$key_element};
193cdf0e10cSrcweir			# lookup failed, accesspath invalid
194cdf0e10cSrcweir			return () if !defined($lookup_ref);
195cdf0e10cSrcweir			# we've got a valid key
196cdf0e10cSrcweir			$sub_data_ref = $$lookup_ref[2];
197cdf0e10cSrcweir        }
198cdf0e10cSrcweir	    return ($$lookup_ref[0], $$lookup_ref[1], $sub_data_ref);
199cdf0e10cSrcweir    }
200cdf0e10cSrcweir    else {
201cdf0e10cSrcweir        # empty access path is only vlaid for getting top level key list
202cdf0e10cSrcweir        return ( undef, undef, $sub_data_ref );
203cdf0e10cSrcweir    }
204cdf0e10cSrcweir}
205cdf0e10cSrcweir
206cdf0e10cSrcweir##### finish #####
207cdf0e10cSrcweir
208cdf0e10cSrcweir1; # needed by use or require
209cdf0e10cSrcweir
210cdf0e10cSrcweir__END__
211cdf0e10cSrcweir
212cdf0e10cSrcweir=head1 NAME
213cdf0e10cSrcweir
214cdf0e10cSrcweirGenInfoParser - Perl extension for parsing general info databases
215cdf0e10cSrcweir
216cdf0e10cSrcweir=head1 SYNOPSIS
217cdf0e10cSrcweir
218cdf0e10cSrcweir    # example that will load a general info database called 'stand.lst'
219cdf0e10cSrcweir
220cdf0e10cSrcweir    use GenInfoParser;
221cdf0e10cSrcweir
222cdf0e10cSrcweir    # Create a new instance of the parser:
223cdf0e10cSrcweir    $a = GenInfoParser->new();
224cdf0e10cSrcweir
225cdf0e10cSrcweir    # Load the database into the parser:
226cdf0e10cSrcweir    $a->load_list('ssrc633.ini');
227cdf0e10cSrcweir
228cdf0e10cSrcweir    # get top level keys from database
229cdf0e10cSrcweir    @top_level_keys = $a->get_keys();
230cdf0e10cSrcweir
231cdf0e10cSrcweir    # get sub list keys
232cdf0e10cSrcweir    @sub_list_keys = $a->get_keys('src633/Drives/o:/Projects');
233cdf0e10cSrcweir
234cdf0e10cSrcweir    # get key/value pair
235cdf0e10cSrcweir    $key = $a->get_key('src633/Comment/build');
236cdf0e10cSrcweir    $value = $a->get_value('src633/Comment/build');
237cdf0e10cSrcweir
238cdf0e10cSrcweir=head1 DESCRIPTION
239cdf0e10cSrcweir
240cdf0e10cSrcweirGenInfoParser is a perl extension to load and parse General Info Databses.
241cdf0e10cSrcweirIt uses a simple object oriented interface to retrieve the information stored
242cdf0e10cSrcweirin the database.
243cdf0e10cSrcweir
244cdf0e10cSrcweirMethods:
245cdf0e10cSrcweir
246cdf0e10cSrcweirGenInfoParser::new()
247cdf0e10cSrcweir
248cdf0e10cSrcweirCreates a new instance of the parser. Can't fail.
249cdf0e10cSrcweir
250cdf0e10cSrcweir
251cdf0e10cSrcweirGenInfoParser::load_list($database)
252cdf0e10cSrcweir
253cdf0e10cSrcweirLoads and parses $database. Returns 1 on success and 0 on failure
254cdf0e10cSrcweir
255cdf0e10cSrcweir
256cdf0e10cSrcweirGenInfoParser::get_keys($path)
257cdf0e10cSrcweir
258cdf0e10cSrcweirReturns a sorted list of keys from the path $path. Returns an emtpy list if $path
259cdf0e10cSrcweirhas no sublist. If there is no $path spcified, the method will return the
260cdf0e10cSrcweirprimary key list. $path can be specified case insensitive. Sorting is done case
261cdf0e10cSrcweirinsensitive.
262cdf0e10cSrcweir
263cdf0e10cSrcweirGenInfoParser::get_key($path)
264cdf0e10cSrcweir
265cdf0e10cSrcweirReturns the key to $path or 'undef' if an invalid path is given.
266cdf0e10cSrcweirExample: $path = 'src633/comment/build' will return 'Build' as key.
267cdf0e10cSrcweirNote: $path can be specified case insensitive, but the returned key will
268cdf0e10cSrcweirhave the exact case as in the database.
269cdf0e10cSrcweir
270cdf0e10cSrcweirGenInfoParser::get_value($path)
271cdf0e10cSrcweir
272cdf0e10cSrcweirReturns the value to $path or 'undef' is invalid path is given.
273cdf0e10cSrcweir
274cdf0e10cSrcweir
275cdf0e10cSrcweir=head2 EXPORT
276cdf0e10cSrcweir
277cdf0e10cSrcweirGenInfoParser::new()
278cdf0e10cSrcweirGenInfoParser::load_list($database)
279cdf0e10cSrcweirGenInfoParser::get_keys($path)
280cdf0e10cSrcweirGenInfoParser::get_key($path)
281cdf0e10cSrcweirGenInfoParser::get_value($path)
282cdf0e10cSrcweir
283cdf0e10cSrcweir
284cdf0e10cSrcweir=head1 AUTHOR
285cdf0e10cSrcweir
286cdf0e10cSrcweirJens-Heiner Rechtien, rechtien@sun.com
287cdf0e10cSrcweir
288cdf0e10cSrcweir=head1 SEE ALSO
289cdf0e10cSrcweir
290cdf0e10cSrcweirperl(1).
291cdf0e10cSrcweir
292cdf0e10cSrcweir=cut
293