package LCFG::Resources; # -*-perl-*-
use strict;

#######################################################################
#
# This package contains common routines for LCFG Resources
#
# Stephen Quinney <squinney@inf.ed.ac.uk>
# Version 1.13.4 : 31/01/19 16:10:55
#
# $Id: Resources.pm.cin 31039 2016-08-10 09:24:41Z squinney@INF.ED.AC.UK $
# $Source: /var/cvs/dice/LCFG-Utils-Perl/lib/LCFG/Resources.pm.cin,v $
# $Revision: 31039 $
# $HeadURL: https://svn.lcfg.org/svn/source/tags/LCFG-Utils-Perl/LCFG_Utils_Perl_1_13_4/lib/LCFG/Resources.pm.cin $
# $Date: 2016-08-10 10:24:41 +0100 (Wed, 10 Aug 2016) $
#
#######################################################################

use v5.10;

use LCFG::DB_File;
use Data::Dumper;
use HTML::Entities ();

#######################################################################
# Constants
#######################################################################

our $VERSION  = '1.13.4';
my $date      = '31/01/19 16:10:55';
my $dbext     = $LCFG::DB::dbext;
my $vpfx      = "LCFG_%s_";
my $tpfx      = "LCFGTYPE_%s_";
my $lpfx      = "_RESOURCES";

#######################################################################
sub DBMDir {
#######################################################################
    my ($newdir) = @_;

    state $dbmdir = '/var/lcfg/conf/profile/dbm';

    if (defined $newdir ) {
        $dbmdir = $newdir;
    }

    return $dbmdir;
}

#######################################################################
sub DBMFile ($) {
#######################################################################
  
  my $fqdn = shift;
  my $dbmdir = DBMDir();
  return "$dbmdir/$fqdn.$dbext";
}

#######################################################################
sub Load ($;@) {
#######################################################################

# Take a list of component or resource names
# Find resource values from adaptor DBM file
# Return a hash containing one element for each unique component
# Each element is a hash of key/record pairs
# Set $@ and return undef on error
  
  my $host = shift;
  my @speclist = @_;

  my $dbm = {};
  my $result = {};
  my $errmsg = undef;  

  my $dbmfile = DBMFile($host);
  unless ( LCFG::DB::TieReadOnly( $dbmfile, $dbm ) ) { 
   $@ = "can't tie $dbmfile: \l$!"; return undef;
  }
    
  foreach my $spec (grep !/=/, @speclist) {
    
    my $comp = $spec; $comp =~ s/\..*//;
    next if (defined($result->{$comp}));

    unless (exists($dbm->{$comp})) {
      LCFG::DB::UnTie($dbm);
      $errmsg .= "no such component: $comp\n";
      next;
    }

    # The key is just the short hostname without any domain name
    my ($key) = split /\./, $host, 2;

    my $res = {}; foreach my $k (split /\s+/,$dbm->{$comp}) {
      my $rkey = join q{.}, $key, $comp, $k;
      $res->{$k}= {
		   VALUE   => $dbm->{$rkey},
		   TYPE    => $dbm->{"%$rkey"},
		   DERIVE  => $dbm->{"#$rkey"},
		   CONTEXT => $dbm->{"=$rkey"},
		  };
    }

    $result->{$comp} = $res;
  }
  
  LCFG::DB::UnTie($dbm);

  $errmsg =~ s/\n$//, $@ = $errmsg if (defined($errmsg));
  return defined($errmsg) ? undef : $result;
}

#######################################################################
sub Import (@) {
#######################################################################

# Take a list of component or resource names
# Find resource values from environment (as created by Export())
# Return a hash containing one element for each unique component
# Each element is a hash of key/record pairs
# Set $@ and return undef on error
  
  my @speclist = @_;

  my $dbm = {};
  my $result = {};
  my $errmsg = undef;
  
  foreach my $spec (grep !/=/, @speclist) {
    my $comp = $spec; $comp =~ s/\..*//;
    next if (defined($result->{$comp}));

    my $listvar = sprintf "$vpfx$lpfx", $comp;
    unless (defined($ENV{$listvar})) {
      $errmsg .= "no such component in environment: $comp\n";
      next;
    }
    
    my $res = {}; foreach my $k (split /\s+/,$ENV{$listvar}) {
      my $resvar = sprintf "$vpfx$k", $comp;
      my $typvar = sprintf "$tpfx$k", $comp;
      $res->{$k}= {
		   VALUE   => $ENV{$resvar},
		   TYPE    => $ENV{$typvar},
		  };
    }

    $result->{$comp} = $res;
  }

  $errmsg =~ s/\n$//, $@ = $errmsg if (defined($errmsg));
  return defined($errmsg) ? undef : $result;
}

