mirror of
git://git.psyced.org/git/psyced
synced 2024-08-15 03:25:10 +00:00
let the past begone in cvs land. welcome to igit igit!
This commit is contained in:
PSYC
commit
4e601cf1c7
509 changed files with 77963 additions and 0 deletions
361
utility/INI.pm
Normal file
361
utility/INI.pm
Normal file
|
|
@ -0,0 +1,361 @@
|
|||
# $Id: INI.pm,v 1.34 2006/06/14 16:27:23 lynx Exp $
|
||||
package INI;
|
||||
require Tie::Hash;
|
||||
@ISA = (Tie::ExtraHash);
|
||||
|
||||
use strict;
|
||||
|
||||
# lynx: you propably really want that _all_ tied INI hashes in a Perl ...
|
||||
# "session" share the verbosity-setting, but would you mind if i did that some
|
||||
# more OO, on a per hash basis?
|
||||
my $verbose = 0;
|
||||
# saga: i don't need this to be any better but if your heart aches, go ahead
|
||||
|
||||
sub HASH { 0 }
|
||||
sub FNAME { 1 }
|
||||
sub CHANGED { 2 }
|
||||
sub MAX { 3 }
|
||||
sub JANITOR { 4 }
|
||||
|
||||
sub import {
|
||||
$_ = join ' ', @_;
|
||||
$verbose = /\bverbose\b/i;
|
||||
}
|
||||
|
||||
sub iniSane {
|
||||
my $self = shift;
|
||||
my $key = shift;
|
||||
my $value = shift;
|
||||
|
||||
if (defined $value && $key !~ /^.+?_.+/) {
|
||||
die "'$key' is not a valid key";
|
||||
}
|
||||
|
||||
if ($key =~ /[\r\n\s]/) {
|
||||
die "invalid characters in key '$key'";
|
||||
}
|
||||
|
||||
if (defined $value && $value =~ /[\r\n]/) {
|
||||
die "invalid characters in value for '$key'";
|
||||
}
|
||||
}
|
||||
|
||||
# TODO:: make janitor a more swanky datastructure.
|
||||
# like $janitor->{'_foo'}->[CHILDREN]->{'_bar'}->[COUNT]
|
||||
# instead of $janitor->{'_foo_bar'}.
|
||||
# on the other hand, we'd probably need entries for levels with a count of 0,
|
||||
# if they got child levels. hm.
|
||||
# it'd eat more memory (ok, we don't have to care for that), and.. i'm not even
|
||||
# sure if it would be faster. probably not. same operations, splitting on "_",
|
||||
# and we'd have to walk through the structure beginning from the leftmost level
|
||||
# of a value to the right every time while we might find our levels earlier
|
||||
# if coming from the right (.. trying _foo_bar_some before _foo_bar before
|
||||
# _foo) in the average case. we'll at least in some cases, while we always need
|
||||
# to walk through from the leftmost level if doing that tree specified above.
|
||||
# hm. i'll have to think that over.
|
||||
sub iniJanDel {
|
||||
my $self = shift;
|
||||
my $key = shift;
|
||||
my $janitor = $self->[JANITOR];
|
||||
my $max = $self->[MAX];
|
||||
|
||||
while ($key =~ s/(.+)_.*/$1/) {
|
||||
if ($janitor->{$key}-- == $max) {
|
||||
for (my $i = 1; $i < $max; $i++) {
|
||||
$self->iniJanAdd($key);
|
||||
}
|
||||
last;
|
||||
}
|
||||
last if $janitor->{$key} >= $max;
|
||||
delete $janitor->{$key} unless $janitor->{$key};
|
||||
}
|
||||
}
|
||||
|
||||
sub iniJanAdd {
|
||||
my $self = shift;
|
||||
my $key = shift;
|
||||
my $janitor = $self->[JANITOR];
|
||||
my $max = $self->[MAX];
|
||||
|
||||
while ($key =~ s/(.+)_.*/$1/) {
|
||||
if (++$janitor->{$key} == $max) {
|
||||
for (my $i = 1; $i < $max; $i++) {
|
||||
$self->iniJanDel($key);
|
||||
}
|
||||
last;
|
||||
}
|
||||
last if $janitor->{$key} > $max;
|
||||
}
|
||||
}
|
||||
|
||||
sub iniParse {
|
||||
my $self = shift;
|
||||
my $fname = $self->[FNAME];
|
||||
my $max = $self->[MAX];
|
||||
my $hash = $self->[HASH];
|
||||
my $janitor = $self->[JANITOR];
|
||||
my $section;
|
||||
|
||||
open(FILE, '<', $fname) || die $!;
|
||||
while (<FILE>) {
|
||||
chomp;
|
||||
|
||||
next if /^\s*(?:$|;)/;
|
||||
|
||||
if (/^\[(.+?)\]\s*(?:;.*)?$/) {
|
||||
$self->iniSane($1);
|
||||
$section = $1;
|
||||
print STDERR "$section " if $verbose;
|
||||
next;
|
||||
}
|
||||
|
||||
if ($section && /^(.+?)\s*=\s*((?>(?:(?<=(?<!\\)\\)(?:\\\\)*["\s;\\]|[^"\s\\;]|\s(?!\s*(?:;|$))|\\(?!$))*)|"(?:(?<=(?<!\\)\\)(?:\\\\)*["\s]|[^"])*?(?:(?<!\\)(?:\\\\)+|(?<!\\))")\s*(?:;.*)?$/) {
|
||||
my $t = join('', $section, $1);
|
||||
my $t2 = $2;
|
||||
if (substr($t2, 0, 1) eq '"') {
|
||||
$t2 = substr($t2, 1, length($t2)-2);
|
||||
}
|
||||
$t2 =~ s/\\(.)/$1/g;
|
||||
$self->iniSane($t, $t2);
|
||||
$hash->{$t} = $t2;
|
||||
# print STDERR "$t is $t2\n";
|
||||
$self->iniJanAdd($t) if $max;
|
||||
next;
|
||||
}
|
||||
|
||||
die "failed in parsing from '$fname':\n$_\n(line $.)" if ($_);
|
||||
}
|
||||
close(FILE);
|
||||
}
|
||||
|
||||
sub iniSerialize {
|
||||
my $self = shift;
|
||||
my $hash = $self->[HASH];
|
||||
my $janitor = $self->[JANITOR];
|
||||
my $max = $self->[MAX];
|
||||
my %shash = ();
|
||||
my $nottop;
|
||||
my $res = ";this is an automatically generated file, you may change it as "
|
||||
. "you like, but\n"
|
||||
. ";keep in mind that your comments will be destroyed if a "
|
||||
. "config tool makes some\n"
|
||||
. ";changes.\n\n";
|
||||
|
||||
foreach (keys %$hash) {
|
||||
my $sec = $_;
|
||||
my $key = "";
|
||||
my ($section, $buf);
|
||||
|
||||
while ($max && $sec =~ s/(.+)(_.*)/$1/) {
|
||||
$key = $2 . $key;
|
||||
if ($janitor->{$sec} >= $max) {
|
||||
$section = $sec;
|
||||
last;
|
||||
}
|
||||
}
|
||||
|
||||
unless ($section) {
|
||||
/(.+?)(_.*)/;
|
||||
$section = $1;
|
||||
$key = $2;
|
||||
}
|
||||
|
||||
$shash{$section} = {} unless exists $shash{$section};
|
||||
|
||||
$buf = $hash->{$_};
|
||||
$buf =~ s/\\/\\\\/g;
|
||||
$buf =~ s/"/\\"/g;
|
||||
if ($buf =~ /(?:^\s|\s$|;)/) {
|
||||
$buf = join('', '"', $buf, '"');
|
||||
}
|
||||
|
||||
$shash{$section}->{$key} = $buf;
|
||||
}
|
||||
|
||||
foreach my $base (sort keys %shash) {
|
||||
if ($nottop) {
|
||||
$res .= "\n";
|
||||
} else {
|
||||
$nottop = 1;
|
||||
}
|
||||
|
||||
$res .= join('', '[', $base, ']', "\n");
|
||||
|
||||
foreach my $child (keys %{$shash{$base}}) {
|
||||
$res .= join(' ', $child, '=', $shash{$base}->{$child});
|
||||
$res .= "\n";
|
||||
}
|
||||
}
|
||||
|
||||
return $res;
|
||||
}
|
||||
|
||||
sub TIEHASH {
|
||||
my $pkg = shift;
|
||||
my $fname = shift || die 'NO FILENAME PROVIDED';
|
||||
my $max = shift;
|
||||
my $self = [{}, $fname, 0, $max, {}];
|
||||
|
||||
bless $self, $pkg;
|
||||
|
||||
if (-r $fname) {
|
||||
print STDERR "Loading from $fname:\n" if $verbose;
|
||||
$self->iniParse();
|
||||
print STDERR "\nConfiguration loaded.\n\n" if $verbose;
|
||||
} else {
|
||||
print STDERR "$fname does not exist.\n" if $verbose;
|
||||
}
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub STORE {
|
||||
my $self = shift;
|
||||
my $key = shift;
|
||||
my $value = shift;
|
||||
|
||||
|
||||
#TODO: needs more restrictive checks, (key, value) are valid if they can be
|
||||
#added to the hash.
|
||||
#alternatively keep this somewhat abstract and overload it for psyced config
|
||||
#sanity checks.
|
||||
#oh, i like that.
|
||||
|
||||
$self->iniSane($key, $value);
|
||||
|
||||
$self->[CHANGED] = 1;
|
||||
|
||||
if ($self->[MAX] && !exists $self->[HASH]->{$key}) {
|
||||
$self->iniJanAdd($key);
|
||||
}
|
||||
|
||||
return $self->SUPER::STORE($key, $value);
|
||||
}
|
||||
|
||||
sub DELETE {
|
||||
my $self = shift;
|
||||
my $key = shift;
|
||||
|
||||
if ($self->[MAX] && exists $self->[HASH]->{$key}) {
|
||||
$self->iniJanDel($key);
|
||||
}
|
||||
|
||||
return $self->SUPER::DELETE($key);
|
||||
}
|
||||
|
||||
sub CLEAR {
|
||||
my $self = shift;
|
||||
|
||||
$self->[CHANGED] = 1;
|
||||
$self->[JANITOR] = {};
|
||||
|
||||
return $self->SUPER::CLEAR();
|
||||
}
|
||||
|
||||
sub SCALAR {
|
||||
my $self = shift;
|
||||
|
||||
return $self->iniSerialize();
|
||||
}
|
||||
|
||||
sub UNTIE {
|
||||
my $self = shift;
|
||||
|
||||
return unless $self->[CHANGED];
|
||||
|
||||
open(FILE, '>', $self->[FNAME]) || die $!;
|
||||
print FILE $self->iniSerialize();
|
||||
close(FILE);
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
=head1 NAME
|
||||
|
||||
INI - class definitions for tying .ini-like configuration files as hashes
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
require INI;
|
||||
|
||||
tie(%hash, INI, 'conf.ini', 5);
|
||||
|
||||
if ($hash{'_some_system_setting'} =~ /^y(?:es)$/) {
|
||||
# do something
|
||||
}
|
||||
|
||||
$hash{'_some_system_setting2'} = 12;
|
||||
|
||||
untie %hash;
|
||||
|
||||
=head1 FORMAT DESCRIPTION
|
||||
|
||||
[section] ; comment
|
||||
key = value ; comment
|
||||
key = "value" ; comment
|
||||
; comment
|
||||
(all whitespaces up to here are optional).
|
||||
|
||||
key = \"
|
||||
(value of key will be a quote sign)
|
||||
|
||||
key = \; ; and
|
||||
key = ";"
|
||||
(value of key will will be a semicolon)
|
||||
|
||||
Section- and keynames should start with underscores.
|
||||
|
||||
The section names are just prepended to the key names, so
|
||||
|
||||
[_foo]
|
||||
_bar_snafu = kibo
|
||||
and
|
||||
[_foo_bar]
|
||||
_snafu = kibo
|
||||
define the same (key, value)-tuple.
|
||||
|
||||
=head1 API
|
||||
|
||||
=over
|
||||
|
||||
=item tie(B<HASH>, B<FILE>, B<MAX>)
|
||||
|
||||
Tie B<FILE> to B<HASH>, B<FILE> will be parsed upon tie and fill the hash,
|
||||
contents of B<HASH> will be serialized to B<FILE> on untie.
|
||||
|
||||
B<MAX> is optional and defines when a level counts as full, thus if B<MAX>
|
||||
is set to 3, and you have 3 settings named _foo_bar_something1,
|
||||
_foo_bar_something2 and _foo_bar_something3, they'll be serialized into a
|
||||
|
||||
section [_foo_bar] as _something<digit> = value.
|
||||
|
||||
=item untie(B<HASH>)
|
||||
|
||||
Untie B<HASH>, will be serialized into B<FILE> given in the tie statement if
|
||||
changed.
|
||||
|
||||
Will use B<MAX> (from the tie statement) to find out which levels deserve their
|
||||
own section.
|
||||
|
||||
=item scalar(B<HASH>)
|
||||
|
||||
Returns a string containing B<HASH> serialized into the INI format.
|
||||
You'll most probably never need that for anything but debugging purposes, as
|
||||
B<INI> does serializing into files for you on untie.
|
||||
|
||||
=back
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<http://about.psyc.eu/psyced>
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Tobias Josefowitz, <tobij@goodadvice.pages.de>
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright (c) 2005 Tobias Josefowitz.
|
||||
All rights reserved.
|
||||
|
||||
This program is free software under the GPL.
|
||||
=cut
|
||||
Loading…
Add table
Add a link
Reference in a new issue