diff options
author | Norbert Preining <norbert@preining.info> | 2019-09-02 13:46:59 +0900 |
---|---|---|
committer | Norbert Preining <norbert@preining.info> | 2019-09-02 13:46:59 +0900 |
commit | e0c6872cf40896c7be36b11dcc744620f10adf1d (patch) | |
tree | 60335e10d2f4354b0674ec22d7b53f0f8abee672 /systems/texlive/tlnet/tlpkg/TeXLive/TLConfFile.pm |
Initial commit
Diffstat (limited to 'systems/texlive/tlnet/tlpkg/TeXLive/TLConfFile.pm')
-rw-r--r-- | systems/texlive/tlnet/tlpkg/TeXLive/TLConfFile.pm | 719 |
1 files changed, 719 insertions, 0 deletions
diff --git a/systems/texlive/tlnet/tlpkg/TeXLive/TLConfFile.pm b/systems/texlive/tlnet/tlpkg/TeXLive/TLConfFile.pm new file mode 100644 index 0000000000..4a2a125f44 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/TeXLive/TLConfFile.pm @@ -0,0 +1,719 @@ +# $Id: TLConfFile.pm 44447 2017-06-04 02:03:31Z preining $ +# TeXLive::TLConfFile.pm - reading and writing conf files +# Copyright 2010-2017 Norbert Preining +# This file is licensed under the GNU General Public License version 2 +# or any later version. + +package TeXLive::TLConfFile; + +use TeXLive::TLUtils; + +my $svnrev = '$Revision: 44447 $'; +my $_modulerevision; +if ($svnrev =~ m/: ([0-9]+) /) { + $_modulerevision = $1; +} else { + $_modulerevision = "unknown"; +} +sub module_revision { + return $_modulerevision; +} + +sub new +{ + my $class = shift; + my ($fn, $cc, $sep, $typ) = @_; + my $self = {} ; + $self{'file'} = $fn; + $self{'cc'} = $cc; + $self{'sep'} = $sep; + if (defined($typ)) { + if ($typ eq 'last-win' || $typ eq 'first-win' || $typ eq 'multiple') { + $self{'type'} = $typ; + } else { + printf STDERR "Unknown type of conffile: $typ\n"; + printf STDERR "Should be one of: last-win first-win multiple\n"; + return; + } + } else { + # default type for backward compatibility is last-win + $self{'type'} = 'last-win'; + } + bless $self, $class; + return $self->reparse; +} + +sub reparse +{ + my $self = shift; + my %config = parse_config_file($self->file, $self->cc, $self->sep); + my $lastkey = undef; + my $lastkeyline = undef; + $self{'keyvalue'} = (); + $self{'confdata'} = \%config; + $self{'changed'} = 0; + my $in_postcomment = 0; + for my $i (0..$config{'lines'}) { + if ($config{$i}{'type'} eq 'comment') { + $lastkey = undef; + $lastkeyline = undef; + $is_postcomment = 0; + } elsif ($config{$i}{'type'} eq 'data') { + $lastkey = $config{$i}{'key'}; + $lastkeyline = $i; + $self{'keyvalue'}{$lastkey}{$i}{'value'} = $config{$i}{'value'}; + $self{'keyvalue'}{$lastkey}{$i}{'status'} = 'unchanged'; + if (defined($config{$i}{'postcomment'})) { + $in_postcomment = 1; + } else { + $in_postcomment = 0; + } + } elsif ($config{$i}{'type'} eq 'empty') { + $lastkey = undef; + $lastkeyline = undef; + $is_postcomment = 0; + } elsif ($config{$i}{'type'} eq 'continuation') { + if (defined($lastkey)) { + if (!$in_postcomment) { + $self{'keyvalue'}{$lastkey}{$lastkeyline}{'value'} .= + $config{$i}{'value'}; + } + } + # otherwise we are in a continuation of a comment!!! so nothing to do + } else { + print "-- UNKNOWN TYPE\n"; + } + } + return $self; +} + +sub file +{ + my $self = shift; + return($self{'file'}); +} +sub cc +{ + my $self = shift; + return($self{'cc'}); +} +sub sep +{ + my $self = shift; + return($self{'sep'}); +} +sub type +{ + my $self = shift; + return($self{'type'}); +} + +sub key_present +{ + my ($self, $key) = @_; + return defined($self{'keyvalue'}{$key}); +} + +sub keys +{ + my $self = shift; + return keys(%{$self{'keyvalue'}}); +} + +sub keyvaluehash +{ + my $self = shift; + return \%{$self{'keyvalue'}}; +} +sub confdatahash +{ + my $self = shift; + return $self{'confdata'}; +} + +sub by_lnr +{ + # order of lines + # first all the line numbers >= 0, + # then the negative line numbers in reverse order + # (negative line numbers refer to new entries in the conffile) + # example: + # line number in order: 0 3 6 7 9 -1 -2 -3 + return ($a >= 0 && $b >= 0 ? $a <=> $b : $b <=> $a); +} + +sub value +{ + my ($self, $key, $value, @restvals) = @_; + my $t = $self->type; + if (defined($value)) { + if (defined($self{'keyvalue'}{$key})) { + my @key_lines = sort by_lnr CORE::keys %{$self{'keyvalue'}{$key}}; + if ($t eq 'multiple') { + my @newval = ( $value, @restvals ); + my $newlen = $#newval; + # in case of assigning to a multiple value stuff, + # we assign to the first n elements, delete superficial + # or add new ones if necessary + # $value should be a reference to an array of values + my $listp = $self{'keyvalue'}{$key}; + my $oldlen = $#key_lines; + my $minlen = ($newlen < $oldlen ? $newlen : $oldlen); + for my $i (0..$minlen) { + if ($listp->{$key_lines[$i]}{'value'} ne $newval[$i]) { + $listp->{$key_lines[$i]}{'value'} = $newval[$i]; + if ($listp->{$key_lines[$i]}{'status'} ne 'new') { + $listp->{$key_lines[$i]}{'status'} = 'changed'; + } + $self{'changed'} = 1; + } + } + if ($minlen < $oldlen) { + # we are assigning less values to more lines, so we have to + # remove the remaining ones + for my $i (($minlen+1)..$oldlen) { + $listp->{$key_lines[$i]}{'status'} = 'deleted'; + } + $self{'changed'} = 1; + } + if ($minlen < $newlen) { + # we have new values + my $ll = $key_lines[$#key_lines]; + # if we are adding the first new entry, set line to -1, + # otherwise decrease the line number (already negative + # for new lines) + $ll = ($ll >= 0 ? -1 : $ll-1); + for my $i (($minlen+1)..$newlen) { + $listp->{$ll}{'status'} = 'new'; + $listp->{$ll}{'value'} = $newval[$i]; + $ll--; + } + $self{'changed'} = 1; + } + } else { + # select element based on first-win or last-win type + my $ll = $key_lines[($t eq 'first-win' ? 0 : $#key_lines)]; + #print "lastwin = $ll\n"; + if ($self{'keyvalue'}{$key}{$ll}{'value'} ne $value) { + $self{'keyvalue'}{$key}{$ll}{'value'} = $value; + # as long as the key/value pair is not new, + # we set its status to changed + if ($self{'keyvalue'}{$key}{$ll}{'status'} ne 'new') { + $self{'keyvalue'}{$key}{$ll}{'status'} = 'changed'; + } + $self{'changed'} = 1; + } + } + } else { # all new key + my @newval = ( $value, @restvals ); + my $newlen = $#newval; + for my $i (0..$newlen) { + $self{'keyvalue'}{$key}{-($i+1)}{'value'} = $value; + $self{'keyvalue'}{$key}{-($i+1)}{'status'} = 'new'; + } + $self{'changed'} = 1; + } + } + # $self->dump_myself(); + if (defined($self{'keyvalue'}{$key})) { + my @key_lines = sort by_lnr CORE::keys %{$self{'keyvalue'}{$key}}; + if ($t eq 'first-win') { + return $self{'keyvalue'}{$key}{$key_lines[0]}{'value'}; + } elsif ($t eq 'last-win') { + return $self{'keyvalue'}{$key}{$key_lines[$#key_lines]}{'value'}; + } elsif ($t eq 'multiple') { + return map { $self{'keyvalue'}{$key}{$_}{'value'} } @key_lines; + } else { + die "That should not happen: wrong type: $!"; + } + } + return; +} + +sub delete_key +{ + my ($self, $key) = @_; + %config = %{$self{'confdata'}}; + if (defined($self{'keyvalue'}{$key})) { + for my $l (CORE::keys %{$self{'keyvalue'}{$key}}) { + $self{'keyvalue'}{$key}{$l}{'status'} = 'deleted'; + } + $self{'changed'} = 1; + } +} + +sub rename_key +{ + my ($self, $oldkey, $newkey) = @_; + %config = %{$self{'confdata'}}; + for my $i (0..$config{'lines'}) { + if (($config{$i}{'type'} eq 'data') && + ($config{$i}{'key'} eq $oldkey)) { + $config{$i}{'key'} = $newkey; + $self{'changed'} = 1; + } + } + if (defined($self{'keyvalue'}{$oldkey})) { + $self{'keyvalue'}{$newkey} = $self{'keyvalue'}{$oldkey}; + delete $self{'keyvalue'}{$oldkey}; + $self{'keyvalue'}{$newkey}{'status'} = 'changed'; + $self{'changed'} = 1; + } +} + +sub is_changed +{ + my $self = shift; + return $self{'changed'}; +} + +sub save +{ + my $self = shift; + my $outarg = shift; + my $closeit = 0; + # unless $outarg is defined or we are changed, return immediately + return if (! ( defined($outarg) || $self->is_changed)); + # + %config = %{$self{'confdata'}}; + # + # determine where to write to + my $out = $outarg; + my $fhout; + if (!defined($out)) { + $out = $config{'file'}; + my $dn = TeXLive::TLUtils::dirname($out); + TeXLive::TLUtils::mkdirhier($dn); + if (!open(CFG, ">$out")) { + tlwarn("Cannot write to $out: $!\n"); + return 0; + } + $closeit = 1; + $fhout = \*CFG; + } else { + # check what we got there for $out + if (ref($out) eq 'SCALAR') { + # that is a file name + my $dn = TeXLive::TLUtils::dirname($out); + TeXLive::TLUtils::mkdirhier($dn); + if (!open(CFG, ">$out")) { + tlwarn("Cannot write to $out: $!\n"); + return 0; + } + $fhout = \*CFG; + $closeit = 1; + } elsif (ref($out) eq 'GLOB') { + # that hopefully is a fh + $fhout = $out; + } else { + tlwarn("Unknown out argument $out\n"); + return 0; + } + } + + # + # first we write the config file as close as possible to orginal layout, + # and after that we add new key/value pairs + my $current_key_value_is_changed = 0; + for my $i (0..$config{'lines'}) { + if ($config{$i}{'type'} eq 'comment') { + print $fhout "$config{$i}{'value'}"; + print $fhout ($config{$i}{'multiline'} ? "\\\n" : "\n"); + } elsif ($config{$i}{'type'} eq 'empty') { + print $fhout ($config{$i}{'multiline'} ? "\\\n" : "\n"); + } elsif ($config{$i}{'type'} eq 'data') { + $current_key_value_is_changed = 0; + # we have to check whether the original data has been changed!! + if ($self{'keyvalue'}{$config{$i}{'key'}}{$i}{'status'} eq 'changed') { + $current_key_value_is_changed = 1; + print $fhout "$config{$i}{'key'} $config{'sep'} $self{'keyvalue'}{$config{$i}{'key'}}{$i}{'value'}"; + if (defined($config{$i}{'postcomment'})) { + print $fhout $config{$i}{'postcomment'}; + } + # if a value is changed, we do not print out multiline stuff + # as keys are not split + print $fhout "\n"; + } elsif ($self{'keyvalue'}{$config{$i}{'key'}}{$i}{'status'} eq 'deleted') { + $current_key_value_is_changed = 1; + } else { + $current_key_value_is_changed = 0; + # the original already contains the final \, so only print new line + print $fhout "$config{$i}{'original'}\n"; + } + } elsif ($config{$i}{'type'} eq 'continuation') { + if ($current_key_value_is_changed) { + # ignore continuation lines if values are changed + } else { + print $fhout "$config{$i}{'value'}"; + print $fhout ($config{$i}{'multiline'} ? "\\\n" : "\n"); + } + } + } + # + # save new keys + for my $k (CORE::keys %{$self{'keyvalue'}}) { + for my $l (CORE::keys %{$self{'keyvalue'}{$k}}) { + if ($self{'keyvalue'}{$k}{$l}{'status'} eq 'new') { + print $fhout "$k $config{'sep'} $self{'keyvalue'}{$k}{$l}{'value'}\n"; + } + } + } + close $fhout if $closeit; + # + # reparse myself + if (!defined($outarg)) { + $self->reparse; + } +} + + + + +# +# parse/write config file +# these functions allow reading and writing of config files +# that consists of comments (comment char/string is the second argument) +# and pairs +# \s* key \s* SEP \s* value \s* +# where SEP is the third argument, +# and key does not contain neither white space nor SEP +# and value can be arbitry +# +# continuation lines are allowed +# Furthermore, at least the separator has to be on the same line as the key!! +# Continuations followed by comment lines are invalid! +# +sub parse_config_file { + my ($file, $cc, $sep) = @_; + my @data; + if (!open(CFG, "<$file")) { + @data = (); + } else { + @data = <CFG>; + chomp(@data); + close(CFG); + } + + my %config = (); + $config{'file'} = $file; + $config{'cc'} = $cc; + $config{'sep'} = $sep; + + my $lines = $#data; + my $cont_running = 0; + for my $l (0..$lines) { + $config{$l}{'original'} = $data[$l]; + if ($cont_running) { + if ($data[$l] =~ m/^(.*)\\$/) { + $config{$l}{'type'} = 'continuation'; + $config{$l}{'multiline'} = 1; + $config{$l}{'value'} = $1; + next; + } else { + # last line of a continuation + # do nothing, we will finish here + $config{$l}{'type'} = 'continuation'; + $config{$l}{'value'} = $data[$l]; + $cont_running = 0; + next; + } + } + # ignore continuation after comments, that is the behaviour the + # kpathsea library is using, so we follow it here + if ($data[$l] =~ m/$cc/) { + $data[$l] =~ s/\\$//; + } + # continuation line + if ($data[$l] =~ m/^(.*)\\$/) { + $cont_running = 1; + $config{$l}{'multiline'} = 1; + # remove the continuation marker so that we can do everything + # as normal below + $data[$l] =~ s/\\$//; + # we will continue below + } + # from now on, if $cont_running == 1, then it means that + # we are in the FIRST line of a multi line setting, so evaluate + # it accordingly to get the key if necessary + + # empty lines are treated as comments + if ($data[$l] =~ m/^\s*$/) { + $config{$l}{'type'} = 'empty'; + next; + } + if ($data[$l] =~ m/^\s*$cc/) { + # save the full line as is into the config hash + $config{$l}{'type'} = 'comment'; + $config{$l}{'value'} = $data[$l]; + next; + } + # mind that the .*? is making the .* NOT greedy, ie matching as few as + # possible. That way we can get rid of the comments at the end of lines + if ($data[$l] =~ m/^\s*([^\s$sep]+)\s*$sep\s*(.*?)(\s*)?($cc.*)?$/) { + $config{$l}{'type'} = 'data'; + $config{$l}{'key'} = $1; + $config{$l}{'value'} = $2; + if (defined($3)) { + my $postcomment = $3; + if (defined($4)) { + $postcomment .= $4; + } + # check that there is actually a comment in the second part of the + # line. Otherwise we might add the continuation lines of that + # line to the value + if ($postcomment =~ m/$cc/) { + $config{$l}{'postcomment'} = $postcomment; + } + } + next; + } + # if we are still here, that means we cannot evaluate the config file + # give a BIG FAT WARNING but save the line as comment and continue + # anyway + warn("WARNING WARNING WARNING\n"); + warn("Cannot parse config file $file ($cc, $sep)\n"); + warn("The following line (l.$l) seems to be wrong:\n"); + warn(">>> $data[$l]\n"); + warn("We will treat this line as a comment!\n"); + $config{$l}{'type'} = 'comment'; + $config{$l}{'value'} = $data[$l]; + } + # save the number of lines in the config hash + $config{'lines'} = $lines; + #print "====DEBUG dumping config ====\n"; + #dump_config_data(\%config); + #print "====DEBUG writing config ====\n"; + #write_config_file(\%config); + #print "=============================\n"; + return %config; +} + +sub dump_myself { + my $self = shift; + print "======== DUMPING SELF =============\n"; + dump_config_data($self{'confdata'}); + print "DUMPING KEY VALUES\n"; + for my $k (CORE::keys %{$self{'keyvalue'}}) { + print "key = $k\n"; + for my $l (sort CORE::keys %{$self{'keyvalue'}{$k}}) { + print " line =$l= value =", $self{'keyvalue'}{$k}{$l}{'value'}, "= status =", $self{'keyvalue'}{$k}{$l}{'status'}, "=\n"; + } + } + print "=========== END DUMP ==============\n"; +} + +sub dump_config_data { + my $foo = shift; + my %config = %{$foo}; + print "config file name: $config{'file'}\n"; + print "config comment char: $config{'cc'}\n"; + print "config separator: $config{'sep'}\n"; + print "config lines: $config{'lines'}\n"; + for my $i (0..$config{'lines'}) { + print "line ", $i+1, ": $config{$i}{'type'}"; + if ($config{$i}{'type'} eq 'comment') { + print "\nCOMMENT = $config{$i}{'value'}\n"; + } elsif ($config{$i}{'type'} eq 'data') { + print "\nKEY = $config{$i}{'key'}\nVALUE = $config{$i}{'value'}\n"; + print "MULTLINE = ", ($config{$i}{'multiline'} ? "1" : "0"), "\n"; + } elsif ($config{$i}{'type'} eq 'empty') { + print "\n"; + # do nothing + } elsif ($config{$i}{'type'} eq 'continuation') { + print "\nVALUE = $config{$i}{'value'}\n"; + print "MULTLINE = ", ($config{$i}{'multiline'} ? "1" : "0"), "\n"; + } else { + print "-- UNKNOWN TYPE\n"; + } + } +} + +sub write_config_file { + my $foo = shift; + my %config = %{$foo}; + for my $i (0..$config{'lines'}) { + if ($config{$i}{'type'} eq 'comment') { + print "$config{$i}{'value'}"; + print ($config{$i}{'multiline'} ? "\\\n" : "\n"); + } elsif ($config{$i}{'type'} eq 'data') { + print "$config{$i}{'key'} $config{'sep'} $config{$i}{'value'}"; + if ($config{$i}{'multiline'}) { + print "\\"; + } + print "\n"; + } elsif ($config{$i}{'type'} eq 'empty') { + print ($config{$i}{'multiline'} ? "\\\n" : "\n"); + } elsif ($config{$i}{'type'} eq 'continuation') { + print "$config{$i}{'value'}"; + print ($config{$i}{'multiline'} ? "\\\n" : "\n"); + } else { + print STDERR "-- UNKNOWN TYPE\n"; + } + } +} + + +1; +__END__ + + +=head1 NAME + +C<TeXLive::TLConfFile> -- TeX Live Config File Access Module + +=head1 SYNOPSIS + + use TeXLive::TLConfFile; + + $conffile = TeXLive::TLConfFile->new($file_name, $comment_char, $separator, $type); + $conffile->file; + $conffile->cc; + $conffile->sep; + $conffile->type + $conffile->key_present($key); + $conffile->keys; + $conffile->value($key [, $value, ...]); + $conffile->is_changed; + $conffile->save; + $conffile->reparse; + +=head1 DESCRIPTION + +This module allows parsing, changing, saving of configuration files +of a general style. It also supports three different paradigma +with respect to multiple occurrences of keys: C<first-win> specifies +a configuration file where the first occurrence of a key specifies +the value, C<last-win> specifies that the last wins, and +C<multiple> that all keys are kept. + +The configuration files (henceforth conffiles) can contain comments +initiated by the $comment_char defined at instantiation time. +Everything after a $comment_char, as well as empty lines, will be ignored. + +The rest should consists of key/value pairs separated by the separator, +defined as well at instantiation time. + +Whitespace around the separator, and before and after key and value +are allowed. + +Comments can be on the same line as key/value pairs and are also preserved +over changes. + +Continuation lines (i.e., lines with last character being a backslash) +are allowed after key/value pairs, but the key and +the separator has to be on the same line. + +Continuations are not possible in comments, so a terminal backslash in +a comment will be ignored, and in fact not written out on save. + +=head2 Methods + +=over 4 + +=item B<< $conffile = TeXLive::TLConfFile->new($file_name, $comment_char, $separator [, $type]) >> + +instantiates a new TLConfFile and returns the object. The file specified +by C<$file_name> does not have to exist, it will be created at save time. + +The C<$comment_char> can actually be any regular expression, but +embedding grouping is a bad idea as it will break parsing. + +The C<$separator> can also be any regular expression. + +The C<$type>, if present, has to be one of C<last-win> (the default), +C<first-win>, or C<multiple>. + +=item B<< $conffile->file >> + +Returns the location of the configuration file. Not changeable (at the moment). + +=item B<< $conffile->cc >> + +Returns the comment character. + +=item B<< $conffile->sep >> + +Returns the separator. + +=item B<< $conffile->type >> + +Returns the type. + +=item B<< $conffile->key_present($key) >> + +Returns true (1) if the given key is present in the config file, otherwise +returns false (0). + +=item B<< $conffile->keys >> + +Returns the list of keys currently set in the config file. + +=item B<< $conffile->value($key [, $value, ...]) >> + +With one argument, returns the current setting of C<$key>, or undefined +if the key is not set. If the configuration file is of C<multiple> +type a list of keys ordered by occurrence in the file is returned. + +With two (or more) arguments changes (or adds) the key/value pair to +the config file and returns the I<new> value. +In case of C<first-win> or C<last-win>, the respective occurrence +of the key is changed, and the others left intact. In this case only +the first C<$value> is used. + +In case of C<multiple> the C<$values> are assigned to the keys in the +order of occurrence in the file. If extra values are present, they +are added. If on the contrary less values then already existing +keys are passed, the remaining keys are deleted. + +=item B<< $conffile->rename_key($oldkey, $newkey) >> + +Renames a key from C<$oldkey> to C<$newkey>. It does not automatically +save the new config file. + +=item B<< $conffile->is_changed >> + +Returns true (1) if some real change has happened in the configuration file, +that is a value has been changed to something different, or a new +setting has been added. + +Note that changing a setting back to the original one will not reset +the changed flag. + +=item B<< $conffile->save >> + +Saves the config file, preserving as much structure and comments of +the original file as possible. + +=item B<< $conffile->reparse >> + +Reparses the configuration file. + + +=back + +=head1 EXAMPLES + +For parsing a C<texmf.cnf> file you can use + + $tmfcnf = TeXLive::TLConfFile->new(".../texmf-dist/web2c", "[#%]", "="); + +since the allowed comment characters for texmf.cnf files are # and %. +After that you can query keys: + + $tmfcnf->value("TEXMFMAIN"); + $tmfcnf->value("trie_size", 900000); + +=head1 AUTHORS AND COPYRIGHT + +This script and its documentation were written for the TeX Live +distribution (L<http://tug.org/texlive>) and both are licensed under the +GNU General Public License Version 2 or later. + +=cut + +### Local Variables: +### perl-indent-level: 2 +### tab-width: 2 +### indent-tabs-mode: nil +### End: +# vim:set tabstop=2 expandtab: # |