#!/usr/bin/perl
# Time-stamp: <2008-03-11 00:32:06 phm>
BEGIN { $ENV{PATH} = '/bin:/usr/bin:/usr/local/bin' };
package A2E::CString;
use strict;
use English -no_match_vars;
umask oct('002');
use utf8;
binmode STDIN, ':utf8';
binmode STDOUT, ':utf8';
binmode STDERR, ':utf8';
use Encode qw(_utf8_on);
use Data::Dumper;

our @deplate_macro_name_chars = (65..90, 97..122, 49..57, 95);
# our @deplate_macro_name_end_chars = (32, ord("\t"), ord("\n"), 58, 125);
our @cjk_blanks = (12288);
our @blanks = (8, 9, 32, @cjk_blanks);
our @latin_quote_chars = (34, 39);
our @latin_closing_chars_non_deplate = (41, 93);
our @latin_closing_chars = (41, 93, 125);
our @latin_opening_chars_non_deplate = (40, 91);
our @latin_opening_chars = (40, 91, 123);
our @cjk_opening_chars = (65288, 12300);
our @cjk_closing_chars = (65289, 12301);
our @closing_chars_non_deplate = (@latin_closing_chars_non_deplate, @cjk_closing_chars);
our @closing_chars = (125, @closing_chars_non_deplate);
our @opening_chars_non_deplate = (@latin_opening_chars_non_deplate, @cjk_opening_chars);
our @opening_chars = (123, @opening_chars_non_deplate);
our %opening_closers = (40 => 41, 91 => 93, 123 => 125, 65288 => 65289, 12300=>12301);
our %closing_openers = (41 => 40, 93 => 90, 125 => 123, 65289 => 65288, 12301=>12300);

our @OPTIONS = qw(p subs sup cjk2asc lookup debug verbose);
our $optvals0 = {
    p => 0,
    subs => [],
    verbose => 0,
    debug => 0,
};
 
sub new {
    my $class = shift;
    my $self = {};
    bless $self, $class;
    $self->{chars} = shift;
    $self->{len} = scalar @{$self->{chars}};
    $self->{pmax} = $#{$self->{chars}};
    $self->{sup} = shift;
    my $optvals = shift;
    for (@OPTIONS) {
	next unless defined $optvals->{$_};
	$self->{$_} = $optvals->{$_};
    };
    for (@OPTIONS) {
	next if defined $self->{$_};
	$self->{$_} = $self->{sup}->{$_};
	next if defined $self->{$_};
	$self->{$_} = $optvals0->{$_};
	next if defined $self->{$_};
	return $self->error( { prog => 1 }, "undefined parameter $_");
    };
    $self->{closers} = [];
    $self->{openers} = [];
    $self->string;
    return $self;
};

sub reset {
    my $self = shift;
    @{$self->{chars}} = @_;
    $self->{len} = scalar @{$self->{chars}};
    $self->{pmax} = $#{$self->{chars}};
    $self->{p} = 0;
    @{$self->{openers}} = (); 
    @{$self->{closers}} = (); 
    undef $self->{error};
    $self->string;
};

sub parse {
    my $self = shift;
    # nothing to do in generic class;
};

sub echo {
    my $self = shift;
    my $flag = shift;
    return unless $flag;
    map { _utf8_on $_ } @_;
    my $s = shift;
    $s = sprintf $s, @_ if @_;
    print STDERR $s, "\n";
    return $s;
};

sub vecho {
    my $self = shift;
    $self->echo($self->{verbose}, @_);
};
sub decho {
    my $self = shift;
    $self->echo($self->{debug}, @_);
};