#######################################################################
sub ReadFile ($@) {
#######################################################################

# Load list of resources from named file
# Return hash of named values
# Set $@ and return undef on error
  
  my $fname = shift;
  my @speclist = shift;

  my $errmsg = undef;  
  my $res = {};
  
  unless (open(RFP,"<$fname")) {
    $@ = "can't open $fname: \l$!"; return undef;
  }
  
  while (<RFP>) {
    chomp;
    if (/^\s*([^\.]+).([^=]+)\s*=\s*(.*)$/) {
      my ($comp,$k,$v,$type) = ($1,$2,$3,'VALUE'); $v=~s/\s+$//;
      if ($comp =~ /^\#(.*)$/) { $comp=$1; $type='DERIVE'}
      elsif ($comp =~ /^\=(.*)$/) { $comp=$1; $type='CONTEXT'}
      elsif ($comp =~ /^\%(.*)$/) { $comp=$1; $type='TYPE'}

      if ( $type eq 'VALUE' ) {
          HTML::Entities::decode_entities($v);
      }

      $res->{$comp} = {} unless defined($res->{$comp});
      $res->{$comp}->{$k} = {} unless defined($res->{$comp}->{$k});
      $res->{$comp}->{$k}->{$type} = $v;
    }
  }

  close(RFP);

  my $result = {}; foreach my $spec (grep !/=/, @speclist) {
    my ($comp,$k) = ($spec,undef);
    if ($comp =~ /^([^\.]+)\.(.+)$/) { ($comp,$k) = ($1,$2); }
    my $r = $res->{$comp};
    unless (defined($r)) {
      $errmsg .= "no such component in file: $comp\n";
      next;
    }
    my @klist = ($k) ? ($k) : keys(%$r);
    foreach $k (@klist) {
      if (!defined($r->{$k})) {
	$errmsg .= "no such resource in file: $comp.$k\n";
	next;
      }
      $result->{$comp} = {} unless (defined($result->{$comp}));
      $result->{$comp}->{$k} = $r->{$k};
    }
  }

  $errmsg =~ s/\n$//, $@ = $errmsg if (defined($errmsg));
  return defined($errmsg) ? undef : $result;
}

#######################################################################
sub WriteFile ($$@) {
#######################################################################

# Save resources to named file
# Set $@ and return undef on error
  
  my $fname = shift;
  my $hash = shift;
  my @speclist = shift;
  
  unless (open(RFP,">$fname")) {
    $@ = "can't open $fname: \l$!"; return undef;
  }

  my $result = Output($hash,'write',\*RFP,@speclist);

  close(RFP);

  return $result;
}

#######################################################################
sub Merge (@) {
#######################################################################

# Merge resource sets
  
  my @rlist = @_;
  
  my $res = {}; foreach my $r (@rlist) {
    foreach my $comp (keys(%$r)) {
      $res->{$comp} = {} unless defined($res->{$comp});
      foreach my $k (keys(%{$r->{$comp}})) {
	$res->{$comp}->{$k} = {} unless (defined($res->{$comp}->{$k}));
	my ($br,$ar) = ($res->{$comp}->{$k},$r->{$comp}->{$k});
	$br->{VALUE} = $ar->{VALUE};
	$br->{DERIVE} = $ar->{DERIVE};
	$br->{CONTEXT} = $ar->{CONTEXT};
	$br->{TYPE} = $ar->{TYPE} if (defined($ar->{TYPE}));
      }
    }
  }
  return $res;
}

#######################################################################
sub Dump($;@) {
#######################################################################

# Take a hash of component resources as returned by "Load" and
# an (optional) list of component or resource names.
# Print values and (optionally) attributes
# Return 'ok' or undef on error (and set $@ to error message)
  
  my $hash = shift;
  my $verbose = shift;
  my $all = shift;
  my @speclist = @_;
  
  @speclist = keys(%$hash) unless (defined($speclist[0]));
  my $keytab = {};
  my $errmsg = undef;
  my $compk = scalar(keys(%$hash));
  
  foreach my $spec (grep !/=/, @speclist) {
    
    my ($comp,$key) = ($spec,undef);
    ($comp,$key) = ($1,$2) if ($spec =~ /^([^\.]+)\.(.*)$/);
    my $res = $hash->{$comp};
    $keytab->{$comp} = {} unless (defined($keytab->{$comp}));
				  
    if (!defined($res)) {
      $errmsg .= "no such component: $comp\n";
      next;
    }

    my @keys = defined($key) ? $key : keys(%$res);
    
    foreach my $i (sort @keys) { 
      
      my $r = $res->{$i};
      if (!defined($r)) {
	$errmsg .= "no such resource: $comp.$i\n";
	next;
      }
      $keytab->{$comp}->{$i}=1;
      my $v = $r->{VALUE};
      next if (($v eq '') && !$all);
      if ($verbose) {
	print "$comp.$i:\n";
	printf "   value=%s\n", $v;
	printf "    type=%s\n",
	  defined($r->{TYPE}) ? $r->{TYPE} : 'default';
	printf "  derive=%s\n",
	  defined($r->{DERIVE}) ? $r->{DERIVE} : 'default'
	    if (exists($r->{DERIVE}));
	printf " context=%s\n",
	  defined($r->{CONTEXT}) ? $r->{CONTEXT} : 'default'
	    if (exists($r->{CONTEXT}));
      } else {
	print (($compk>1) ? "$comp.$i=$v\n" : "$i=$v\n");
      }
    }
  }
  
  $errmsg =~ s/\n$//, $@ = $errmsg if (defined($errmsg));
  return defined($errmsg) ? undef : 'ok';
}

#######################################################################
sub Output($$$;@) {
#######################################################################

# Take a hash of component resources as returned by "Load" and
# an (optional) list of component or resource names.
# Print shell assignment statements, or simple resource
# assignmants, depending on $mode.
# Return 'ok' or undef on error (and set $@ to error message)
  
  my $hash = shift;
  my $mode = shift;
  my $fp = shift;
  my @speclist = @_;
  
  @speclist = keys(%$hash) unless (defined($speclist[0]));
  my $keytab = {};
  my $errmsg = undef;
  
  foreach my $spec (grep !/=/, @speclist) {
    
    my ($comp,$key) = ($spec,undef);
    ($comp,$key) = ($1,$2) if ($spec =~ /^([^\.]+)\.(.*)$/);
    my $res = $hash->{$comp};
    $keytab->{$comp} = {} unless (defined($keytab->{$comp}));
				  
    if (!defined($res)) {
      $errmsg .= "no such component: $comp\n";
      next;
    }

    my @keys = defined($key) ? $key : keys(%$res);
    
    foreach my $i (@keys) { 
      
      my $r = $res->{$i};
      if (!defined($r)) {
	$errmsg .= "no such resource: $comp.$i\n";
	next;
      }
      $keytab->{$comp}->{$i}=1;
      my $v = $r->{VALUE};
      my $t = $r->{TYPE};
      my $resvar = sprintf "$vpfx$i", $comp;
      my $typvar = sprintf "$tpfx$i", $comp;
      if ($mode eq 'export') {
	$v =~ s/\'/\'\"\'\"\'/g;
	print $fp "export $resvar='$v'\n";
        if ( defined $t ) {
            $t =~ s/\'/\'\"\'\"\'/g;
            print $fp "export $typvar='$t'\n";
        }
      } else {
	my $c = $r->{CONTEXT};
	my $d = $r->{DERIVE};

        # Encode the value, might have newlines or other troublesome
        # characters.

        HTML::Entities::encode_entities_numeric(
            $v, q{^\x20-\x25\x27-\x7e} );

	print $fp "$comp.$i=$v\n";
	print $fp "%$comp.$i=$t\n" if (defined($t));
	print $fp "=$comp.$i=$c\n" if (defined($c));
	print $fp "#$comp.$i=$d\n" if (defined($d));
	print $fp "^$comp.$i=$a\n" if (defined($a));
      }
    }
  }

  foreach my $comp (keys(%$keytab)) {
    my $klist = $keytab->{$comp};
    if ($mode eq 'export') {
      my $listvar = sprintf "$vpfx$lpfx", $comp;
      printf $fp "export $listvar='%s'\n", join(' ',keys(%$klist));
    }
  }
  
  $errmsg =~ s/\n$//, $@ = $errmsg if (defined($errmsg));
  return defined($errmsg) ? undef : 'ok';
}

#######################################################################
sub Export($;@) {
#######################################################################

# Take a hash of component resources as returned by "Load" and
# an (optional) list of component or resource names.
# Print shell assignment statements to export the values into
# the environment.
# Return 'ok' or undef on error (and set $@ to error message)
  
  my $hash = shift;
  my @speclist = @_;
  
  return Output($hash,'export',\*STDOUT,@speclist);
}

#######################################################################
sub Parse ($@) {
#######################################################################

# Parse resource assignments of the form res=value or comp.res=value
# Ignore args not containing an "="
# Use "default" as the default component
# Return hash of named values
# Set $@ and return undef on error
  
  my $default = shift;
  my @args = @_;

  my $res = {}; 
  my $errmsg = undef;

  foreach my $a (@args) {
    if ($a=~/^\s*([A-Za-z_][A-Za-z0-9_]*)\.([A-Za-z0-9_]+)\s*=((.|\n)*)$/){
      $res->{$1} = {} unless (defined($res->{$1}));
      $res->{$1}->{$2} = { VALUE=>$3, DERIVE=>"assignment" };
    } elsif ($a =~ /^\s*([A-Za-z0-9_]+)\s*=((.|\n)*)$/) {
      if (defined($default)) {
	$res->{$default} = {} unless (defined($res->{$default}));
	$res->{$default}->{$1} = { VALUE=>$2, DERIVE=>"assignment" };
      } else {
	$errmsg .= "ambiguous component for resource: $1\n";
      }
    }
  }

  $errmsg =~ s/\n$//, $@ = $errmsg if (defined($errmsg));
  return defined($errmsg) ? undef : $res;
}

#######################################################################
sub SetPrefix ($;$) {
#######################################################################

  my $v = shift;
  my $t = shift;

  $vpfx = $v;
  $tpfx = $t if (defined($t));
}

1;

__END__

=head1 NAME

LCFG::Resources - load and save LCFG resources

=head1 SYNOPSYS

use LCFG::Resources;

  # Load resources for named resources from adaptor profile
  # Note that the nodename must be fully-qualified not the short name

  $res = LCFG::Resources::Load($nodename,$rspec1,$rspec2,...);

  # Dump resources for named resources to stdout
  LCFG::Resources::Dump($res,$verbose,$all,$rspec1,$rspec2,...);

  # Dump named resources as shell assigments
  LCFG::Resources::Export($res,$rspec1,$rspec2,...);

  # Load resource for named resources from environment
  $res = LCFG::Resources::Import($rspec1,$rspec2,...);

  # Write named resources to file
  LCFG::Resources::WriteFile($file,$res,$rspec1,$rspec2,...);

  # Read named resources from file
  $res = LCFG::Resources::ReadFile($file,$rspec1,$rspec2,...);

  # Parse resource values from arguments
  $res = LCFG::Resources::Parse($default,"res1=val1","res2=val2",...);

  # Merge resource structures
  $res = LCFG::Resources::Merge($res1,$res2,...);

  # Set prefixes to be used for environment variables
  LCFG::Resources::SetPrefix($value_prefix,$type_prefix);

=head1 DESCRIPTION

In the above, I<rspec> has the form I<component>.I<resource> or simply
I<component> which refers to all resources in the specified component.

The B<Parse> routine accepts qualified, or unqualified resource names.
The I<default> component is assumed for unqualified resource names.

B<SetPrefix> defines the prefixes attached to resource names when
the values and types are exported or imported from the environment. 
B<%s> in the prefix strings is replaced by the name of the corresponding
component. The defaults are C<LCFG_%S_> and C<LCFGTYPE_%s_>.

The I<res> structures have the following form:

  {
    'foo' => {
               'resource1' => {
                                VALUE => value,
                                TYPE => type,
                                DERIVE = > derivation,
                                CONTEXT => context
                              },
               'resource2' => {
                                VALUE => value,
                                TYPE => type,
                                DERIVE = > derivation,
                                CONTEXT => context
                              },
               ......
             }

    'bar' => {
               'resource1' => {
                                VALUE => value,
                                TYPE => type,
                                DERIVE = > derivation,
                                CONTEXT => context
                              },
               'resource2' => {
                                VALUE => value,
                                TYPE => type,
                                DERIVE = > derivation,
                                CONTEXT => context
                              },
               ......
             }
    .......
 }

All routines return C<undef> and set the variable C<$@> on error.

=head1 PLATFORMS

ScientificLinux6, EnterpriseLinux7, Debian

=head1 AUTHOR

Stephen Quinney <squinney@inf.ed.ac.uk>

=cut
