# file KLEIDER/web/src/kalender/Readargs.pm
# Liest die (Befehlszeilen-)Argumente
# 2016-06-16 Herbert Schiemann <h.schiemann@herbaer.de>
# GPL Version 2 oder neuer

# 2020-04-18 print_message_with_values: bessere Ausgabe von ARRAY-Werten

package Herbaer::Readargs;

BEGIN {
   use File::Spec::Functions qw (file_name_is_absolute catfile);
   use Exporter;
   our $VERSION    = 20160617;
   our @ISA        = qw (Exporter);
   our @EXPORT     = qw (read_args print_message_with_values);
   our @EXPORT_OK  = qw (read_args print_message_with_values read_data_file);
}

my $verb; 
use utf8;
binmode (STDERR, "raw:encoding(utf8)");

# verarbeitet die Argumente
# Die gültigen Options-Namen sind in $args voreingestellt
# read_args ($args);
sub read_args {
   my ($args, $argv) = @_;
   ref ($args) eq "HASH"  or return;
   ref ($argv) eq "ARRAY" or $argv = \@ARGV;
   my $a;                  # ein einzelnes Argument in der Schleife
   my $oname;              # Name einer Option 
   my $okey;               # Schlüssel des Hash-Eintrags zur letzten Option
   my $ok;                 # Test-Schlüssel
   my $kfound;             # neuer Schlüssel gefunden?
   my $otypes = [          # möglicher Typen von Optionen
      "",                  # einfacher Wert (Zeichenkette)
      "[cnt]",             # logischer Wert (durch --no_XXX zurückgesetzt)
      "[sr]",              # Unterprogramm-Referenz, Parameter $args, $argv
      "[rc]",              # Name oder Pfad einer Einstellungsdatei
   ];
   my $ot;                 # Options-Typ (s. $otypes)
   my $ott;                # Options-Typ in Schleife
   my $expect_val = 0;     # erwarte einen Wert
   my $rd_posargs = 0;     # lese Positions-Argumente $args -> {'_argv'}
   my $car;                # aktuelle Liste ("current array")
   for $a (@$argv) {
      if ($rd_posargs) { push (@$car, $a); next; }
      if ( !$expect_val && $a =~ /^--([a-zA-Z0-9_]*)/ ) {
         $oname = $1;
         if ($oname eq '') {
            ref ($car = $args -> {'_argv'}) eq "ARRAY"
                or $args -> {'_argv'} = $car = []
                ;
            $rd_posargs = 1;
            next;
         }
         $kfound = 0;
         for $ott (@$otypes) {
            $ok = "$ott$oname";
            if (exists $args -> {$ok}) {
               $ot   = $ott;
               $okey = $ok;
               ++ $kfound;
               ++ $args -> {$ok} if $ott eq '[cnt]';
            }
            if ( $ott eq '[cnt]' && $oname =~ /^no_(.+)/ ){
               $ok = "$ott$1";
               if (exists $args -> {$ok}) {$ot = $ott; ++ $kfound; $args -> {$ok} = 0; }
            }
            last if $kfound;
         }
         if ($kfound) {
            $car = undef;
            if    ($ot eq '[cnt]') {}
            elsif ($ot eq '[sr]')  { $args -> {$okey} -> ($args, $argv); }
            else {
               ++ $expect_val;
               ref ($car = $args -> {$okey}) eq "ARRAY" or $car = undef;
            }
            next;
         }
         elsif (!$car) {
            print STDERR "Ungültige Option $a\n" if $args -> {"[cnt]verbose"};
            exit 1;
         }
      }
      if ($car) { push (@$car, $a); }
      elsif ($okey && $expect_val) {
         if ($ot eq "[rc]") {
            read_data_file ($a, $args, $okey);
         }
         else {
            $args -> {$okey} = $a;
         }
      }
      else {
         ref ($car = $args -> {'_argv'}) eq "ARRAY"
             or $args -> {'_argv'} = $car = []
             ;
         push (@$car, $a);
         $rd_posargs = 1;
      }
      $okey = undef;
      $expect_val = 0;
   }
   $args;
} # read_args

sub print_message_with_values {
   my ($msg, $vals) = @_;
   my $replace = sub {
      my ($s, $k) = @_ ;
      my $v = $vals -> {$k};
      $k =~ /^<(.*)>$/    ? "$s\${$1}"                        :
      ! defined ($v)      ? $s                                :
      ref ($v) eq "ARRAY" ? "$s\[" . join (",$s", @$v) . "\]" :
                            "$s(" . $v . ")"                  ;
   }; # replace
   $msg =~ s/(\s*)\$\{(.*?)\}/$replace -> ($1, $2)/ges ;
   print $msg;
} # help

