File Coverage

/root/.cpan/build/Text-Starfish-1.37-0/blib/lib/Text/Starfish.pm

Criterion	Covered	Total	%
statement	1468	1733	84.7
branch	258	466	55.3
condition	44	72	61.1
subroutine	332	354	93.7
pod	32	65	49.2
total	2134	2690	79.3

# Starfish - Perl-based System for Preprocessing and Text-Embedded Programming
#
# (c) 2001-2020 Vlado Keselj http://web.cs.dal.ca/~vlado [e-mail]
#               and contributing authors
#
# See the documentation following the code.  You can also use the
# command "perldoc Starfish.pm".

package Text::Starfish;
use vars qw($NAME $ABSTRACT $VERSION);
$NAME     = 'Text::Starfish';
$ABSTRACT = 'Perl-based System for Preprocessing and Text-Embedded Programming';
$VERSION  = '1.37';

use strict;
use POSIX;
use Carp;
use Cwd qw(cwd);
use Exporter;
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS); # Exporter vars

@ISA = qw(Exporter);
%EXPORT_TAGS = ( 'all' => [qw(
  add_hook appendfile echo file_modification_date
  file_modification_time getfile getmakefilelist get_verbatim_file
  getinclude htmlquote include
  last_update putfile read_records read_starfish_conf rm_hook set_out_delimiters
  sfish_add_tag sfish_ignore_outer starfish_cmd make_gen_dirs_to_generate
  make_add_dirs_to_generate_if_needed
  ) ] );
@EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );
@EXPORT = @{ $EXPORT_TAGS{'all'} };

# Used in starfishing Makefiles
use vars qw(@DirGenerateIfNeeded);

# non-exported package globals
use vars qw($GlobalREPLACE);

sub appendfile($@);
sub getfile($ );
sub getmakefilelist($$);
sub htmlquote($ );
sub putfile($@);
sub read_records($ );
sub starfish_cmd(@);

sub new($@) {
  my $proto = shift;
  my $class = ref($proto) || $proto;
  my $self = {};
  bless($self, $class);

  $self->{Loops} = 1;
  my $copyhooks = '';
  foreach (@_) {
    if (/^-infile=(.*)$/) { $self->{INFILE} = $1 }
    elsif (/^-copyhooks$/)   { $copyhooks = 1 }
    else { _croak("unknown new option: $_") }
  }

  if ($copyhooks) {
    _croak("new: cannot copyhooks if Star is not there") unless
      ref($::Star) eq 'Text::Starfish';
    $self->{Style}           = $::Star->{Style};
    $self->{CodePreparation} = $::Star->{CodePreparation};
    $self->{LineComment}     = $::Star->{LineComment};
    $self->{OutDelimiters}   = $::Star->{OutDelimiters};
    $self->{IgnoreOuter}     = $::Star->{IgnoreOuter};
    $self->{hook}            = [ @{ $::Star->{hook} } ];
  }

  $self->set_style() unless $copyhooks;

  return $self;
}

