source: main/trunk/greenstone2/perllib/cfgread.pm@ 29794

###########################################################################
#
# cfgread.pm --
# A component of the Greenstone digital library software
# from the New Zealand Digital Library Project at the 
# University of Waikato, New Zealand.
#
# Copyright (C) 1999 New Zealand Digital Library Project
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
#
###########################################################################

# reads in configuration files

package cfgread;

use strict; no strict 'refs';


sub read_cfg_line {
    my ($handle) = @_;
    my $line = "";
    my @line = ();
    my $linecontinues = 0;

    while (defined($line = <$handle>)) {
    $line =~ s/^\#.*$//;   # remove comments
    $line =~ s/\cM|\cJ//g; # remove end-of-line characters
    $line =~ s/^\s+//;     # remove initial white space
    # Merge with following line if a quoted phrase is left un-closed.
    if ($line =~ m/^([\"\'])/ || $line =~ m/[^\\]([\"\'])/) {
        my $quote=$1;

        # Improve speed substantially by not doing the regular expression on $line in the while loop
        #   (since $line gets longer each iteration, the regular expression gets slower and slower)
        # Instead we just check each new line to see if it finishes the quoted multi-line value
        if ($line !~ m/$quote(.*?[^\\])?(\\\\)*$quote/)
        {
        my $nextline;
        while (defined($nextline = <$handle>))
        {
            $nextline =~ s/\r?\n//; # remove end-of-line
            $line .= " " . $nextline;

            # Break out of the while loop if we've found the end of the multi-line value
            last if ($nextline =~ m/^(.*?[^\\])?(\\\\)*$quote/);
        }
        }
    }
    $linecontinues = $line =~ s/\\$//;

    while ($line =~ s/\s*(\".*?[^\\](\\\\)*\"|\'.*?[^\\](\\\\)*\'|\S+)\s*//) {
        if (defined $1) {
        # remove any enclosing quotes
        my $entry = $1;
        $entry =~ s/^([\"\'])(.*)\1$/$2/;

        # substitute an environment variables
##      $entry =~ s/\$(\w+)/$ENV{$1}/g;
        $entry =~ s/\$\{(\w+)\}/$ENV{$1}/g;
        push (@line, $entry);
        } else {
        push (@line, "");
        }
    }

    if (scalar(@line) > 0 && !$linecontinues) {
#       print STDERR "line: \"" . join ("\" \"", @line) . "\"\n";
        return \@line;
    }
    }

    return undef;
}

sub write_cfg_line {
    my ($handle, $line) = @_;
    print $handle join ("\t", @$line), "\n";
}


# stringexp, arrayexp, hashexp,arrayarrayexp and hashhashexp
# should be something like '^(this|that)$'
sub read_cfg_file {
    my ($filename, $stringexp, $arrayexp, $hashexp, $arrayarrayexp,
    $hashhashexp) = @_;
    my ($line);
    my $data = {};

    if (open (COLCFG, $filename)) {
    while (defined ($line = &read_cfg_line('COLCFG'))) {
        if (scalar(@$line) >= 2) {
        my $key = shift (@$line);
        if (defined $stringexp && $key =~ /$stringexp/) {
            $data->{$key} = shift (@$line);

        } elsif (defined $arrayexp && $key =~ /$arrayexp/) {
            push (@{$data->{$key}}, @$line);

        } elsif (defined $hashexp && $key =~ /$hashexp/) {
            my $k = shift @$line;
            my $v = shift @$line;
            $data->{$key}->{$k} = $v;
        } elsif (defined $arrayarrayexp && $key =~ /$arrayarrayexp/) {
            if (!defined $data->{$key}) {
            $data->{$key} = [];
            }
            push (@{$data->{$key}}, $line);
        }
        elsif (defined $hashhashexp && $key =~ /$hashhashexp/) {
            my $k = shift @$line;
            my $p = shift @$line;
            my $v = shift @$line;
            if (!defined $v) {
            $v = $p;
            $p = 'default';
            }
            $data->{$key}->{$k}->{$p} = $v;
        }
        }
    }
    close (COLCFG);

    } else {
    print STDERR "cfgread::read_cfg_file couldn't read the cfg file $filename\n";
    }

    return $data;
}

# If the cfg file contains unicode characters, use this method to read from it
# Used by HFileHierarchy classifier, since an HFile is read as a cfg file, but 
# can contain unicode characters.
sub read_cfg_file_unicode {
    my ($filename, $stringexp, $arrayexp, $hashexp, $arrayarrayexp,
    $hashhashexp) = @_;
    my ($line);
    my $data = {};

    if (open (COLCFG, $filename)) {
    binmode(COLCFG,":utf8");
    while (defined ($line = &read_cfg_line('COLCFG'))) {
        if (scalar(@$line) >= 2) {

        #map { decode("utf8",$_) } @$line; #use Encode;

        my $key = shift (@$line);
        if (defined $stringexp && $key =~ /$stringexp/) {
            $data->{$key} = shift (@$line);

        } elsif (defined $arrayexp && $key =~ /$arrayexp/) {
            push (@{$data->{$key}}, @$line);

        } elsif (defined $hashexp && $key =~ /$hashexp/) {
            my $k = shift @$line;
            my $v = shift @$line;
            $data->{$key}->{$k} = $v;
        } elsif (defined $arrayarrayexp && $key =~ /$arrayarrayexp/) {
            if (!defined $data->{$key}) {
            $data->{$key} = [];
            }
            push (@{$data->{$key}}, $line);
        }
        elsif (defined $hashhashexp && $key =~ /$hashhashexp/) {
            my $k = shift @$line;
            my $p = shift @$line;
            my $v = shift @$line;
            if (!defined $v) {
            $v = $p;
            $p = 'default';
            }
            $data->{$key}->{$k}->{$p} = $v;
        }
        }
    }
    close (COLCFG);

    } else {
    print STDERR "cfgread::read_cfg_file_unicode couldn't read the cfg file $filename\n";
    }

    return $data;
}


# stringexp, arrayexp, hashexp and arrayarrayexp 
# should be something like '^(this|that)$'
sub write_cfg_file {
    my ($filename, $data, $stringexp, $arrayexp, $hashexp, $arrayarrayexp,
    $hashhashexp) = @_;

    if (open (COLCFG, ">$filename")) {
    foreach my $key (sort(keys(%$data))) {
        if ($key =~ /$stringexp/) {
        &write_cfg_line ('COLCFG', [$key, $data->{$key}]);
        } elsif ($key =~ /$arrayexp/) {
        &write_cfg_line ('COLCFG', [$key, @{$data->{$key}}]);
        } elsif (defined $hashexp && $key =~ /$hashexp/) {
        foreach my $k (keys (%{$data->{$key}})) {
            &write_cfg_line ('COLCFG', [$key, $k, $data->{$key}->{$k}]);
        }
        } elsif (defined $arrayarrayexp && $key =~ /$arrayarrayexp/) {
        foreach my $k (@{$data->{$key}}) {
            &write_cfg_line ('COLCFG', [$key, @$k]);
        }
        } elsif (defined $hashhashexp && $key =~ /$hashhashexp/) {
        foreach my $k (keys (%{$data->{$key}})) {
            foreach my $p (keys (%{$data->{$key}->{$k}})) {
            if ($p =~ /default/) {
                &write_cfg_line ('COLCFG', 
                         [$key, $k, $data->{$key}->{$k}]);
            }
            else {
                &write_cfg_line ('COLCFG', 
                   [$key, $k, $p, $data->{$key}->{$k}->{$p}]);
            }
            }
        }
        }
    }
    close (COLCFG);
    } else {
    print STDERR "cfgread::write_cfg_file couldn't write the cfg file $filename\n";
    }
}


1;