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