# liest eine Daten-Datei
sub read_data_file {
   my ($file, $args, $k) = @_;
   ref ($args) eq "HASH" or $args = {};
   $verb = $args -> {"[cnt]verbose"};
   my $f; # Dateipfad
   my $d; # Verzeichnis
   my $h; # Dateihandle
   if (file_name_is_absolute ($file)) {
      $f = $file;
   }
   else {
      $file =~ /\.rc$/ or $file .= ".rc";
      for $d (".", "$ENV{HOME}/etc", "/etc") {
         $f = catfile ($d, $file);
         last if -f $f;
      }
   }
   if (!$f) {
      print STDERR "Datei nicht angegeben.\n" if $verb;
      return $args;
   }
   $args -> {$k} = $f if $k;
   if ( !open ($h, "<:encoding(utf-8)", $f)) {
      print STDERR "Kann Datei \"$f\" nicht lesen: $!\n" if $verb;
   }
   else {
      print STDERR "Lese Datei \"$f\"\n" if $verb;
      my $line;
      my $key;
      my $val;
      while ($h && (defined ($line = <$h>))) {
         print STDERR $line if $verb > 2;
         next unless $line =~ s/^\s*([a-zA-Z0-9_.]+)\s*=\s*//;
         $key = $1;
         next unless $line;
         if (exists $args -> {"[cnt]$key"}) {
            $key = "[cnt]$key";
         }
         if (defined ($v = _read_value (\$line, $h))) {
            print STDERR "key/value $key $v\n" if $verb > 2;
            $args -> {$key} = $v;
         }
         $line =~ s/\s+//;
         $line =~ s/#.*//s;
         print STDERR "unerwarteter Zeilenrest $line\n" if $line && $verb;
      }
   }
   $args;
} # read_data_file

sub _read_value {
   my ($lref, $h) = @_;
   my $c;
   print STDERR "_read_value line:\"" . $$lref . "\"\n" if $verb > 2;
   $$lref =~ s/(.)// or return undef;
   $c = $1;
   my $v = undef;
   my $k;
   my $v2;
   if ($c eq "\[") {
      $v = [];
      print STDERR "neues Array\n" if $verb > 2;
      while (1) {
         _skip_comment ($lref, $h);
         next if $$lref =~ s/^,//;
         if ( $$lref =~ s/^]// ) {
            my $n = @$v;
            print STDERR "Array abgeschlossen, $n Elemente\n" if $verb > 2;
            last;
         }
         if (!defined ($v2 = _read_value ($lref, $h))) {
            print STDERR "fehlender Wert\n" if $verb;
            last;
         }
         else {
            print STDERR "Array-Element $v2\n" if $verb > 2;
            push (@$v, $v2);
         }
      }
   }
   elsif ($c eq "\{") {
      $v = {};
      print STDERR "neuer Hash\n" if $verb > 2;
      while (1) {
         _skip_comment ($lref, $h);
         next if $$lref =~ s/^,//;
         if ( $$lref =~ s/^}// ) {
            print STDERR "Hash abgeschlossen\n" if $verb > 2;
            last;
         }
         if (! defined ($k = _read_value ($lref, $h))) {
            print STDERR "Hash-Schlüssel erwartet\n" if $verb > 2;
            last;
         }
         if (ref ($k)) {
            print STDERR
               "Skalarer Wert als Schlüssel erwartet, nicht " . ref ($k) . "\n"
               if $verb > 2;
            last;
         }
         _skip_comment ($lref, $h);
         if (! ($$lref =~ s/=>?//) ) {
            print STDERR "\"=>\" erwartet\n";
            last;
         }       
         _skip_comment ($lref, $h);
         if (! defined ($v2 = _read_value ($lref, $h))) {
            print STDERR "Hash-Wert erwartet\n" if $verb > 2;
            last;
         }
         $v -> {$k} = $v2;
      }  
   }
   elsif ($c eq "\"") {
      $v = "";
      while (1) {
         while ( $$lref =~ s/^([^"]*?)\\(["\\])// ) {
            $v .= $1 . $2;
         }
         if ( $$lref =~ s/^([^"]+)// ) {
            $v .= $1;
         }
         last if $$lref =~ s/^"// ;
         if (!$h || !defined ($$lref = <$h>)) {
            print STDERR "unerwartetes Zeichenketten-Ende: " . $$lref if $verb;
            last;
         }
      }
   }
   else {
      $$lref =~ s/^([^[:space:]{},\[\]=]*)//;
      $v = "$c$1";
   }
   print STDERR "_read_value returns " . (defined $v ? $v : "undef") . "\n" if $verb > 2;
   $v;
} # _read_value

sub _skip_comment {
   my ($lref, $h) = @_;
   while (1) {
      $$lref =~ s/^\s*//;
      $$lref =~ s/^#.*//s;
      last if ($$lref);
      last if !$h || !defined ($$lref = <$h>);
   }
} # _skip_comment

1;
# end of file KLEIDER/web/src/kalender/Readargs.pm