sub read_sexp {
    # read a syntacting expression (sexp) from a string
    # read from left to right, see read_sexp_to_left for the inverse
    # return length of source string and resulting sexp;
    # return nothing if no sexp was found;
    # leave $self->{p} wherever the search ends, whether successful or not
    # keep track of remaining open brackets with $self->{closers}
    my $self = shift;
    my $p0 = shift;
    my $pd = 0;
    my $sd = '';
    $self->{p} = $p0 if $p0;
    $p0 = $self->{p};
    $self->decho("start read_sexp from $self->{p} in $self->{string}");
    my $ch = $self->{chars}->[$self->{p}];
    my $chr = chr $ch; # for debugging only

  UNSEXPY: {
      last if grep { $_ == $ch } @opening_chars;
      $self->decho("unsexpy: a sexp can not start with $chr");
      $self->decho("from read_sexp unsexpily return");
      return;
  };
    $self->decho("read_sexp starts with opening $chr $ch");
    my $closer = $opening_closers{$ch};
    unshift @{$self->{closers}}, $closer;
    my $closers = join ', ', @{$self->{closers}}; # for debugging only
  CHAR: while ($self->{p}++ < $self->{len}) { 
      $ch = $self->{chars}->[$self->{p}];
      $chr = chr $ch; # for debugging only
    OPENING: { 
	last unless  grep { $_ == $ch } @opening_chars;
	$closer = $opening_closers{$ch};
	$self->decho("read_sexp opening: found opening $chr $ch at $self->{p}, unshift $closer to closers $closers");
	unshift @{$self->{closers}}, $closer;
	$closers = join ', ', @{$self->{closers}}; # for debugging only
	next CHAR;
    };
    CLOSING: {
	last unless grep { $_ == $ch } @closing_chars;
	$self->decho("read_sexp closing: found closing $ch $chr at $self->{p}, shift from closers $closers?");
      MISMATCH: {
	  last if $ch == $self->{closers}->[0];
	  $self->decho("read_sexp mismatch: no, it doesn't match");
	  $self->decho("from read_sexp mismatchedly return");
	  return;
      };
	$self->decho("read_sexp closing: yes, it matches");
	shift @{$self->{closers}};
	$closers = join ', ', @{$self->{closers}}; # for debugging only
	next CHAR if @{$self->{closers}};
	$sd = pack 'U*', @{$self->{chars}}[$p0..$self->{p}];
	$pd = $self->{p} - $p0 + 1;
	$self->decho("from read_sexp successfully return $pd, $sd");
	return $pd, $sd;
    }; #CLOSING 
  };
    my $n = scalar @{$self->{closers}}; # for debugging only
    $self->decho("from read_sexp final-failingly return with $n closers open");
    return;
};

sub read_sexp_to_left {
    # read from right to left to catch a bracketted expression (sexp)
    # return length of source string used and resulting sexp;
    # return nothing if no sexp was found;
    # leave $self->{p} wherever the search ends, whether successful or not
    # keep track of remaining open brackets with $self->{openers}
    my $self = shift;
    my $p0 = shift;
    my $sd = '';
    my $pd = 0;
    $self->{p} = $p0 if $p0;
    $p0 = $self->{p}; 
    $self->decho("start read_sexp_to_left from $self->{p} in $self->{string}");
    my $sexp = '';
    my $ch = $self->{chars}->[$self->{p}];
    my $chr = chr $ch;

  UNSEXPY: {
      last if grep { $_ == $ch } @closing_chars;
      $self->decho("a sexp can not end with $chr");
      $self->decho("from read_sexp_to_left unsexpily return");
      return;
  };
    my $opener = $closing_openers{$ch};
    unshift @{$self->{openers}}, $opener;
    my $openers = join ', ', @{$self->{openers}}; # for debugging only
  CHAR: while ($self->{p}-- >= 0) {
      $ch = $self->{chars}->[$self->{p}];
      $chr = chr $ch; # for debugging only
    CLOSING: {
	last unless grep { $_ == $ch } @closing_chars;
	$opener = $closing_openers{$ch};
	$self->decho("found closing $ch $chr at $self->{p}, unshift $opener to openers $openers"); 
	unshift @{$self->{openers}}, $opener;
	$openers = join ', ', @{$self->{openers}}; # for debugging only
	next CHAR;
    };
    OPENING: {
	last unless grep { $_ == $ch } @opening_chars;
	$self->decho("found opening $chr $ch at $self->{p}, shift from openers $openers?");
      MISMATCH: {
	  last if $ch == $self->{openers}->[0];
	  $self->decho("no, it doesn't match.");
	  $self->decho("from read_sexp_to_left mismatchedly return");
	  return;
      };
	$self->decho("yes, it matches");
	shift @{$self->{openers}};
	$openers = join ', ', @{$self->{openers}}; # for debugging only
	next CHAR if @{$self->{openers}};
	$sd = pack 'U*', @{$self->{chars}}[$self->{p}..$p0];
	$pd = $p0 - $self->{p} + 1;
	$self->decho("from read_sexp successfully return $pd, $sd");
	return $pd, $sd;
    }; # OPENING
  };
    my $n = scalar @{$self->{openers}}; # for debugging only
    $self->decho("from read_sexp final-failingly return with $n openers unclosed");
    return;
};

