solenv/bin/modules/GenInfoParser.pm

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