package LCFG::Template; # -*-perl-*-

#######################################################################
#
# This package contains template handling routines for LCFG resources
#
# Stephen Quinney <squinney@inf.ed.ac.uk>
# Version 1.13.4 : 31/01/19 16:10:55
#
# $Id: Template.pm.cin 34112 2018-03-12 12:59:50Z squinney@INF.ED.AC.UK $
# $Source: /var/cvs/dice/LCFG-Utils-Perl/lib/LCFG/Template.pm.cin,v $
# $Revision: 34112 $
# $HeadURL: https://svn.lcfg.org/svn/source/tags/LCFG-Utils-Perl/LCFG_Utils_Perl_1_13_4/lib/LCFG/Template.pm.cin $
# $Date: 2018-03-12 12:59:50 +0000 (Mon, 12 Mar 2018) $
#
#######################################################################

use strict;
use warnings;

use v5.10;

use base 'Exporter';

use Digest::SHA ();
use File::Spec ();
use File::Temp ();
use IO::File ();
use Readonly;

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

our $VERSION  = '1.13.4';
my $date      = '31/01/19 16:10:55';

my $left      = '<%';           # Left bracket  
my $right     = '%>';           # Right bracket

my %perlopts  = (   # Perl template options
    ABSOLUTE    => 1,
    INTERPOLATE => 1,
    ANYCASE     => 1,
);

Readonly our $DUMMY    => 1;         # Mode bit - dummy run (don't change file)
Readonly our $NOBACK   => 2;         # Mode bit - don't create backup file
Readonly our $PERLTMPL => 4;         # Mode bit - use Perl templates
Readonly our $LITERAL  => 8;         # Mode bit - literal file, no processing

Readonly our $NOCHANGE => 0;
Readonly our $MODIFIED => 1;

our @EXPORT_OK = qw($DUMMY $NOBACK $PERLTMPL $LITERAL $NOCHANGE $MODIFIED);

Readonly my $DEFAULT_FILE_MODE => oct '0644';

my $DEBUG = 0;

#######################################################################
sub IncludePath {
#######################################################################

    state $include_path;
    if ( @_ > 1 ) {
	$include_path = [@_];
    } elsif ( @_ == 1 ) {
	$include_path = $_[0];
    }

    return $include_path;
}

#######################################################################
sub ReadTemplate {
#######################################################################

# Read template into memory
# Return template data or undef on error

    my ($tmplfile) = @_;

    if ( !defined $tmplfile || length $tmplfile == 0 ) {
        $@ = 'You must specify the template filename.';
        return;
    }

    my $t;
    local $/ = undef;

    if ( $tmplfile eq q{-} ) {
        $t = <STDIN>;
    }
    else {
	my $tmplfile_abs = $tmplfile;

	if ( !File::Spec->file_name_is_absolute($tmplfile) ) {
	    my $incpath = IncludePath();
	    if ( $incpath ) {

		for my $dir ( ref $incpath eq 'ARRAY' ?
			      @{$incpath} : ($incpath) ) {
		    my $newpath = File::Spec->catfile( $dir, $tmplfile );
		    if ( -f $newpath ) {
			$tmplfile_abs = $newpath;
			last;
		    }
		}
	    }
	}

        my $fh = IO::File->new( $tmplfile_abs, 'r' );
        if ( !defined $fh ) {
            $@ = "can't open template file: $tmplfile\n$!";
            return;
        }
        $t = <$fh>;
        $fh->close;
    }

    return $t;
}