sub error {
    my $self = shift;
    my $typ = shift;
    my $msg = shift;
    my $s0 = $self->string;
    my $ch = $self->{chars}->[$self->{p}];
    my $chr = chr $ch;
    $msg = join ' ', "CString error:", $msg, "at p $self->{p} ch $ch chr $chr in $s0"; 
    $self->{error} = { typ => $typ, msg=>$msg };
};

sub string {
    my $self = shift;
    $self->{string} = pack 'U*', @{$self->{chars}};
    return $self->{string}
};

sub non_escaped {
    # whether the current char is the one in the argument without a backslash escape before it
    my $self = shift;
    my $ch = shift;
    return ($self->{chars}->[$self->{p}] == $ch) and (not $self->{chars}->[$self->{p}-1] == 92);
};

sub read_deplate_attrs {
    # return
    #  1. pos where attribute section of deplate macro ends by a colon character
    #  2. arrayref of names and values of attrs (attributes) that were found
    # check validity and skip colons that are protected withing quoted strings
    my $self = shift;
    my $ch = 0;
    my $chr = '';
    my $p0 = $self->{p};
    my $pa = 0;
    my $pd = 0;
    my %END_OK;
    my $attrs = {};
    $self->decho("start read_deplate_attrs at $self->{p} in $self->{string}");
  ATTR_CHAR: while ($self->{p} < $self->{len}) {
      $ch = $self->{chars}->[$self->{p}];
      $chr = chr $ch;
      $self->decho("deplate_attrs char $ch $chr at $self->{p}");
      $END_OK{ATTR_CHAR} = grep { $_ == $ch } (58, 125);
      last ATTR_CHAR if $END_OK{ATTR_CHAR};
      if ($ch == 32) {
	  $self->{p}++;
	  next ATTR_CHAR;
      };
    ATTR_KEYVAL: {
	last unless grep { $_ == $ch } @deplate_macro_name_chars;
	$pa = $self->{p};
	$self->decho("read_attrs found attr_keyval at $chr $self->{p}");
	my ($key, $val) = ();
      ATTR_KEY_CHAR: while ($self->{p}++ < $self->{len}) {
	  $ch = $self->{chars}->[$self->{p}];
	  $END_OK{ATTR_KEY_CHAR} = $ch == 61; # equal sign ends attribute name
	  last if $END_OK{ATTR_KEY_CHAR};
      };
	$chr = chr $ch;
	$key = pack 'U*', @{$self->{chars}}[$pa..$self->{p}-1];
	$self->decho("read_attrs attr_keyval found key $key at $self->{p} ending with $chr");
	return $self->error({ user => 1 }, "deplate macro attribute name did not end in equal sign") unless $END_OK{ATTR_KEY_CHAR};
	
      GO_BEYOND_EQUAL: {
	  $self->{p}++;
	  $ch = $self->{chars}->[$self->{p}];
	  $chr = chr $ch; 
      };
      ATTR_VAL_CHAR: {
	  $self->decho("read_attrs start attr_val_char at $chr $self->{p}");
	  $pa = $self->{p};
	QUOTED: {
	    last unless grep { $_ == $ch } @latin_quote_chars;
	    $self->decho("read_attrs quoted attr_val_char at $chr $self->{p}");
	    $pa++;
	  QUOTED_CHAR: while ($self->{p}++ < $self->{len}) {
	      $END_OK{QUOTED_CHAR} = $self->non_escaped($ch);
	      last QUOTED_CHAR if $END_OK{QUOTED_CHAR};
	  };
	    $ch = $self->{chars}->[$self->{p}];
	    $chr = chr $ch;
	    $self->decho("read_attrs quoted_char ends with $ch $chr at $self->{p}");
	    return $self->error({ user => 1 }, "argument value began with $chr but did not so end") unless $END_OK{QUOTED_CHAR};
	  SET_ATTR_VAL: { # without escape chars
	      my @valchars = ();
	      my @srcchars = @{$self->{chars}}[$pa..$self->{p}-1];
	      foreach my $i (0..$#srcchars) {
		  # $chr = chr $srcchars[$i];
		  # $self->decho("read_attrs set_attr_val srcchar $i $chr");
		  next if $srcchars[$i] == 92 and $srcchars[$i+1] != 92;
		  push @valchars, $srcchars[$i]; 
	      };
	      $val = pack 'U*', @valchars;
	  };
	    $self->decho("read_attrs quoted attr_val_char found $val ending at $self->{p}");
	    $self->{p}++;
	    last ATTR_VAL_CHAR;
	};
	  $self->decho("read_attrs start non_blank_attr_val_char at $chr $self->{p}");
	NON_BLANK_ATTR_VAL_CHAR: while ($self->{p}++ < $self->{len}) {
	    $ch = $self->{chars}->[$self->{p}];
	    return $self->error({ user => 1 }, "quote character found in non-quoted attribute value") if grep { $_ == $ch } @latin_quote_chars;
	    $END_OK{NON_BLANK_ATTR_VAL_CHAR} = grep { $_ == $ch } (58, 125), @blanks;
	    last if $END_OK{NON_BLANK_ATTR_VAL_CHAR};
	};
	  $val = pack 'U*', @{$self->{chars}}[$pa..$self->{p}-1];
	  $chr = chr $ch;
	  $self->decho("read_attrs end non_blank_attr_val_char at $chr $self->{p}");
	  return $self->error({ user => 1}, "argument value did not end properly") unless $END_OK{NON_BLANK_ATTR_VAL_CHAR};
      };
	if ($key and length($val) > 0) {
	    $attrs->{$key} = $val;
	} else {
	    return $self->error({ user => 1 }, "read_attrs keyval section finished without obtaining a key $key and val $val");
	};
	next ATTR_CHAR;
    };
      return $self->error({ user => 1}, "invalid character in attributes section of macro");
  };
    return $self->error({ prog => 1 }, "read_deplate_attrs section attr_char did not end properly") unless $END_OK{ATTR_CHAR};
    $pd = $self->{p} - $p0;
    my $attrs_str = join ', ', map { join ': ', $_, $attrs->{$_} } keys %$attrs;
    $self->decho("from read_deplate_attrs return $pd and attrs $attrs_str");
    return $pd, $attrs;
};

sub escape_char {
    my $self = shift;
    my $ch = shift;
    my @c2 = ();
    while ($self->{p} < $self->{len}) {
	push @c2, 92 if $self->non_escaped($ch);
	push @c2, $ch;
    } continue { $self->{p}++ };
    @{$self->{chars}} = @c2;
    $self->string;
    return $self->{string};
};

return 1;

# Local Variables:
# coding: utf-8
# url: http://a2e.de/adv/tratext/Tratext.pm
# srcfile:/adv/tratext/CString.pm
# mode: perl
# End:
