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