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