sub starfish_cmd(@) {
  my $sf = Text::Starfish->new();
  my @tmp = ();
  foreach (@_) {
    if    (/^-e=?/)      { $sf->{INITIAL_CODE} = $' }
    elsif (/^-mode=/)    { $sf->{NEW_FILE_MODE} = $' }
    elsif (/^-o=/)       { $sf->{OUTFILE}      = $' }
    elsif (/^-replace$/) { $sf->{REPLACE} = $GlobalREPLACE = 1; }
    elsif (/^-v$/) { print "$NAME, version $VERSION, $ABSTRACT\n"; exit 0; }
    else { push @tmp, $_ }
  }

  if (defined $sf->{NEW_FILE_MODE} and $sf->{NEW_FILE_MODE} =~ /^0/)
  { $sf->{NEW_FILE_MODE} = oct($sf->{NEW_FILE_MODE}) }

  $sf->process_files(@tmp);
  return $sf;
}

sub include($@) { $::O .= getinclude(@_); return 1; }

sub getinclude($@) {
  my $sf = loadinclude(@_);
  return '' unless defined $sf;
  $sf->digest();
  return $sf->{Out};
}

sub loadinclude($@) {
  my $infile = '';
  my @args = ();
  my $replace = 1;
  my $require = '';
  foreach (@_) {
    if    (/^-replace$/)   { $replace = 1 }
    elsif (/^-noreplace$/) { $replace = '' }
    elsif (/^-require$/)   { $require = 1 }
    elsif (!/^-/ && $infile eq '') { $infile = $_ }
    else  { push @args, $_ }
  }

  my $sf = Text::Starfish->new("-infile=$infile", @args);
  $sf->{REPLACE} = $replace;

  if ($sf->{INFILE} eq '' or ! -r $sf->{INFILE} ) {
    if ($require) { _croak("cannot getinclude file: ($sf->{INFILE})") }
    return undef;
  }

  $sf->{data} = getfile $sf->{INFILE};
  return $sf;
}

sub process_files {
  my $self = shift;
  my @args = @_;

  if (defined $self->{REPLACE} and !defined $self->{OUTFILE})
  { _croak("Starfish:output file required for replace") }

  my $FileCount=0;
  $self->eval1($self->{INITIAL_CODE}, 'initial');

  while (@args) {
    $self->{INFILE} = shift @args;
    ++$FileCount;
    $self->set_style();
    $self->{data} = getfile $self->{INFILE};

    # *123* we need to forbid defining an outfile externally as well as
    # internally:
    my $outfileExternal = exists($self->{OUTFILE}) ? $self->{OUTFILE} : '';

    my $ExistingText = '';
    if (! defined $self->{OUTFILE}) {
      $ExistingText = $self->{data};
      $self->{LastUpdateTime} = (stat $self->{INFILE})[9];
    }
    elsif ($FileCount > 1)  {
      $ExistingText = '';
      $self->{LastUpdateTime} = time;
    }
    elsif (! -f $self->{OUTFILE})   {
      $ExistingText = '';
      $self->{LastUpdateTime} = time;
    }
    else {
      $ExistingText = getfile $self->{OUTFILE};
      $self->{LastUpdateTime} = (stat $self->{OUTFILE})[9];
    }

    $self->digest();

    # see *123* above
    if ($outfileExternal ne '' and $outfileExternal ne $self->{OUTFILE})
    { _croak("OUTFILE defined externally ($outfileExternal) and ".
	     "internally ($self->{OUTFILE})") }

    my $InFile = $self->{INFILE};
    if ($FileCount==1 && defined $self->{OUTFILE}) {
      # touch the outfile if it does not exist
      if ( ! -f $self->{OUTFILE} ) {
	putfile $self->{OUTFILE};
	my $infile_mode = (stat $InFile)[2];
	if (defined $self->{NEW_FILE_MODE}) {
	       chmod $self->{NEW_FILE_MODE}, $self->{OUTFILE}}
	else { chmod $infile_mode,	$self->{OUTFILE} }
      }
      elsif (defined $self->{NEW_FILE_MODE}) {
	chmod $self->{NEW_FILE_MODE}, $self->{OUTFILE} }
    }

    # write the text if changed
    if ($ExistingText ne $self->{Out}) {
      if (defined $self->{OUTFILE}) {
	# If the OutFile is defined, we may have to play with
	# permissions in order to write.  Be careful! Allow
	# unallowed write only on outfile and if -mode is
	# specified
	my $mode = ((stat $self->{OUTFILE})[2]);
	if (($mode & 0200) == 0 and defined $self->{NEW_FILE_MODE}) {
	  chmod $mode|0200, $self->{OUTFILE};
	  if ($FileCount==1) { putfile $self->{OUTFILE}, $self->{Out} }
	  else            { appendfile $self->{OUTFILE}, $self->{Out} }
	  chmod $mode, $self->{OUTFILE};
	} else {
	  if ($FileCount==1) { putfile $self->{OUTFILE}, $self->{Out} }
	  else            { appendfile $self->{OUTFILE}, $self->{Out} }
	}
      }
      else {
	putfile $InFile, $self->{Out};
	chmod $self->{NEW_FILE_MODE}, $InFile if defined $self->{NEW_FILE_MODE};
      }
    }
    elsif (defined $self->{NEW_FILE_MODE}) {
      if (defined $self->{OUTFILE}) {
	     chmod $self->{NEW_FILE_MODE}, $self->{OUTFILE} }
      else { chmod $self->{NEW_FILE_MODE}, $InFile }
    }
  }				# end of while (@args)

}				# end of method process_files

# eval_dispatch should see how to properly call the evaluator, or replacement
# eventually it should also be used for string-based evaluators
sub eval_dispatch {
  my $self = shift;
  my $hook = $self->{hook}->[$self->{ttype}];
  if ($hook->{ht} eq 'regex') {
    local $::Star = $self;
    my $c = $self->{args}->[0];
    my $r = &{ $self->{hook}->[$self->{ttype}]->{replace} }
      ( $self, @{ $self->{args} } );
    return $r if $self->{REPLACE};
    return $c if $r eq '';
    return $c."".$self->_output_wrap($r);
  }
  _croak("Hook type not evaluated: ht=($hook->{ht})");
}

sub digest {
  my $self = shift;
  $self->{CurrentLoop} = 1;
  my $savedcontent = $self->{data};

 START:			# The main scanning loop
  $self->{Out} = '';
  $self->scan();
  while ($self->{ttype} != -1) {
    if ($self->{ttype} > -1) {
      my $hook = $self->{hook}->[$self->{ttype}];
      if ($hook->{ht} eq 'regex') {
	$self->{Out} .= $self->eval_dispatch;
      }
      # old style regex evaluator, should be removed, but first
      # fix problems with python style
      elsif ( @{$self->{args}} ) {
	$self->{Out}.= &{$self->{hook}->[$self->{ttype}]->{replace}}
	  ( $self, @{ $self->{args} } );
      }
      else {
	$self->{Out}.= &{$self->{hook}->[$self->{ttype}]->{f}}
	  ( $self, $self->{prefix}, $self->{currenttoken}, $self->{suffix});
      }
    } # else $ttype < -1 (outer text)
    else { $self->_process_outer( $self->{currenttoken} ) }
    $self->scan();
  }

  if ($self->{CurrentLoop} < $self->{Loops}) {
    ++$self->{CurrentLoop};
    if ($self->{REPLACE}) {             # in replace mode interate with
      $self->{data} = $savedcontent;    # original input
      goto START;
    }
    $self->{data} = $self->{Out};
    if ($savedcontent ne $self->{Out})
      { $self->{LastUpdateTime} = time }
    putfile 'sfish.debug', $self->{data};
    goto START;
  }

  # Final routines, if defined
  if (defined($self->{Final})) {
    my @a = @{ $self->{Final} };
    local $::Star = $self;
    for my $f (@a) {
      $self->{Out} = &{$f}($self->{Out}); }
  }

  # Related to the macro concept (e.g. code folding)
  if (defined $self->{macrosdefined}) {
    my ($m, $s);
    for $m (sort keys %{$self->{Macros}}) {
      $s = $self->{Macros}->{$m};
      if ($s =~ /\n/) {
	my $p1 = "$`$&"; $s = $';
	if ($s) { $s = $p1.wrap($s) }
	else { $s = $p1 }
      }
      $self->{Out}.= $self->{MprefAuxDefine}.$s.$self->{MsufAuxDefine};
    }
  }
} # end of sub digest

# process outer text; by default, it should be appended to $self->{Out}
sub _process_outer {
  my $self = shift; my $outer = shift;
  if ($self->{REPLACE} && $self->{IgnoreOuter}) {  }
  else { $self->{Out} .= $outer }
  # Comment: something should be done if IgnoreOuter is true and
  # not in REPLACE mode; maybe comment-out outer text? (todo?)
}

sub _index {
    my $str = shift;
    my $subs = shift;
    if (ref($subs) eq 'Regexp') {
	if ($str =~ $subs) { return (length($`),length($&)) }
	else { return (-1,0) }
    }
    else { return (index($str, $subs), length($subs)) }
}

# $self->{ttype}: -1 EOF
#             -2 outer text (but also handled directly)
sub scan {
  my $self = shift;

  $self->{prefix} = $self->{suffix} = '';
  $self->{args} = [];
  if ($self->{data} eq '') {	# no more data, EOF
    $self->{ttype} = -1;
    $self->{currenttoken} = '';
  }
  else {
    my $i1 = length($self->{data}) + 1;   # distance to starting anchor
    my $i2 = $i1;                         # distance to ending anchor
    my $pl=0; my $sl=0;
    $self->{ttype} = -2;
    foreach my $ttype (0 .. $#{ $self->{hook} }) {
      my ($j, $pl2, $j2, $sl2);         # $j  dist to candidate starting achor
                                        # $j2 dist to candidate ending anchor
      if (exists($self->{hook}->[$ttype]->{'begin'})) {
	# $j - to the start of the candidate active snippet
	($j,$pl2) = _index($self->{data}, $self->{hook}->[$ttype]->{'begin'});
	next unless $j != -1 && $j <= $i1;
	my $data2 = substr($self->{data}, $j);
	if ($self->{hook}->[$ttype]->{'end'} ne '') {
	  ($j2, $sl2) = _index($data2, $self->{hook}->[$ttype]->{'end'});
	  next if -1 == $j2;
	  $j2 += $j;
	} else { $j2 = length($self->{data}) + 1; $sl2 = 0; }
	next if ($j==$i1 and $i2<=$j2);
	$i1 = $j; $pl = $pl2; $i2 = $j2; $sl = $sl2;
	$self->{ttype} = $ttype;
	$self->{args}  = [];
      } else {		# matching regex hook
	my @args = ($self->{data} =~ /$self->{hook}->[$ttype]->{regex}/m);
	next unless @args;
	my $j = length($`);
	next unless $j < $i1;
	$i1 = $j; $i2 = $i1+length($&); $sl=$pl=0;
	unshift @args, $&;
	$self->{ttype} = $ttype;
	$self->{args} = \@args;
      }
    }

    if ($self->{ttype}==-2) {
      $self->{currenttoken}=$self->{data}; $self->{data}='' }
    else { # live code
      if (@{$self->{args}}) {
	#$self->{Out} = $newOut;
	$self->_process_outer( substr($self->{data}, 0, $i1) );
	#$self->{Out} .= substr($self->{data}, 0, $i1);
	##$self->{data} = $newData;
	$self->{prefix} = '';
	$self->{currenttoken} = substr($self->{data}, $i1+$pl, $i2-$i1-$pl);
	$self->{suffix} = '';
	$self->{data} = substr($self->{data}, $i2+$sl);
      }
      else {
	# just copy type -2
	# instead of returning as earlier, to
	# support negative look-back for prefix
	# $self->{Out} .= substr($self->{data}, 0, $i1);
	$self->_process_outer( substr($self->{data}, 0, $i1) );
	$self->{prefix} = substr($self->{data}, $i1, $pl);
	$self->{currenttoken} = substr($self->{data}, $i1+$pl, $i2-$i1-$pl);
	$self->{suffix} = substr($self->{data}, $i2, $sl);
	$self->{data} = substr($self->{data}, $i2+$sl);
      }
	  # Remove old output if it is there:
      if (defined($self->{OutDelimiters})) {
	my ($b1,$b2,$e1,$e2) = @{ $self->{OutDelimiters} };
	if ($self->{data} =~ /^\Q$b1\E(\d*)\Q$b2\E.*?\Q$e1\E\1\Q$e2\E/s) {
	  $self->{data} = $'; }
      }
    }
  }

  return $self->{ttype};
}

# eval wrapper for string code
sub eval1 {
  my $self = shift;
  my $code = shift; $code = '' unless defined $code;
  my $comment = shift;
  eval("package main; no strict; $code");
  if ($@) {
    my ($code1, $linecnt);
    foreach (split(/\n/, $code))
      { ++$linecnt; $code1 .= sprintf("%03d %s\n", $linecnt, $_); }
    _croak("$comment code error:$@\ncode:\n$code1");
  }
}

# The main subroutine for evaluating a snippet of string
sub evaluate {
    my $self = shift;

    my $pref = shift;
    my $code = shift; my $c = $code;
    my $suf = shift;
    if (defined($self->{CodePreparation}) && $self->{CodePreparation}) {
	local $_=$code;
	$self->eval1($self->{CodePreparation},'preprocessing');
	$code = $_;
  	}

    # Evaluate code, first final preparation and then eval1
    local $::Star = $self;
    local $::O = '';
    $self->eval1($code, 'snippet');

    if ($self->{REPLACE}) { return $::O }
    if ($::O ne '') { $suf.= $self->_output_wrap($::O); }
    return "$pref$c$suf";
  }

# Wrap output with output delimiters
sub _output_wrap {
  my $self = shift; my $out = shift; my @d = ("#","+\n","#","-");
  @d = @{ $self->{OutDelimiters} } if defined( $self->{OutDelimiters} );
  my ($b,$e) = ($d[0].$d[1], $d[2].$d[3]); my $i;
  if (index($out, $e) != -1) {
    while(1) { $i++; $e=$d[2].$i.$d[3]; last if index($out, $e)==-1;
      _croak("Problem finding ending delimiter!\n(O=$out)") if $i > 1000000;}
    $b = $d[0].$i.$d[1]; }
  return $b.$out.$e; }

# Python-specific evaluator (used also for makefile style)
sub evaluate_py {
    my $self = shift;

    my $pref = shift;
    my $code = shift; my $c = $code;
    my $suf = shift;
    if (defined($self->{CodePreparation}) && $self->{CodePreparation}) {
	local $_=$code;
	$self->eval1($self->{CodePreparation},'preprocessing');
	$code = $_;
    }

    # Evaluate code, first final preparation and then eval1
    local $::Star = $self;
    local $::O = '';
    $self->eval1($code, 'snippet');

    if ($self->{REPLACE}) { return $::O }
    if ($::O ne '') {
	my $indent = '';
	if ($pref =~ /^(\s+)#/) { $indent = $1 }
	elsif ($c =~ /^(\s+)#/m) { $indent = $1 }
	my $out = $::O;
	# Avoiding extra \n before #-
	$out.="\n" unless rindex($out, "\n")==length($out)-1;
	$out.= $indent.$self->_output_wrap($out);
	$suf.= $indent.$out;
    }
    return "$pref$c$suf";
}

# Python-specific evaluator (used also for makefile style)
sub evaluate_py1 {
    my $self = shift;
    my $allmatch = shift;
    my $indent = shift;
    my $prefix = shift;
    my $code = shift; my $c = $code;
    my $oldout = shift;

    if (defined($self->{CodePreparation}) && $self->{CodePreparation}) {
	local $_=$code;
	$self->eval1($self->{CodePreparation},'preprocessing');
	$code = $_;
    }

    # Evaluate code, first final preparation and then eval1
    local $::O = '';
    local $::Star = $self;
    $self->eval1($code, 'snippet');

    if ($self->{REPLACE}) { return $indent.$::O }
    elsif ($::O eq '') { return "$indent#$prefix$c!>" }
    else {
      $::O =~ s/^/$indent/gmx;
      my $r;
      my ($b,$e); my @d = @{ $self->{OutDelimiters} };
      $b = $d[0].$d[1]; my $i; $e = $d[2].$d[3];
      if (index($::O, $e) != -1) {
	while(1) { $i++; $e=$d[2].$i.$d[3]; last if index($::O, $e)==-1;
		   _croak("Problem finding ending delimiter!\n(O=$::O)")
		     if $i > 1000000; }
	$b = $d[0].$i.$d[1];
      }
      $r= "$indent#$prefix$c!>$b".$::O;
      $r =~ s/\n?$/\n/; $r.="$indent$e"; # no extra \n
    }
}

# predefined evaluator: echo
sub eval_echo {
    my $self = shift;
    my $pref = shift;
    my $cont = shift;
    my $suff = shift;
    $::O = $cont;

    # to update OutDelimiters
    return $::O if $self->{REPLACE};
    return $pref.$cont.$suff if $::O eq '';
    $suff.=$self->_output_wrap($::O);
    return $pref.$cont.$suff;
}

# predefined evaluator: ignore
sub eval_ignore {
    my $self = shift;
    return '' if $self->{REPLACE};

    my $pref = shift;
    my $code = shift;
    my $suf = shift;
    return $pref.$code.$suf;
}

# predefined ignore evaluator for regex hooks
sub repl_comment {
    my $self = shift;
    if ($self->{REPLACE}) { return '' }
    return $self->{currenttoken};
}

sub define {
    my $self = shift;

    my $pref = shift;
    my $data = shift;
    my $suf = shift;

    if ($self->{CurrentLoop} > 1) { return "$pref$data$suf"; }

    $data =~ /^.+/ or _croak("expected macro spec");
    _croak("no macro spec") unless $&;
    _croak("double macro def (forbidden):$&") if ($self->{ForbidMacro}->{$&});
    $self->{Macros}->{$&} = $data;
    return '';
}

sub MCdefine {
    my $self = shift;
    my $pref = shift;
    my $data = shift;
    my $suf = shift;

    if ($self->{CurrentLoop} > 1) { die "define in loop > 1 !?" }

    $data =~ /^.+/ or die "expected macro spec";
    die "no macro spec" unless $&;
    die "double macro def (forbidden):$&" if ($self->{ForbidMacro}->{$&});
    $self->{Macros}->{$&} = $data;
    return '';
}

sub MCdefe {
  my $self = shift;
  die "(".ref($self).")" unless ref($self) eq 'Text::Starfish';

  my $pref = shift;
  my $data = shift;
  my $suf = shift;

  if ($self->{CurrentLoop} > 1) { die "defe in a loop >1!?" }

  $data =~ /^.+/ or die "expected macro spec";
  die "no macro spec" unless $&;
  die "def macro forbidden:$&\n" if (defined $self->{ForbidMacro}->{$&});
  $self->{Macros}->{$&} = $data;
  return $self->{MacroKey}->{'expand'}.$&.$self->{MacroKey}->{'/expand'};
}

sub MCnewdefe {
    my $self = shift; die "(".ref($self).")" unless ref($self) eq 'Text::Starfish';

    my $pref = shift;
    my $data = shift;
    my $suf = shift;

    if ($self->{CurrentLoop} > 1) { die "newdefe in second loop!?" }

    $data =~ /^.+/ or die "expected macro spec";
    die "no macro spec" unless $&;
    if (defined $self->{Macros}->{$&} || $self->{ForbidMacro}->{$&}) {
	die "double def:$&" }
    $self->{Macros}->{$&} = $data;
    $self->{ForbidMacro}->{$&} = 1;
    return $self->{MprefExpand}.$&.$self->{MsufExpand};
}

sub expand {
  my $self = shift;
  die "(".ref($self).")" unless ref($self) eq 'Text::Starfish';

  my $pref = shift;
  my $data = shift;
  my $suf = shift;

  if ($self->{CurrentLoop} < 2 || $self->{HideMacros})
  { return $self->{MacroKey}->{'expand'}.$data.$self->{MacroKey}->{'/expand'} }

  $data =~ /^.+/ or die "expected macro spec";
  die "no macro spec" unless $&;
  return $self->{MacroKey}->{'expanded'}.$self->{Macros}->{$&}.
    $self->{MacroKey}->{'/expanded'};
}

sub MCexpand {
  my $self = shift;
  die "(".ref($self).")" unless ref($self) eq 'Text::Starfish';

  my $pref = shift;
  my $data = shift;
  my $suf = shift;

  if ($self->{CurrentLoop} < 2 || $self->{HideMacros}) {
    return "$pref$data$suf"; }

  $data =~ /^.+/ or die "expected macro spec";
  die "no macro spec" unless $&;
  die "macro not defined" unless defined $self->{Macros}->{$&};
  return $self->{MprefExpanded}.$self->{Macros}->{$&}.$self->{MsufExpanded};
}

sub fexpand {
  my $self = shift;
  die "(".ref($self).")" unless ref($self) eq 'Text::Starfish';

  my $pref = shift;
  my $data = shift;
  my $suf = shift;

  if ($self->{CurrentLoop} < 2) { return "$pref$data$suf"; }

  $data =~ /^.+/ or die "expected macro spec";
  die "no macro spec" unless $&;
  die "macro not defined:$&" unless defined $self->{Macros}->{$&};
  return $self->{MpreffExpanded} . $self->{Macros}->{$&}.$self->{MsuffExpanded};
}

sub MCfexpand {
  my $self = shift;
  die "(".ref($self).")" unless ref($self) eq 'Text::Starfish';

  my $pref = shift;
  my $data = shift;
  my $suf = shift;

  if ($self->{CurrentLoop} < 2) { return "$pref$data$suf"; }

  $data =~ /^.+/ or die "expected macro spec";
  die "no macro spec" unless $&;
  die "macro not defined:$&" unless defined $self->{Macros}->{$&};
  return $self->{MacroKey}->{'fexpanded'}.$self->{Macros}->{$&}.
    $self->{MacroKey}->{'/fexpanded'};
}

sub expanded {
  my $self = shift;
  die "(".ref($self).")" unless ref($self) eq 'Text::Starfish';

  my $pref = shift;
  my $data = shift;
  my $suf = shift;

  $data =~ /^.+/ or die "expected macro name";
  die "no macro spec" unless $&;
  return $self->{MprefExpand}.$&.$self->{MsufExpand};
}

sub MCexpanded {
  my $self = shift;
  die "(".ref($self).")" unless ref($self) eq 'Text::Starfish';

  my $pref = shift;
  my $data = shift;
  my $suf = shift;

  $data =~ /^.+/ or die "expected macro name";
  die "no macro spec" unless $&;
  return $self->{MacroKey}->{'expand'}.$&.$self->{MacroKey}->{'/expand'};
}

sub fexpanded {
  my $self = shift;
  die "(".ref($self).")" unless ref($self) eq 'Text::Starfish';

  my $pref = shift;
  my $data = shift;
  my $suf = shift;

  $data =~ /^.+/ or die "expected macro name";
  die "no macro spec" unless $&;
  return $self->{MpreffExpand}.$&.$self->{MsuffExpand};
}

sub MCfexpanded {
  my $self = shift;
  die "(".ref($self).")" unless ref($self) eq 'Text::Starfish';

  my $pref = shift;
  my $data = shift;
  my $suf = shift;

  if ($self->{CurrentLoop} < 2) { return "$pref$data$suf"; }
  $data =~ /^.+/ or die "expected macro name";
  die "no macro spec" unless $&;
  die "Macro not defined:$&" unless defined $self->{Macros}->{$&};
  return $self->{MacroKey}->{'fexpanded'}.$self->{Macros}->{$&}.
    $self->{MacroKey}->{'/fexpanded'};
}

sub MCauxdefine {
  my $self = shift;
  die "(".ref($self).")" unless ref($self) eq 'Text::Starfish';

  my $pref = shift;
  my $data = shift;
  my $suf = shift;

  $data =~ /^.+/ or die "expected macro name";
  die "no macro spec" unless $&;
  my $mn = $&;
  $data = unwrap($data);
  die "double macro def (forbidden):$mn\n" if ($self->{ForbidMacro}->{$mn});
  if (! defined($self->{Macros}->{$mn}) ) { $self->{Macros}->{$mn}=$data }
  return '';
}

sub auxDefine {
  my $self = shift;
  die "(".ref($self).")" unless ref($self) eq 'Text::Starfish';

  my $pref = shift;
  my $data = shift;
  my $suf = shift;

  $data =~ /^.+/ or die "expected macro name";
  die "no macro spec" unless $&; my $mn = $&;
  $data = unwrap($data);
  die "double macro def (forbidden):$mn\n" if ($self->{ForbidMacro}->{$mn});
  if (! defined($self->{Macros}->{$mn}) ) { $self->{Macros}->{$mn}=$data }
  return '';
}

sub wrap {
    my $d = shift;
    $d =~ s/^/\/\/ /mg;
    return $d;
}

sub unwrap {
    my $d = shift;
    $d =~ s/^\/\/ //mg;
    return $d;
}

sub setGlobStyle {
    my $self = shift;
    my $s = shift;
    $self->{STYLE} = $s;
    $self->set_style($s);
}

sub clearStyle {
  my $self = shift;
  foreach my $k (qw(Style CodePreparation LineComment OutDelimiters
                    IgnoreOuter)) {
    delete $self->{$k} }
  $self->{hook} = [];
}

sub setStyle { return &set_style }

# List of fields typically set in set_style:
# $self->{Style}           = string, style
# $self->{CodePreparation} = scalar
# $self->{LineComment}     = string, line comment
# $self->{OutDelimiters}   = [] eg: "//" "+\n" "//" "-\n"
# $self->{IgnoreOuter}     = 1 or ''
# $self->{hook}            = [], list of hooks
sub set_style {
  my $self = shift;
  if (ref($self) ne 'Text::Starfish') { unshift @_, $self; $self = $::Star; }

  if ($#_ == -1) {
    if (defined $self->{STYLE} && $self->{STYLE} ne '')
    { $self->set_style($self->{STYLE}) }
    else {
      my $f = $self->{INFILE};

      if ($f =~ /\.(html\.sfish|sf)$/i) { $self->set_style('html.sfish') }
      else {
	$f =~ s/\.s(tar)?fish$//;
	if    ($f =~ /\.html?/i)        { $self->set_style('html') }
	elsif ($f =~ /\.(?:la)?tex$/i)  { $self->set_style('tex') }
	elsif ($f =~ /\.java$/i)        { $self->set_style('java') }
	elsif ($f =~ /^[Mm]akefile/)    { $self->set_style('makefile') }
	elsif ($f =~ /\.ps$/i)          { $self->set_style('ps') }
	elsif ($f =~ /\.py$/i)          { $self->set_style('python') }
	else { $self->set_style('perl') }
      }
    }
    return;
  }

  my $s = shift;
  if ($s eq 'latex' or $s eq 'TeX') {	$s = 'tex' }
  if (defined $self->{Style} and $s eq $self->{Style}) { return }

  # default
  $self->clearStyle();
  $self->{'LineComment'} = '#';
  $self->{'IgnoreOuter'} = '';
  $self->{OutDelimiters} = [ "#", "+\n", "#", "-" ];
  $self->{hook}= [
      {ht=>'be', begin => '# '!>', f => \&evaluate },
      {ht=>'be', begin => ' '!>', f => \&evaluate },
      {ht=>'be', begin => ' '?>', f => \&evaluate }
    ];
    $self->{CodePreparation} = 's/\\n(?:#|%|\/\/+)/\\n/g';

    # Used for Python and Makefile with &evaluate_py1
    my $re_py1 = qr/([\ \t]*)\#(\ *<\?)([\000-\377]*?)!>/x;
    # extension below was a bug for ...#+...#-
    # ([\ \t]*\#+\n[\000-\377]*?\n[\ \t]*\#-\n)?/x;

    if ($s eq 'perl') { }
    elsif ($s eq 'makefile') {
      $self->{hook} = [ ];
      $self->addHook($re_py1, \&evaluate_py1);
      $self->{CodePreparation} = 's/\\n\\s*#/\\n/g';
    }
    elsif ($s eq 'python') {
      $self->{hook} = [ ];
      $self->addHook($re_py1, \&evaluate_py1);
      $self->{CodePreparation} = 's/\\n\\s*#/\\n/g';
    }
    elsif ($s eq 'java') {
      $self->{LineComment} = '//';
      $self->{OutDelimiters} = [ "//", "+\n", "//", "-" ];
      $self->{hook} = [{begin => '// '!>', f => \&evaluate },
		       {begin => ' '!>', f => \&evaluate }];
      $self->{CodePreparation} = 's/^\s*\/\/+//mg';
    }
    elsif ($s eq 'tex') {
      $self->{LineComment} = '%';
      # change OutDelimiters ?
      # $self->{OutDelimiters} = [ "%", "+\n", "%", "-\n" ];
      $self->{OutDelimiters} = [ "%", "+\n", "\n%", "-\n" ];
      $self->{hook}=[{ht=>'be', begin => '% "!>\n", f => \&evaluate },
		     # change to this one?
		     #{ht=>'be', begin => '% "!>", f => \&evaluate },
		     {ht=>'be', begin => ' "!>\n", f => \&evaluate },
		     {ht=>'be', begin => ' "!>", f => \&evaluate }];

      $self->{CodePreparation} = 's/^[ \t]*%//mg';
    }
    elsif ($s eq 'html.sfish') {
      undef $self->{LineComment};
      $self->{OutDelimiters} = [ "", "" ];
      $self->{hook}=[
        {ht=>'be', begin=>'', f => \&evaluate },
        {ht=>'be', begin=>''?>', f=>\&evaluate },
        {begin=>qr/<\?sf\s/, end=>qr/!>/, f=>\&evaluate },
      ];
      $self->addHook(qr/^#.*\n/m, 'comment');
      $self->{CodePreparation} = '';
    }
    elsif ($s eq 'html') {
      undef $self->{LineComment}; # Changes
      $self->{OutDelimiters} = [ "", "" ];
      $self->{hook}=[
	{ht=>'be', begin => '', f => \&evaluate },
	{ht=>'be', begin=>''?>', f=>\&evaluate } ];
      $self->{CodePreparation} = '';
    }
    elsif ($s eq 'ps') {
      $self->{LineComment} = '%';
      $self->{OutDelimiters} = [ "% ", "+\n", "% ", "-" ];
      $self->{hook}=[
         {ht=>'be', begin => ' '!>', f => \&evaluate }];
      $self->{CodePreparation} = 's/\\n%/\\n/g';
    }
    else { _croak("set_style:unknown style:$s") }
    $self->{Style} = $s;
}

# to be deprecated?  Used only to make it available in name space
sub sfish_add_tag($$)     { $::Star->add_tag(@_) }
sub sfish_ignore_outer    { $::Star->ignore_outer(@_) }

# adds tags such as %slide:.* and % by adding appropriate hooks
# eg: add_tag('slide', 'ignore')
# eg: add_tag('sl,l',  'echo')
sub add_tag {
  my $self = shift;
  if (ref($self) ne 'Text::Starfish')
  { unshift @_, $self; $self = $::Star; }
  my $tag = shift; my $fun = shift;
  my $lc = $self->{LineComment};
  #die "tag=($tag) fun=($fun) ref(fun)=".ref($fun);
  if (ref($fun) eq '') {
    if    ( $fun eq 'ignore') { $fun = sub{''} }
    elsif ( $fun eq 'echo') { $fun = sub{$_[2]} }
  }
  my $lc1 = ($lc eq '') ? $lc : "$lc?";
  $self->addHook(qr/$lc1<$tag>\n?((?:.|\n)*?)$lc1<\/$tag>\n?/, $fun);
  $self->addHook(qr/$lc$tag:(.*\n)/, $fun);
}

sub ignore_outer {
  my $self = shift;
  if (ref($self) ne 'Text::Starfish')
  { unshift @_, $self; $self = $::Star; }
  my $newignoreouter = 1;
  $newignoreouter = $_[1] if $#_ > 0;
  $self->{IgnoreOuter} = $newignoreouter;
}

sub set_out_delimiters {
  my $self = shift;
  if (ref($self) ne 'Text::Starfish')
  { unshift @_, $self; $self = $::Star; }
  _croak("OutDelimiters must be array of 4 elements:(@_)") if scalar(@_)!=4;
  $self->{OutDelimiters} = [ $_[0], $_[1], $_[2], $_[3] ]; }

sub add_hook {
  my $self = shift;
  if (ref($self) ne 'Text::Starfish')
  { unshift @_, $self; $self = $::Star; }

  my $ht = shift;
  my $hooks = $self->{hook}; my $hook = { ht=>$ht };
  if ($ht eq 'regex') {
    my $regex=shift; my $replace = shift;
    $hook->{regex} = $regex;
    if (ref($replace) eq '' && $replace eq 'comment')
    { $hook->{replace} = \&repl_comment }
    elsif (ref($replace) eq 'CODE')
    { $hook->{replace} = $replace }
    else { _croak("add_hook, undefined regex format input ".
		  "(TODO?): ref regex(".ref($regex).
		  "), ref replace(".ref($replace).")" ) }
    push @{$hooks}, $hook;
  } elsif ($ht eq 'be') {
    my $b = shift; my $e = shift; my $f='default';
    if ($#_>-1) { $f = shift }
    $self->addHook($b, $e, $f);
  } else { _croak("add_hook error, unknown hook type `$ht'") }
}

# addHook is deprecated.  Use add_hook, which contains the hook type
# as the second argument, after $self.
sub addHook {
    my $self = shift;
    my @Hook = @{ $self->{hook} };

    if ($#_ == 2) {
	my $p = shift; my $s=shift; my $fun=shift;
	if ($fun eq 'default')
	{ push @Hook, {begin=>$p, end=>$s, f=>\&evaluate} }
	elsif ($fun eq 'ignore')
	{ push @Hook, {begin=>$p, end=>$s, f=>\&eval_ignore} }
	elsif ($fun eq 'echo')
	{ push @Hook, {begin=>$p, end=>$s, f=>\&eval_echo} }
	elsif (ref($fun) eq 'CODE') {
	    push @Hook, {begin=>$p, end=>$s,
			 f=> sub { local $_; my $self=shift;
				   my $p=shift; $_=shift; my $s=shift;
				   &$fun($p,$_,$s);
				   if ($self->{REPLACE}) { return $_ }
				   return "$p$_$s";
			       }
		     };
	}
	else {
	    eval("push \@Hook, {begin=>\$p, end=>\$s,".
		 "f=>sub{\n".
		 "local \$_;\n".
		 "my \$self = shift;\n".
		 "my \$p = shift; \$_ = shift; my \$s = shift;\n".
		 "$fun;\n".
		 'if ($self->{REPLACE}) { return $_ }'."\n".
		 "return \"\$p\$_\$s\"; } };");
	}
	_croak("addHook error:$@") if $@;
    } elsif ($#_ == 1 and ref($_[0]) eq 'Regexp') { #regex hook
        my $regex=shift; my $replace = shift;
        if (ref($replace) eq '' && $replace eq 'comment')
	{ push @Hook, {regex=>$regex, replace=>\&repl_comment} }
	elsif (ref($replace) eq 'CODE')
	{ push @Hook, {regex=>$regex, replace=>$replace} }
	else { _croak("addHook, undefined regex format input ".
	              "(TODO?): ".ref($regex).", ".ref($replace)
		      ) }
    } else { _croak("addHook parameter error") }

    $self->{hook} = \@Hook;
}

sub rm_hook {
  my $self = shift;
  if (ref($self) ne 'Text::Starfish')
  { unshift @_, $self; $self = $::Star; }

  my $ht = shift; # hook type: be (begin-end)
  if ($ht eq 'be') {
    my $b=shift; my $e=shift;
    my @Hooks = @{ $self->{hook} }; my @Hooks1;
    foreach my $h (@Hooks) {
      if ($h->{begin} eq $b and $h->{end} eq $e) {}
      else { push @Hooks1, $h }
    }
    $self->{hook} = \@Hooks1;
  } else {
    _croak("rm_hook not implemented for type ht=($ht)") }
}

# rmHook to be deprecated.  Needs to be replaced with rm_hook
sub rmHook {
    my $self = shift;
    my $p = shift;
    my $s = shift;
    $self->rm_hook('be', $p, $s); return; }

sub rmAllHooks {
    my $self = shift;
    $self->{hook} = [];
}

sub resetHooks { my $self = shift; $self->rmAllHooks(); $self->set_style(); }

sub add_final {
  my $self = shift;
  my $f = shift; die "$f not a function" unless ref($f) eq 'CODE';
  if (!defined($self->{Final})) { $self->{Final} = [] }
  push @{ $self->{Final} }, $f;
}

sub defineMacros {
    my $self = shift;

    return if $self->{CurrentLoop} > 1;
    $self->{Loops} = 2 if $self->{Loops} < 2;
    $self->{MprefDefine} = '//define ';
    $self->{MsufDefine} = "//enddefine\n";
    $self->{MprefExpand} = '//expand ';
    $self->{MsufExpand} = "\n";
    $self->{MacroKey}->{'expand'}   = '//m!expand ';
    $self->{MacroKey}->{'/expand'} = "\n";
    $self->{MacroKey}->{'expanded'}  = '//m!expanded ';
    $self->{MacroKey}->{'/expanded'} = "//m!end\n";
    $self->{MpreffExpand} = '//fexpand ';
    $self->{MsuffExpand} = "\n";
    $self->{MacroKey}->{'fexpand'}   = '//m!fexpand ';
    $self->{MacroKey}->{'/fexpand'} = "\n";
    $self->{MprefExpanded} = '//expanded ';
    $self->{MsufExpanded} = "//endexpanded\n";
    $self->{MpreffExpanded} = '//fexpanded ';
    $self->{MsuffExpanded} = "//endexpanded\n";
    $self->{MacroKey}->{'fexpanded'}  = '//m!fexpanded ';
    $self->{MacroKey}->{'/fexpanded'} = "//m!end\n";
    $self->{MprefAuxDefine}='//auxdefine ';
    $self->{MsufAuxDefine}="//endauxdefine\n";
    $self->{MacroKey}->{'auxdefine'}='//m!auxdefine ';
    $self->{MacroKey}->{'/auxdefine'}="//m!endauxdefine\n";
    $self->{MacroKey}->{'define'} = '//m!define ';
    $self->{MacroKey}->{'/define'} = "//m!end\n";
    $self->{MacroKey}->{'defe'} = '//m!defe ';
    $self->{MacroKey}->{'/defe'} = "//m!end\n";
    $self->{MacroKey}->{'newdefe'} = '//m!newdefe ';
    $self->{MacroKey}->{'/newdefe'} = "//m!end\n";
    push @{$self->{hook}},
    {begin=>$self->{MprefDefine},    end=>$self->{MsufDefine}, f=>\&define},
    {begin=>$self->{MprefExpand},    end=>$self->{MsufExpand}, f=>\&expand},
    {begin=>$self->{MpreffExpand},   end=>$self->{MsuffExpand}, f=>\&fexpand},
    {begin=>$self->{MprefExpanded},  end=>$self->{MsufExpanded}, f=>\&expanded},
    {begin=>$self->{MpreffExpanded},
     end=>$self->{MsuffExpanded},f=>\&fexpanded},
    {begin=>$self->{MprefAuxDefine},
      end=>$self->{MsufAuxDefine},f=>\&auxDefine},
    {begin=>$self->{MacroKey}->{'auxdefine'},
      end=>$self->{MacroKey}->{'/auxdefine'},f=>\&MCauxdefine},
    {begin=>$self->{MacroKey}->{'define'},
      end=>$self->{MacroKey}->{'/define'},  f=>\&MCdefine},
    {begin=>$self->{MacroKey}->{'expand'},
      end=>$self->{MacroKey}->{'/expand'},  f=>\&MCexpand},
    {begin=>$self->{MacroKey}->{'fexpand'},
      end=>$self->{MacroKey}->{'/fexpand'}, f=>\&MCfexpand},
    {begin=>$self->{MacroKey}->{'expanded'},
      end=>$self->{MacroKey}->{'/expanded'},f=>\&MCexpanded},
    {begin=>$self->{MacroKey}->{'fexpanded'},
      end=>$self->{MacroKey}->{'/fexpanded'},f=>\&MCfexpanded},
    {begin=>$self->{MacroKey}->{'defe'},
      end=>$self->{MacroKey}->{'/defe'},    f=>\&MCdefe},
    {begin=>$self->{MacroKey}->{'newdefe'},
      end=>$self->{MacroKey}->{'/newdefe'}, f=>\&MCnewdefe};
    $self->{macrosdefined} = 1;
}

sub getmakefilelist ($$) {
    my $f = getfile($_[0]); shift;
    my $l = shift;
    $f =~ /\b$l=(.*(?:(?<=\\)\n.*)*)/ or
	die "starfish:getmakefilelist:no list:$l";
    $f=$1; $f=~s/\\\n/ /g;
    $f =~ s/^\s+//; $f =~ s/\s+$//;
    return split(/\s+/, $f);
}

# Should be used for example
# e.g. addHookUnComment("\n%Dbegin", "\n%Dend");
#sub addHookUnComment {
#    my $t1 = shift;
#    my $t2 = shift;
#    addHook($t1, $t2, 's/\n%!/\n/g');
#}
#
#sub addHookComment {
#    my $t1 = shift;
#    my $t2 = shift;
#    addHook($t1, $t2, 's/\n(?:%!)?/\n%!/g');
#}

sub echo(@) { $::O .= join('', @_) }

# used in LaTeX mode to include verbatim textual files
sub get_verbatim_file {
    my $f = shift;
    return "\\begin{verbatim}\n".
	   untabify(scalar(getfile($f))).
	   "\\end{verbatim}\n";
}

sub untabify {
    local $_ = shift;
    my ($r, $l);
    while (/[\t\n]/) {
	if ($& eq "\n") { $r.="$l$`\n"; $l=''; $_ = $'; }
	else {
	    $l .= $`;
	    $l .= ' ' x (8 - (length($l) & 7));
	    $_ = $';
	}
    }
    return $r.$l.$_;
}

sub getfile($) {
    my $f = shift;
    local *F;
    open(F, "<$f") or die "starfish:getfile:cannot open $f:$!";
    my @r = ;
    close(F);
    return wantarray ? @r : join ('', @r);
}

sub putfile($@) {
    my $f = shift;
    local *F;
    open(F, ">$f") or die "starfish:putfile:cannot open $f:$!";
    print F '' unless @_;
    while (@_) { print F shift(@_) }
    close(F);
}

sub appendfile($@) {
    my $f = shift;
    local *F;
    open(F, ">>$f") or die "starfish:appendfile:cannot open $f:$!";
    print F '' unless @_;
    while (@_) { print F shift(@_) }
    close(F);
}

sub htmlquote($) {
    local $_ = shift;
    s/&/&/g;
    s/
    s/\"/"/g;
    return $_;
}

sub read_records($ ) {
  my $arg = shift;
  if ($arg =~ /^file=/) {
    my $f = $'; local *F; open(F, $f) or croak "cannot open $f:$!";
    $arg = join('', );
    close(F);
  }

  my $db = [];
  while ($arg) {
    if ($arg =~ /^([ \t\r]*(#.*)?\n)+/) { $arg = $'; }
    last if $arg eq ''; my $record;
    if ($arg =~ /([ \t\r]*\n){2,}/) { $record = "$`\n"; $arg = $'; }
    else { $record = $arg; $arg = ''; }
    my $r = {}; my $recordsave = $record;
    while ($record) {
      if ($record =~ /^[ \t]*#.*\n/) { $record=$'; next; } # allow
                                                   # comments in records
      $record =~ /^[ \t]*([^\n:]*?)[ \t]*:/ or
	croak "db8: no attribute in record: ($recordsave)";
      my $k = $1; $record = $'; my $v;
      croak "empty key in ($recordsave)" if $k eq '';
      while (1) {		# .................... line continuation
	if ($record =~ /^(.*?)\\(\r?\n)/) { $v .= $1.$2; $record = $'; }
	elsif ($record =~ /^.*?\r?\n[ \t]/) { $v .= $&; $record = $'; }
	elsif ($record =~ /^(.*?)\r?\n/) { $v .= $1; $record = $'; last; }
	else { $v .= $record; $record = ''; last }
      }
      if (exists($r->{$k})) {
	my $c = 0;
	while (exists($r->{"$k-$c"})) { ++$c }
	$k = "$k-$c";
      }
      $r->{$k} = $v;
      }
    push @{ $db }, $r;
  }
  return wantarray ? @{$db} : $db;
}

sub current_year { return POSIX::strftime("%Y", localtime(time)) }

sub last_update() {
    my $self = @_ ? shift : $::Star;
    if ($self->{Loops} < 2) { $self->{Loops} = 2 }
    return POSIX::strftime("%d-%b-%Y", localtime($self->{LastUpdateTime}));
}

sub file_modification_time() {
    my $self = @_ ? shift : $::Star;
    return (stat $self->{INFILE})[9];
}

sub file_modification_date() {
    my $self = @_ ? shift : $::Star;

    my $t = $self->file_modification_time();
    my @a = localtime($t); $a[5] += 1900;
    return qw/January February March April May June July
    	      August September October November December/
		  [$a[4]]." $a[3], $a[5]";
}

sub read_starfish_conf() {
    return unless -e "starfish.conf";
    my @dirs = ( '.' );
    while ( -e "$dirs[0]/../starfish.conf" )
    { unshift @dirs, "$dirs[0]/.." }

    my $currdir = cwd();
    foreach my $d (@dirs) {
	chdir $d or die "cannot chdir to $d";
	package main;
	require "$currdir/$d/starfish.conf";
	package Text::Starfish;
	chdir $currdir or die "cannot chdir to $currdir";
    }
}

sub _croak {
    my $m = shift;
    require Carp;
    Carp::croak($m);
}

# used in makefile mode
#kw:makefile
sub make_add_dirs_to_generate_if_needed {
  for my $d (@_) {
    next if grep { $_ eq $d } @DirGenerateIfNeeded;
    push @DirGenerateIfNeeded, $d;
  } }
sub make_gen_dirs_to_generate {
  foreach my $d (@DirGenerateIfNeeded) {
    echo "$d:; mkdir -p \$\@\n" } }

1;

__END__