#######################################################################
sub SaveFile {
#######################################################################

# Save data to file
# Return 0 or 1 depending on whether the target file has been changed
# Set $@ and return undef on error
# Mode contains bit flags $DUMMY , $NOBACK
  
  my ( $data, $file, $comparefile, $mode ) = @_;

  # Compare the contents to see if anything changed.

  # Normally the comparefile is the same name as the one we are
  # generating. This is something to do with "skip files".

  if ( -e $file ) {
      my $cur_sum = eval {
	  my $fh = IO::File->new( $comparefile, 'r' )
	      or die "Could not read $comparefile: $!\n";
	  local $/ = undef; # slurp
	  my $cur_data = <$fh>;
	  Digest::SHA::sha1_hex($cur_data);
      };

      if ( !$@ && defined $cur_sum ) {
	  my $new_sum = Digest::SHA::sha1_hex($data);

	  if ( $cur_sum eq $new_sum ) {
	      return $NOCHANGE;
	  }
      }
  }

  # Select the new mode
  # If the file exists honour the current mode set, otherwise default to 0644

  my $fmode = $DEFAULT_FILE_MODE;
  if ( -f $file ) {
      $fmode = ( stat $file )[2];
  }

  # Honour the umask which might tighten the mode settings

  my $umask = umask;
  $fmode &= ~$umask;

  # Generate the new file.

  # We want the temporary file to be in the same directory as the
  # target file so that we can do a 'rename' and not worry about
  # filesystem boundaries.

  my $tmpdir = (File::Spec->splitpath($file))[1];

  my $new_file = eval {
    my $tfp = File::Temp->new( TEMPLATE => 'lcfgXXXXXX',
			       DIR      => $tmpdir,
			       UNLINK   => 0 ) # cleanup later
      or die "Could not open temporary file: $!\n";

    my $tempname = $tfp->filename;

    $tfp->print($data)
      or die "Could not write to temporary file: $!\n";
    $tfp->close()
      or die "Could not close temporary file: $!\n";

    chmod $fmode, $tempname
      or die "Could not set mode on temporary file: $!\n";

    # return file name to the caller
    $tempname;
  };

  if ( $@ || !defined $new_file ) {
    $@ = "Failed to update '$file': $@";
    return;
  }

  # In dummy mode remove the generated file.

  if ( $mode&$DUMMY ) {
    if ( !unlink $new_file ) {
      $@ = "can't delete file: $new_file\n$!";
      return;
    }
    return $MODIFIED;
  }

  # Store a backup if the file already exists and NOBACK is not set.

  if ( !($mode&$NOBACK) && -f $file ) {

    my $backup_file = $file . q{~};

    # We use a hard link so that the backup file really is the current
    # file. This avoids the potential for permissions to get messed up
    # when doing a copy.

    eval {
      if ( -f $backup_file ) {
	unlink $backup_file
	  or die "Failed to remove old file: $!\n";
      }
      link $file, $backup_file
	or die "Failed to make hard link: $!\n";
    };

    if ($@) {
      $@ = "Cannot make backup file '$backup_file' for '$file': $@";
      return;
    }

  }

  # Finally replace the old file with the new.

  if ( !rename $new_file, $file ) {
    $@ = "can't rename file: $new_file=>$file\n$!";
    return;
  }

  return $MODIFIED;
}

#######################################################################
sub Lookup {
#######################################################################

# Lookup a variable
# Inputs are:
#  Variable name
#  Token ref (for reporting error line)
#  Filename (for error reporting)
#  Ref to error list
#  List of variable bindings

  my $key = shift;
  my $t = shift;
  my $f = shift;
  my $errs = shift;
  my $tmplvars = shift;
  my @reslist = @_;

  $key =~ s/^\s+//; $key =~ s/\s+$//;
  if ($key !~ /^(#?)([a-zA-Z_0-9]+)$/) {
    push @$errs,("invalid resource name ($key) at $f:".$t->{LINE});
    return undef;
  } my ($type,$k) = ($1,$2);

  foreach my $res ($tmplvars,@reslist) {
    my $val = $res->{$k};
    if ($type eq '#') {
      return $val->{DERIVE} if (defined($val->{DERIVE}));
    } else {
      return $val->{VALUE} if (defined($val->{VALUE}));
    }
  }
  
  return '' if ($type eq '#');
  push @$errs,("undefined resource ($k) at $f:".$t->{LINE});
  return undef;
}

#######################################################################
sub Eval {
#######################################################################

# Evaluate template parse tree in LCFG resource context
#
# Input is:
#  Parse tree as genenerated by Parse
#  Filename (for error messages)
#  Ref to error message list
#  Output flag
#    COPY    = copying everything to output
#    SKIP    = not copying "skipped text"
#  List of variable binding hashes
#
# Output is:
#  Substituted template data

  my $tokens = shift;
  my $f = shift;
  my $errs = shift;
  my $skipping = shift;
  my $tmplvars = shift;
  my @reslist = @_;
  
  my $data = '';
  
  foreach my $t (@$tokens) {

    if ($t->{TOKEN} eq 'TEXT') { $data .= $t->{DATA}; next; }
    
    if ($t->{TOKEN} eq 'PERL') {
      my $expr = Eval($t->{EXPR},$f,$errs,$skipping,$tmplvars,@reslist);
      my $val = eval $expr;
      if ($@) {
	chomp $@;
	push @$errs,("perl expression failed at $f:".$t->{LINE}."\n$expr\n$@");
      } else { $data .= $val; }
      next; 
    }
    
    if ($t->{TOKEN} eq 'SHELL') {
      my $cmd = Eval($t->{EXPR},$f,$errs,$skipping,$tmplvars,@reslist);
      my $xcmd = $cmd; $xcmd =~ s/\`/\\\`/;
      my $val = `$xcmd`;
      if ($? != 0) {
	push @$errs,("shell command failed at $f:".$t->{LINE}."\n$cmd");
      } else {
	chomp $val;
	$data .= $val;
      }
      next; 
    }
    
    if ($t->{TOKEN} eq 'REF') {
      my $result = Lookup( Eval($t->{EXPR},$f,$errs,$skipping,$tmplvars,@reslist),
		           $t,$f,$errs,$tmplvars,@reslist );
      if (defined $result) {
          $data .= $result;
      }
      next;
    }
    
    if ($t->{TOKEN} eq 'IFDEF') {
      my $key = Eval($t->{EXPR},$f,$errs,$skipping,$tmplvars,@reslist);
      $key =~ s/^\s+//; $key =~ s/\s+$//;
      my $val = undef; foreach my $res ($tmplvars,@reslist) {
	my $v = $res->{$key};
	last if (defined($val=$v->{VALUE}));
      }
      if (defined($val)) {
	$data .= Eval($t->{BODY},$f,$errs,$skipping,$tmplvars,@reslist) if ($t->{BODY});
      } else {
	$data .= Eval($t->{ELSE},$f,$errs,$skipping,$tmplvars,@reslist) if ($t->{ELSE});
      }
      next;
    }
    
    if ($t->{TOKEN} eq 'IF') {
      my $val = Eval($t->{EXPR},$f,$errs,$skipping,$tmplvars,@reslist);
      $val =~ s/^\s+//; $val =~ s/\s+$//;
      if ($val ne '') {
	$data .= Eval($t->{BODY},$f,$errs,$skipping,$tmplvars,@reslist) if ($t->{BODY});
      } else {
	$data .= Eval($t->{ELSE},$f,$errs,$skipping,$tmplvars,@reslist) if ($t->{ELSE});
      }
      next;
    }
    
    if ($t->{TOKEN} eq 'SET') {
      my $val = Eval($t->{EXPR},$f,$errs,$skipping,$tmplvars,@reslist);
      $tmplvars->{$t->{VAR}} = { VALUE => $val };
      next;
    }
    
    if ($t->{TOKEN} eq 'FOR') {
      my $var = $t->{VAR};
      if ($var !~ /^[a-zA-Z_]+$/) {
	push @$errs,("invalid variable name ($var) at $f:".$t->{LINE});
	next;
      }
      my $list = Eval($t->{EXPR},$f,$errs,$skipping,$tmplvars,@reslist);
      $list =~ s/^\s+//; $list =~ s/\s+$//;
      foreach my $tag (split /\s+/,$list) {
	my $binding = { $var => { VALUE => $tag } };
	$data .= Eval($t->{BODY},$f,$errs,$skipping,$tmplvars,$binding,@reslist)
	  if ($t->{BODY});
      }
      next;
    }

    if ($t->{TOKEN} eq 'INCLUDE') {
      my $fname = Eval($t->{EXPR},$f,$errs,$skipping,$tmplvars,@reslist);
      my $incdata = ReadTemplate($fname);
      unless (defined($incdata)) {
	push @$errs,("$@ at $f:".$t->{LINE});
	next;
      }
      $incdata = Transform($incdata,$fname,$skipping,@reslist);
      unless (defined($incdata)) {
	push @$errs,($@);
	next;
      }
      $data .= $incdata;
      next;
    }
    
    if ($t->{TOKEN} eq 'SKIP') {
      $data .= Eval($t->{BODY},$f,$errs,$skipping,$tmplvars,@reslist) unless ($skipping);
      next;
    }
    
    if ($t->{TOKEN} eq 'COMMENT') {
      next;
    }

  }
  return $data;
}

#######################################################################
sub Parse {
#######################################################################

# Parse token list into parse tree
#
# Input is:
#  Ref to token list as generated by Scan
#  (tokens are removed from here as parsed)
#  Filename (for error messages)
#  Optional pointer to error message list
#
# Output is:
#  Parse tree
#  Terminator token
#  Ref to error list

  my $tokens = shift;
  my $f = shift;
  my $errs = shift || [];

  my $newtokens = [];
  
  while (@$tokens) {
    
    my $t = shift @$tokens;
    my $type = $t->{TOKEN};
    if ( !defined $type ) {
        $type = '';
    }
    
    if ($type eq 'TEXT') { push @$newtokens, ($t); next; }
    
    return($newtokens,$t,$errs)
      if ($type eq 'END' || $type eq 'ELSE' ||
	  $type eq 'ENDSKIP' || $type eq 'ENDCOMMENT');
    
    if ( $type eq 'IF' || $type eq 'IFDEF' ) {
      my ($body,$term,$errs) = Parse($tokens,$f,$errs);
      $t->{BODY} = $body;
      if ($term->{TOKEN} eq 'ELSE') {
	($body,$term,$errs) = Parse($tokens,$f,$errs);
	$t->{ELSE} = $body;
      }
      if (!defined $term->{TOKEN} || $term->{TOKEN} ne 'END')  {
	push @$errs,("missing END for " . $type .
		     " statement at $f:" . $t->{LINE} );
	next;
      }
      ($body,$term,$errs) = Parse($t->{EXPR},$f,$errs);
      $t->{EXPR} = $body;
    }
    
    elsif ($type eq 'FOR') {
      my ($body,$term,$errs) = Parse($tokens,$f,$errs);
      $t->{BODY} = $body;
      if (!defined $term->{TOKEN} || $term->{TOKEN} ne 'END')  {
	push @$errs,("missing END for FOR statement at $f:".$t->{LINE});
	next;
      }
      ($body,$term,$errs) = Parse($t->{EXPR},$f,$errs);
      $t->{EXPR} = $body;
    }

    elsif ($type eq 'COMMENT') {
      my ($body,$term,$errs) = Parse($tokens,$f,$errs);
      $t->{BODY} = $body;
      if (!defined $term->{TOKEN} || $term->{TOKEN} ne 'ENDCOMMENT')  {
	push @$errs,("missing $left*/$right for $left*/$right at $f:"
		     .$t->{LINE});
	next;
      }
    }
    
    elsif ($type eq 'SKIP') {
      my ($body,$term,$errs) = Parse($tokens,$f,$errs);
      $t->{BODY} = $body;
      if (!defined $term->{TOKEN} || $term->{TOKEN} ne 'ENDSKIP')  {
	push @$errs,("missing ENDSKIP for SKIP statement at $f:"
		     .$t->{LINE});
	next;
      }
    }

    push @$newtokens,($t);
  }

  return($newtokens,undef,$errs);
}

#######################################################################
sub Scan {
#######################################################################

# Scan template data into token list
#
# Input is:
#  Template data
#  Template filename (for error messages)
#  Optional array ref to append error messages
#  Optional starting line number
#
# Output is:
#  Ref to list of tokens
#  Remainder of unscanned data
#  Terminator symbol (undef = EOF)
#  New line number
#  Ref to error message list

  my $data = shift;
  my $f = shift;
  my $errs = shift || [];
  my $line = shift || 1;

  my $tokens = [];


  print STDERR "$line: Scan\n$data\n------\n" if $DEBUG;

  while ($data =~ m/^(.*?)((?:\Q$left\E)|(?:\Q$right\E))(.*)$/so) {
    my ($text,$br,$rest) = ($1,$2,$3);

    if ( defined $text && length $text > 0 ) {
      print STDERR "$line: >> TEXT ($text)\n" if $DEBUG;
      push @$tokens, ({ TOKEN=>'TEXT', LINE=>$line, DATA=>$text });
      my $t = $text; $t =~ s/.//g; $line += length($t);
      print STDERR "$line: << TEXT\n" if $DEBUG;
    }
    
    if ($br =~ /^\Q$right\E$/) {
      return ($tokens,$rest,$br,$line,$errs) ;
    }

    if ($rest =~ /^\s*\\\s*\Q$right\E\s*(.*)$/s) {
      $data = $1;

    } elsif ($rest =~ /^\s*if\s*:\s*(.*)$/s) {
      print STDERR "$line: >> IF\n" if $DEBUG;
      my ($expr,$more,$term,$xline,$errs) = Scan($1,$f,$errs,$line);
      push @$tokens, ({ TOKEN=>'IF', LINE=>$line, EXPR=>$expr });
      print STDERR "$xline: << IF\n" if $DEBUG;
      push @$errs,("missing '$right' for IF statement at $f:$line")
	unless ($term =~ /^\Q$right\E$/);
      $data = $more; $line = $xline;
      
    } elsif ($rest =~ /^\s*ifdef\s*:\s*(.*)$/s) {
      print STDERR "$line: >> IFDEF\n" if $DEBUG;
      my ($expr,$more,$term,$xline,$errs) = Scan($1,$f,$errs,$line);
      push @$tokens, ({ TOKEN=>'IFDEF', LINE=>$line, EXPR=>$expr });
      print STDERR "$xline: << IFDEF\n" if $DEBUG;
      push @$errs,("missing '$right' for IFDEF statement at $f:$line")
	unless ($term =~ /^\Q$right\E$/);
      $data = $more; $line = $xline;
      
    } elsif ($rest =~ /^\s*perl\s*:\s*(.*)$/s) {
      print STDERR "$line: >> PERL\n" if $DEBUG;
      my ($expr,$more,$term,$xline,$errs) = Scan($1,$f,$errs,$line);
      push @$tokens, ({ TOKEN=>'PERL', LINE=>$line, EXPR=>$expr });
      print STDERR "$xline: << PERL\n" if $DEBUG;
      push @$errs,("missing '$right' for PERL statement at $f:$line")
	unless ($term =~ /^\Q$right\E$/);
      $data = $more; $line = $xline;
      
    } elsif ($rest =~ /^\s*shell\s*:\s*(.*)$/s) {
      print STDERR "$line: >> SHELL\n" if $DEBUG;
      my ($expr,$more,$term,$xline,$errs) = Scan($1,$f,$errs,$line);
      push @$tokens, ({ TOKEN=>'SHELL', LINE=>$line, EXPR=>$expr });
      print STDERR "$xline: << SHELL\n" if $DEBUG;
      push @$errs,("missing '$right' for SHELL statement at $f:$line")
	unless ($term =~ /^\Q$right\E$/);
      $data = $more; $line = $xline;
      
    } elsif ($rest =~ /^\s*for\s*:\s*([^ \t=]+)\s*=\s*(.*)$/s) {
      print STDERR "$line: >> FOR\n" if $DEBUG;
      my $var=$1; my($expr,$more,$term,$xline,$errs) = Scan($2,$f,$errs,$line);
      push @$tokens, ({ TOKEN=>'FOR', VAR=>$var, 
			EXPR=>$expr, LINE=>$line });
      print STDERR "$xline: << FOR\n" if $DEBUG;
      push @$errs,("missing '$right' for FOR statement at $f:$line")
	unless ($term =~ /^\Q$right\E$/);
      $data = $more; $line = $xline;
      
    } elsif ($rest =~ /^\s*set\s*:\s*(\S+)\s*=\s*(.*)$/s) {
      print STDERR "$line: >> SET\n" if $DEBUG;
      my $var=$1; my($expr,$more,$term,$xline,$errs) = Scan($2,$f,$errs,$line);
      push @$tokens, ({ TOKEN=>'SET', VAR=>$var, 
			EXPR=>$expr, LINE=>$line });
      print STDERR "$xline: << SET\n" if $DEBUG;
      push @$errs,("missing '$right' for SET statement at $f:$line")
	unless ($term =~ /^\Q$right\E$/);
      $data = $more; $line = $xline;
      
    } elsif ($rest =~ /^\s*include\s*:\s*(.*)$/s) {
      print STDERR "$line: >> INCLUDE\n" if $DEBUG;
      my($expr,$more,$term,$xline,$errs) = Scan($1,$f,$errs,$line);
      push @$tokens, ({ TOKEN=>'INCLUDE', EXPR=>$expr, LINE=>$line });
      print STDERR "$xline: << INCLUDE\n" if $DEBUG;
      push @$errs,("missing '$right' for INCLUDE statement at $f:$line")
	unless ($term =~ /^\Q$right\E$/);
      $data = $more; $line = $xline;
      
    } elsif ($rest =~ /^\s*\{\s*\Q$right\E(.*)$/s) {
      $data = $1; push @$tokens, ({ TOKEN=>'SKIP', LINE=>$line });
      print STDERR "$line: SKIP\n" if $DEBUG;

    } elsif ($rest =~ /^\s*\}\s*\Q$right\E(.*)$/s) {
      $data = $1; push @$tokens, ({ TOKEN=>'ENDSKIP', LINE=>$line });
      print STDERR "$line: ENDSKIP\n" if $DEBUG;

    } elsif ($rest =~ /^\s*\/\*\s*\Q$right\E(.*)$/s) {
      $data = $1; push @$tokens, ({ TOKEN=>'COMMENT', LINE=>$line });
      print STDERR "$line: COMMENT\n" if $DEBUG;

    } elsif ($rest =~ /^\s*\*\/\s*\Q$right\E(.*)$/s) {
      $data = $1; push @$tokens, ({ TOKEN=>'ENDCOMMENT', LINE=>$line });
      print STDERR "$line: ENDCOMMENT\n" if $DEBUG;

    } elsif ($rest =~ /^\s*else\s*:\s*\Q$right\E(.*)$/s) {
      $data = $1; push @$tokens, ({ TOKEN=>'ELSE', LINE=>$line });
      print STDERR "$line: ELSE\n" if $DEBUG;

    } elsif ($rest =~ /^\s*end\s*:\s*\Q$right\E(.*)$/s) {
      $data = $1; push @$tokens, ({ TOKEN=>'END', LINE=>$line });
      print STDERR "$line: END\n" if $DEBUG;

    } else {

      print STDERR "$line: >> REF\n" if $DEBUG;
      my ($expr,$more,$term,$xline,$errs) = Scan($rest,$f,$errs,$line);

      push @$tokens, ({ TOKEN=>'REF', EXPR=>$expr, LINE=>$line });
      print STDERR "$xline: << REF\n" if $DEBUG;
      push @$errs,("missing '$right' at $f:$line")
	unless ($term =~ /^\Q$right\E$/);
      $data = $more; $line = $xline;
    }
  }

  push @$tokens, ({ TOKEN=>'TEXT', DATA=>$data, LINE=>$line }) if ($data);
  print STDERR "$line: TEXT\n" if $DEBUG;
  map { ++$line } split(/\n/,$data);
  return ($tokens,'',undef,$line,$errs);
}

#######################################################################
sub Transform {
#######################################################################

# Transform template data according to resources
# Set $@ and return undef on error
# If skipping" is set, do not generate output for skipped statements

  my $data = shift;
  my $f = shift;
  my $skipping = shift;
  my @reslist = @_;

  my ($tokens,$rest,$term,$line,$errs) = Scan($data,$f);
  push @$errs,("unexpected '$right' at $f:$line") if ($term);
  if (@$errs) { $@ = join("\n",@$errs); return undef; }

  ($tokens,$term,$errs) = Parse($tokens,$f);
  push @$errs,("unexpected ".$term->{TOKEN}." at $f:".$term->{LINE})
    if ($term);
  if (@$errs) { $@ = join("\n",@$errs); return undef; }

  my $tmplvars = {}; # anything set in a template

  $data = Eval($tokens,$f,$errs,$skipping,$tmplvars,@reslist);
  if (@$errs) { $@ = join("\n",@$errs); return undef; }
  return (@$errs) ? undef : $data;
}

#######################################################################
sub Substitute {
#######################################################################

# Take a list of resource structures and a template
# Substitute the resources in the template
# Return 0 or 1 depending on whether the target file has been changed
# Set $@ and return undef on error
  
  my $tmplfile = shift;
  my $targetfile = shift;
  my $mode = shift;
  my @reslist = @_;

  my $template;

  # Read the template
  my $data = ReadTemplate($tmplfile);
  return undef unless (defined($data));

  my $newdata = '';
  
  # Make the substitutions
  if ($mode&$LITERAL) { # literal, just read in the file
    my $fh = IO::File->new( $tmplfile, 'r' );
    if ( !defined $fh ) {
      $@ = "Failed to open $tmplfile: $!";
      return;
    }

    $newdata = do { local $/; <$fh> };

    $fh->close;

  } elsif ($mode&$PERLTMPL) {
    
    eval { require Template };
    return undef if ($@);
    # Create template processor
    my %extraopts;
    my $incpath = IncludePath();
    if ( defined $incpath ) { $extraopts{INCLUDE_PATH} = $incpath }
    $template = Template->new( { %perlopts, %extraopts });
    unless ($template) { $@="can't create Perl template: $@"; return undef; }
    # Create variable/value hash for template processor
    my $vars={}; foreach my $res (@reslist) {
      foreach my $key (keys %$res) { 
	$vars->{$key} = $res->{$key}->{'VALUE'};
      }
    }
    my $result = $template->process(\$data,$vars,\$newdata);
    unless ($result) { $@=$template->error(); return undef; }
  } else {
    $newdata = Transform($data,$tmplfile,0,@reslist);
    return undef unless (defined($newdata));
  }

  # If we are writing to the stdout, we can't compare the output
  # with last time, so we just assume it has changed.
  if ($targetfile eq '-') {
    print $newdata;
    return 1;
  }

  # Otherwise, save the output config file. The return status
  # tells us whether the real config file has changed.
  my $realchange = SaveFile($newdata,$targetfile,$targetfile,$mode);
  return $realchange if ( $mode&$PERLTMPL || $mode&$LITERAL );

  # Generate the data without the skipped sections
  my $skipdata = Transform($data,$tmplfile,1,@reslist);
  return undef unless (defined($skipdata));
  
  # If the data contains skipped sections, we need to save a copy of
  # it without these sections, so we can see next time if anything
  # significant has changed. We save this in $skipfile. We try not
  # to create this file unless we actually need it.
  my $skipfile = ($targetfile =~ /^(.*\/)(.*)$/)
    ? "$1.sxprof-$2" : ".sxprof-$targetfile";

  if ($newdata eq $skipdata) {
    if (-f $skipfile) { 
      # The old file had skipped sections, but the new one doesn't
      my $change = SaveFile($skipdata,$skipfile,$skipfile,1);
      unless (unlink($skipfile)) {
	$@ = "can't delete file: $skipfile\n$!";
	return undef;
      }
      unlink("$skipfile~");
      return $change;
    } else {
      # Neither the old file or the new one has skipped sections
      return $realchange;
    }
  } else {
    if (-f $skipfile) { 
      # The old and new files both have skipped sections
      return SaveFile($skipdata,$skipfile,$skipfile,0);
    } else {
      # The new file has skipped sections but the old one doesn't
      return SaveFile($skipdata,$skipfile,$targetfile,0);
    }
  }
}

#######################################################################
sub Delimiters {
#######################################################################

# Set delimiters and (optionally) perl template options
  
  my $l = shift;
  my $r = shift;
  my %opts = @_;

  if ( defined $l ) { $perlopts{START_TAG} = $left  = $l; }
  if ( defined $r ) { $perlopts{END_TAG}   = $right = $r; }
  
  foreach my $o (keys %opts) { $perlopts{$o} = $opts{$o}; }
}

1;

__END__

=head1 NAME

LCFG::Template - substitute LCFG resources in template

=head1 SYNOPSYS

  use LCFG::Template;

  # Load resources for 'foo' and 'bar' from adaptor profile
  $result = LCFG::Template::Substitute($template,$target,$mode,@res);

  # Set delimiters
  LCFG::Template::Delimiters($left,$right,[option...]);

=head1 DESCRIPTION

This routine takes the name of a template file and substitutes LCFG
resource values into the template from the given list of resource
tables. The return status indicates whether the target file has been
changed by the operation (1) or not (0).  The C<mode> option can be
used to specify the following bit flags: if <mode>&1 is non-zero, then
then the file is never modified, but the return status indicates
whether or not it would have been. If <mode>&2 is non-zero, then no
backup files are created. If <mode>&4 is non-zero, then the template is
processed using the Perl B<Template> module instead of the built-in
template processor.

The resources tables are in the same format as generated by the
LCFG::Resources module, without the name of the component at
the top level of the structure:

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

If an error occurs, then the routine returns C<undef> and the variable
C<$@> contains the error message.

The B<Delimiters> routine can be used to change the default delimiter
strings and the options to the Perl template processor.

=head1 TEMPLATE LANGUAGE

The following constructions are supported by the builtin template processor:

=over 4

=item <%I<resource>%>

Substitute the value of the named resource. The resource name my be
preceeded by a B<#> in which case the "derivation" of the resource
will be substituted instead of the value. This can be usefully used to
generate comments in the generated configuration file indicating the
source of the various parameters. The delimiters <%{%> and <%}%> (see
below) are useful when substituting derivations in comments to prevent
a reconfiguraion being flagged if only the derivations (and not the
values) change.

Note that the LCFG client component will only notify components of
changes to the value of resources -- if only derivations change, then
the component is not automatically reconfigured, and values of
substituted derivations may be out of date.

=item <%if: I<expr>%> I<text> <%else:%> I<text> <%end:%>

If the I<expr> is non-null, then substitute the first text, otherwise
substitute the second text. The I<else> part is optional.

=item <%perl: I<expression>%>

Substitute the result of the Perl I<expresssion>.

=item <%shell: I<command>%>

Substitute the result of the Shell I<command>.

=item <%ifdef: I<resource>%> I<text> <%else:%> I<text> <%end:%>

If the I<resource> is defined, then substitute the first text,
otherwise substitute the second text. The I<else> part is optional.

=item <%for: I<var>=I<expr>%> I<text> <%end:%>

Substitute one copy of the specified I<text> for each item in the
space-separated list I<expr>. During substitution of the text, the
value of the variable I<var> may be referenced as <%I<var>%>. (Any
resource with the same name as var will be inaccessible during the
scope of the statement).

=item <%set: I<var>=I<expr>%>

Set a global variable to the given value. The global variable can be
accessed as <%I<var>%> at any subsequent point in the program. Any
resource with the same name will be inacessible.

=item <%include: I<filename>%>

Include the contents of the specified template file, evaluating it in
the current context.

=item <%\%>

Delete any following white space. This allows complex template
expressions to span multiple lines, while still generating
output on a single line.

=item <%/*%> ... <%*/%>

Text between these delimiters is treated as a comment in the template and
is not copied to the output file.

=item <%{%> ... <%}%>

Text between these delimiters is treated as insignificant. The text is
still copied to the output file (evaluating any expressions), but
changes to this text are not sufficient for the return status to
indicate that the file has changed. This is useful for placing
changing comments in the output (for example indicating the generation
date) without triggering reconfiguration of the component unless
something significant has changed. Eg:

 #<%{%> Generated on <%shell: date%> <%}%>

=back

All the above elements except I<var> may contain nested statements.

=head1 PLATFORMS

ScientificLinux6, EnterpriseLinux7, Debian

=head1 AUTHOR

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

=cut
