package Text::Expand::File;
use strict;
use warnings;
use fields qw(mtime dev ino file machine);
use vars qw($cur_file $cur_index $cur_loops %cur_levels $cur_collect);

use Tie::Cacher;
use Cwd qw(abs_path getcwd);
use URI::Escape;
use HTML::Entities;
use Carp;

our $VERSION = 0.02;

*isa = \&UNIVERSAL::isa;

use constant {
    TEXT	=> 1,
    LOOP	=> 2,
    IF		=> 3,
    UNLESS	=> 4,
    VAR		=> 5,
    INCLUDE	=> 6,

    SINGLE	=> 1,	# No more than 1
    MULTIPLE	=> 0,	# 0 or more
    TRUE	=> 2,	# Ignore any tags whose value is false
    DEFINED	=> 8,	# Must have a value
    MANDATORY	=> 256,	# Must be given
};

my %tags =
    (loop	=> { name => SINGLE | MANDATORY,
                     sort => MULTIPLE,
                     context => SINGLE},
     var	=> { name => SINGLE | MANDATORY,
                     context => SINGLE,
                     escape => MULTIPLE | TRUE},
     include	=> { name => SINGLE | MANDATORY,
                     context => SINGLE },
     if		=> { name => SINGLE | MANDATORY ,
                     context => SINGLE },
     unless	=> { name => SINGLE | MANDATORY,
                     context => SINGLE },
     else	=> { name  => SINGLE | MANDATORY },
     comment	=> { text => SINGLE },
     );

my %cache;
tie (%cache, "Tie::Cacher",
     validate => sub {
         my __PACKAGE__ $result = $_[2][0];
         my @stat = stat($_[1]) or croak "Could not stat $_[1]: $!";
         # Heuristics for unchanged file
         return $stat[9] == $result->{mtime} && $stat[0] == $result->{dev} &&
             $stat[1] == $result->{ino};
     },
     load => \&parse_file);

sub parse_file {
    local (*FILE, $_);
    local $/ = "\n";
    my $file = canonical($_[1]);

    if ($file eq $_[1]) {
        my __PACKAGE__ $self = [];
        open(FILE, "<", $file) || die "Could not open $file: $!\n";
        my @stat = stat(FILE) or croak "Could not stat open file $file: $!";
        ($self->{machine}, my $text) = parse_text(\*FILE, $file, "", 0);
        push(@{$self->{machine}}, TEXT, $text) if $text ne "";
        $self->{mtime} = $stat[9];
        $self->{dev}   = $stat[0];
        $self->{ino}   = $stat[1];
        $self->{file}  = $file;
        $_[2][0] = bless $self;
    } else {
        $_[2][0] = $cache{$file};
    }
}

sub canonical {
    my ($dir, $file) = $_[0] =~ /^(.*\/)([^\/]+)\z/s or
        croak "Cannot parse $_[0] into directory and file";
    my $ndir = abs_path($dir);
    defined($ndir) && $ndir ne "" ||
        croak "Cannot find absolute directory for $dir. It probably does not exist";
    $ndir =~ s|/*\z|/|;
    return "$ndir$file";
}

sub new {
    my ($class, $file, $cache) = @_;
    $class = ref($class) || $class;
    croak "$class->new needs a non empty file argument" unless
        defined($file) && $file ne "";
    if (substr($file, 0, 1) ne "/") {
        # relative path
        my $dir = getcwd();
        $dir =~ s|/*\z|/|;
        $file = "$dir$file";
    }
    croak "$class->new does currently not support non-caching" unless $cache;
    croak "$class->new called with an undefined filename argument" unless
        defined($file);
    return $cache{$file};
}

sub parse_text {
    my ($fh, $file, $stop, $stop_line, @parts) = @_;
    my @machine;
    my $text = "";
    while (1) {
        while (@parts) {
            # at this point @parts should consist of:
            # 1 text
            # end of array or
            # 2 empty or / (representing <tmpl_> or </tmpl_>
            # 3 the thing directly after the tmpl_ (eg var, if, loop)
            # end of array or
            # 4 all tags e.g: name=boem special zoem= escape="html"
            # end of array or goto 1
            my $type = shift(@parts);
            push(@machine, TEXT, $text . $type) if $text ne "" || $type ne "";
            last unless @parts;
            my $not  = shift(@parts);
            $type = lc(shift(@parts));
            $parts[0] = "" unless defined($parts[0]);
            my @tags = shift(@parts) =~ /\s+(\w+)(?:=(\w*(?:"[^\"]*"|'[^\']'\w*)*))?/g;
            if ($not) {
                die "Cannot handle tags for </TMPL_$type> on line $. of $file\n" if @tags;
                die("Closing </TMPL_$type> while expecting text or ",
                    ($stop ? "</TMPL_$stop> (started on line $stop_line)" : 
                     "EOF"), " on line $. of $file\n") unless $stop eq $type;
                return (\@machine, @parts);
            } elsif ($type eq "else") {
                die "Cannot handle tags for <TMPL_$type> on line $. of $file\n"
                    if @tags;
                die "<TMPL_$type> is only valid during an IF or UNLESS on line $. of $file\n" unless $stop eq "if" || $stop eq "unless";
                return (undef, \@machine, @parts);
            }
            defined(my $allowed = $tags{$type}) ||
                die "Unknown <TMPL_$type> on line $. of $file\n";
            my %seen;
            while (defined(my $tag = shift(@tags))) {
                $tag = lc($tag);
                die "Invalid tag $tag for <TMPL_$type> on line $. of $file\n"
                    unless defined(my $tag_type = $allowed->{$tag});
                if (defined($text = shift(@tags))) {
                    # escape stuff
                    $text =~ s/("[^\"]*"|'[^\']*')/substr($1, 1, length($1)-2)/eg;
                } elsif ($tag_type & DEFINED) {
                    die "Tag $tag must define a value for <TMPL_$type> on line $. of $file\n";
                }
                if ($tag_type & SINGLE) {
                    die "Multiple $tag tags for <TMPL_$type> on line $. of $file\n" if exists $seen{$tag};
                    $seen{$tag} = $text;
                } elsif (!($tag_type & TRUE) || $text) {
                    # MULTIPLE
                    push(@{$seen{$tag}}, $text);
                }
            }
            for (keys %{$allowed}) {
                if ($allowed->{$_} & MANDATORY) {
                    die "Mandatory tag $_ missing for <TMPL_$type> on line $. of $file\n" unless exists $seen{$_};
                } elsif (!($allowed->{$_} & SINGLE)) {
                    # make an undef into an empty ARRAY
                    $seen{$_} ||= [];
                }
            }
            $seen{context} = "" unless defined $seen{context};
            if ($type eq "var") {
                push(@machine, VAR, $., $seen{context}, $seen{name},
                     $seen{escape});
            } elsif ($type eq "comment") {
                # Do absolutely nothing
            } elsif ($type eq "loop") {
                push(@machine, LOOP, $.);
                ($text, @parts) = parse_text($fh, $file, $type, $., @parts);
                push(@machine, $seen{context}, $seen{name}, $seen{sort}, $text);
            } elsif ($type eq "if") {
                push(@machine, IF, $., $seen{context}, $seen{name});
                ($text, @parts) = parse_text($fh, $file, $type, $., @parts);
                if (defined($text)) {
                    # IF without ELSE
                    push(@machine, $text, undef);
                } else {
                    push(@machine, shift(@parts));
                    ($text, @parts) = parse_text($fh, $file, $type, $., @parts);
                    die "Second <TMPL_ELSE> ends on line $. of $file\n" unless
                        defined($text);
                    push(@machine, $text);
                }
            } elsif ($type eq "unless") {
                push(@machine, UNLESS, $., $seen{context}, $seen{name});
                ($text, @parts) = parse_text($fh, $file, $type, $., @parts);
                if (defined($text)) {
                    # UNLESS without ELSE
                    push(@machine, $text, undef);
                } else {
                    push(@machine, shift(@parts));
                    ($text, @parts) = parse_text($fh, $file, $type, $., @parts);
                    die "Second <TMPL_ELSE> ends on line $. of $file\n" unless
                        defined($text);
                    push(@machine, $text);
                }
            } elsif ($type eq "include") {
                die "<TMPL_$type> should mention a non empty name on line $. of $file\n" if $seen{name} eq "";
                push(@machine, INCLUDE, $., $seen{context}, $seen{name});
            } else {
                die "BUG: Unhandled <TMPL_$type> on line $. of $file";
            }
            # print STDERR "type $type, tags ", join(",", @tags), "\n";
            $text = "";
        }
      LINE:
        unless (defined($_ = <$fh>)) {
            die("Unexpected EOF in $file while expecting </TMPL_$stop> (started on line $stop_line)\n") if $stop;
            return (\@machine, $text);
        }
        chomp if eof($fh);
        @parts = split /<(?:!--)?\s*(\/)?TMPL_(\w+)((?:\s+\w+(?:=\w*(?:"[^\"]*"|'[^\']'\w*)*)?)*)(?:\s*--)?>/i;
        if (@parts == 1) {
            $text .= shift(@parts);
            goto LINE;
        }
    }
}

my @iso = ("m", "", "k", "M", "G", "T");
sub pretty_num {
    my $num = shift;
    return "0 " if $num == 0;
    my $sign = "";
    if ($num < 0) {
        $sign = "-";
        $num = -$num;
    }
    my ($exp, $base) = (log($num)/log(10)) =~ /(\d+)(.\d+)?/;
    $base = 0 unless defined($base);
    $base = 10**$base;
    my $factor = int(($exp+300)/3)-100;
    croak "Can't handle numbers smaller than 0.001 (yet)" if $factor < -1;
    $base *= 10**($exp-$factor*3);
    $base = sprintf("%.3f", $base);
    $base =~ s/0*$//;
    $base =~ s/\.$//;
    return "$sign$base $iso[1+$factor]";
}

sub output {
    my __PACKAGE__ $self = shift;
    local $cur_file = $self->{file};
    return do_out(@{$self->{machine}});
}

our %escape =
    (URI  => \&uri_escape,
     URL  => sub {return uri_escape($_[0], '^;?:\@&=+\$,A-Za-z0-9_.!~*\'()-')},
     FORM_URL => sub {
         my $str = $_[0]; 
         $str =~ s/([^\w.-])/$1 eq " " ? "+" : sprintf("%%%02X",ord($1))/eg;
         return $str;
     },
     STRIP=> sub {
         my $str = $_[0];
         $str =~ s/^\s+//;
         $str =~ s/\s+\z//;
         return $str },
     SQUEEZE_SPACE	=> sub {
         my $str = $_[0];
         $str =~ s/\s//g;
         return $str; },
     HTML => \&encode_entities,
     HTML_SINGLE => sub {
         return encode_entities(encode_entities($_[0]), "\n");
     },
     HTML_PRE => sub { 
         my $str = encode_entities($_[0]);
         $str =~ s/ /&nbsp;/g;
         $str =~ s/\n/<BR>\n/g;
         return $str;
     },
     NL2BR	=> sub { 
         my $str = shift;
         $str =~ s/\n/<BR>\n/g; 
         return $str; 
     },
     CRLF2NL	=> sub { my $str = shift; $str =~ s/\x0d\x0a/\n/g; return $str; },
     DEBUG	=> sub { print STDERR "Debug $_[0]\n"; return $_[0] },
     GMTIME	=> sub { return scalar gmtime($_[0]) },
     NUMGMTIME	=> sub { 
         my @when = gmtime($_[0]); 
         return sprintf("%04d/%02d/%02d %02d:%02d:%02d", 
                        $when[5]+1900, $when[4]+1, @when[3,2,1,0]);
     },
     LOCALTIME	=> sub { return scalar localtime($_[0]) },
     EMPTY	=> sub { return "" },
     NON_EMPTY	=> sub { $_[0] eq "" ? "\xa0" : $_[0] },
     GMK	=> \&pretty_num,
     LATINXML	=> sub { 
         my $str = shift; 
         $str =~ s/([<>&\'\"\x00-\x09\x0b-\x1f\x7f-\xa0])/"&#" . ord($1) . ";"/eg; 
         return $str;
     },	# "
     LATINXML_SINGLE	=> sub { 
         my $str = shift; 
         $str =~ s/([<>&\'\"\x00-\x1f\x7f-\xa0])/"&#" . ord($1) . ";"/eg; return $str;
     },	# "
     );

our $vars;
sub do_out {
    local *vars = $cur_levels{""};
    # the elements of the %cur_levels hash should always be freely changeable !
    while (isa($vars, "CODE")) {
        defined($vars = $vars->()) ||
            croak "Expanding variable set returned undef";
    }
    croak "current level is not a HASH, but a " . ref($vars) unless
        isa($vars, "HASH");
    # print STDERR "Vars are ", join(", ", keys %vars), "\n";
    while (my $work = shift) {
        if ($work == TEXT) {
            if (ref($cur_collect)) {
                print $cur_collect shift
            } else {
                $cur_collect .= shift
            }
        } elsif ($work == VAR) {
            my $line  = shift;
            my $context = shift;
            local *vars = $cur_levels{$context} ||
                die "Context '$context' does not exist on line $line of $cur_file\n";
            my $name = shift;
            if (defined($work = $vars->{$name})) {
                if (isa($work, "CODE")) {
                    $work = $work->();
                    croak "Expanding VAR variable $name returned CODE again on line $line of $cur_file" if
                        isa($work, "CODE");
                    unless (ref($vars) eq __PACKAGE__) {
                        my %vars = %{$vars};
                        $vars = bless \%vars;
                    }
                    $vars->{$name} = $work;
                    $work = "" unless defined($work);
                }
            } else {
                exists($vars->{$name}) ||
                    # die("VAR variable '$name' does not exist on line $line of $cur_file (I have " . join(", ", keys %{$vars}) . " and contexts " . join(", ", keys %cur_levels) . ")\n");
                    die "VAR variable '$name' does not exist on line $line of $cur_file\n";
                $work = "";
            }
            for (@{shift(@_)}) {
                # since escape has the TRUE flag, all these will be non empty
                $escape{$_} ||
                    die "Unknown ESCAPE $_ on line $line of $cur_file\n";
                $work = $escape{$_}->($work);
            }
            if (ref($cur_collect)) {
                print $cur_collect $work;
            } else {
                $cur_collect .= $work;
            }
        } elsif ($work == LOOP) {
            my $line = shift;
            my $context = shift;
            local *vars = $cur_levels{$context} ||
                die "Context '$context' does not exist on line $line of $cur_file\n";
            my $name = shift;
            defined($work = $vars->{$name}) ||
                die "LOOP variable '$name' undefined on line $line of $cur_file\n";
            if (isa($work, "CODE")) {
                $work = $work->();
                croak "Expanding LOOP variable $name returned CODE again on line $line of $cur_file" if isa($work, "CODE");
                unless (ref($vars) eq __PACKAGE__) {
                    my %vars = %{$vars};
                    $vars = bless \%vars;
                }
                $vars->{$name} = $work;
                die "LOOP variable '$name' undefined after expansion on line $line of $cur_file\n" unless
                    defined($work);
            }
            isa($work, "ARRAY") ||
                die "LOOP variable '$name' is not an ARRAY reference on line $line of $cur_file\n";
            if (ref($work) ne __PACKAGE__) {
                $work = bless [@{$work}];	# Make a copy to catch changes
                unless (ref($vars) eq __PACKAGE__) {
                    my %vars = %{$vars};
                    $vars = bless \%vars;
                }
                $vars->{$name} = $work;
            }
            local $cur_loops = $cur_loops && @{$work};
            local $cur_index = 0;
            local ($cur_levels{$name}, $cur_levels{""});
            my $sort = shift;
            $work = [sort { $a->{$_} cmp $b->{$_} and return $a->{$_} cmp $b->{$_} for @{$sort}; 0} @{$work}] if @{$sort};
            my $loop = shift;
            for (@{$work}) {
                $cur_levels{""} = $cur_levels{$name} = \$_;
                do_out(@{$loop});
                $cur_index++;
            }
        } elsif ($work == IF) {
            my $line = shift;
            my $context = shift;
            local *vars = $cur_levels{$context} ||
                die "Context '$context' does not exist on line $line of $cur_file\n";
            my $name = shift;
            # We could in fact create a separate type for this --Ton
            if ($cur_loops && $name =~ /^__(?:FIRST|LAST|INNER|ODD|EVEN)__\z/) {
                if ($name eq "__FIRST__") {
                    $work = 0 == $cur_index;
                } elsif ($name eq "__LAST__") {
                    $work = $cur_loops == $cur_index+1;
                } elsif ($name eq "__EVEN__") {
                    $work = $cur_index %2 == 1;
                } elsif ($name eq "__ODD__") {
                    $work = $cur_index %2 == 0;
                } else {
                    $work = $cur_index && $cur_loops != $cur_index+1
                }
            } else {
                if (defined($work = $vars->{$name})) {
                    if (isa($work, "CODE")) {
                        $work = $work->();
                        croak "Expanding IF variable $name returned CODE again on line $line of $cur_file"
                            if isa($work, "CODE");
                        unless (ref($vars) eq __PACKAGE__) {
                            my %vars = %{$vars};
                            $vars = bless \%vars;
                        }
                        $vars->{$name} = $work;
                        $work = "" unless defined($work);
                    }
                } else {
                    #exists($vars->{$name}) ||
                    #    die "IF variable '$name' does not exist on line $line of $cur_file\n";
                    $work = "";
                }
                $work = @{$work} if isa($work, "ARRAY");
            }
            $name = shift;
            if ($work) {
                shift;	# Get rid of ELSE
                unshift(@_, @{$name});
            } elsif ($name = shift) {
                unshift(@_, @{$name});
            }
        } elsif ($work == UNLESS) {
            my $line = shift;
            my $context = shift;
            local *vars = $cur_levels{$context} ||
                die "Context '$context' does not exist on line $line of $cur_file\n";
            my $name = shift;
            if ($cur_loops && $name =~ /^__(?:FIRST|LAST|INNER|ODD|EVEN)__\z/) {
                if ($name eq "__FIRST__") {
                    $work = 0 == $cur_index;
                } elsif ($name eq "__LAST__") {
                    $work = $cur_loops == $cur_index+1;
                } elsif ($name eq "__EVEN__") {
                    $work = $cur_index %2 == 1;
                } elsif ($name eq "__ODD__") {
                    $work = $cur_index %2 == 0;
                } else {
                    $work = $cur_index && $cur_loops != $cur_index+1
                }
            } else {
                if (defined($work = $vars->{$name})) {
                    if (isa($work, "CODE")) {
                        $work = $work->();
                        croak "Expanding UNLESS variable $name returned CODE again on line $line of $cur_file"
                            if isa($work, "CODE");
                        unless (ref($vars) eq __PACKAGE__) {
                            my %vars = %{$vars};
                            $vars = bless \%vars;
                        }
                        $vars->{$name} = $work;
                        $work = "" unless defined($work);
                    }
                } else {
                    #exists($vars->{$name}) ||
                    #    die "UNLESS variable '$name' does not exist on line $line of $cur_file\n";
                    $work = "";
                }
                $work = @{$work} if isa($work, "ARRAY");
            }
            $name = shift;
            if (!$work) {
                shift;	# Get rid of ELSE
                unshift(@_, @{$name});
            } elsif ($name = shift) {
                unshift(@_, @{$name});
            }
        } elsif ($work == INCLUDE) {
            my $line    = shift;
            my $context = shift;
            local *vars = $cur_levels{$context} ||
                die "Context '$context' does not exist on line $line of $cur_file\n" if $context ne "";
            my $name    = shift;
            if ($context eq "") {
                $work = $name;
            } else {
                if (defined($work = $vars->{$name})) {
                    if (isa($work, "CODE")) {
                        $work = $work->();
                        croak "Expanding INCLUDE variable $name returned CODE again on line $line of $cur_file"
                            if isa($work, "CODE");
                        unless (ref($vars) eq __PACKAGE__) {
                            my %vars = %{$vars};
                            $vars = bless \%vars;
                        }
                        $vars->{$name} = $work;
                        $work = "" unless defined($work);
                    }
                } else {
                    exists($vars->{$name}) ||
                        die "INCLUDE variable '$name' does not exist on line $line of $cur_file\n";
                    $work = "";
                }
                $work = @{$work} if isa($work, "ARRAY");
            }
            unless (substr($work, 0, 1) eq "/") {
                # relative path
                my $dir = $cur_file;
                $dir =~ s|/[^/]+\z|/$work|;
                $work = $dir;
            }
            # another option is to unshift the included machine --Ton
            eval {
                __PACKAGE__->new($work, 1)->output();
            };
            die "Could not include $work on line $line of $cur_file: $@" if $@;
        } else {
            confess("Unknown command $work in " . __PACKAGE__ . " state machine");
        }
    }
}

1;
