#!/usr/bin/env perl

use strict;
use HTML::Parser ();
use URI;
use lib "lib";
use CCwwwutil;
use IPC::ClearTool;
use vars qw($CT $p $file $lbtype $base $script $doc $time $title);
use File::Basename;
use CGI qw(:standard :html3);
use CGI::Carp;

$file = param('file');
$lbtype = param('lbtype');
$time = param('time');
$doc = rootify("cgi-bin/1/lh.html");
$title = $lbtype;
usage() unless ($file and ($lbtype or $time));
my %link_attr;
{
    # To simplify things we reformat the %HTML::Tagset::linkElements
    # hash so that it is always a hash of hashes.
    require HTML::Tagset;
    while (my($k,$v) = each %HTML::Tagset::linkElements) {
	if (ref($v)) { $v = { map {$_ => 1} @$v }; }
	else         { $v = { $v => 1}; }
	$link_attr{$k} = $v;
    }
}
$script = "$server/$cgidir/" . basename($0) . '?';
$p = HTML::Parser->new(api_version => 3);
$p->handler(default => sub { print @_ }, "text");
$p->handler(start => \&start_handler, "self, tagname, tokenpos, text");
$base = dirname($file) . '/';
$CT = IPC::ClearTool->new;
if (setview()) {
    my $f = rootify($file);
    unless ($time) { $time = lock_time($lbtype, vobtag($f)); }
    print header(), "\n";
    my $g = viewify(fully_label_extended($f, $lbtype));
    unless (-r $g) {
	my $h = fully_version_extended($f, $time);
	if ($h) {
	    $g = viewify($h);
	    $title = $time;
	}
    }
    $p->parse_file($g) || error($!, $g, $file, $lbtype, $time);
}
$CT->finish;

sub start_handler($$$$) {
    my($self, $tagname, $pos, $text) = @_;
    if (my $link_attr = $link_attr{$tagname}) {
	while (4 <= @$pos) {
	    # use attribute sets from right to left to avoid
	    # invalidating the offsets when replacing the values
	    my($k_offset, $k_len, $v_offset, $v_len) = splice(@$pos, -4);
	    my $attrname = lc(substr($text, $k_offset, $k_len));
	    next unless $link_attr->{$attrname};
	    next unless $v_offset; # 0 v_offset means no value
	    my $v = substr($text, $v_offset, $v_len);
	    $v =~ s/^([\'\"])(.*)\1$/$2/;
	    my $new_v = edit($v);
	    next if $new_v eq $v;
	    $new_v =~ s/\"/&quot;/g; # since we quote with ""
	    substr($text, $v_offset, $v_len) = qq("$new_v");
	}
    } elsif ($tagname eq "title") {
	$self->handler(text  => [], '@{dtext}' );
	$self->handler(end   => \&title_end_handler, "self,text");
    }
    print $text;
}

sub edit {
    my $url = shift;
    if (defined(URI->new($url)->scheme)) {
	return $url;
    } else {
	my ($f, $ext) = split /\#/, $url;
	$f = normalize(($f =~ /^\//) ? derootify($f) : $base . $f);
	return "${script}file=${f}\&lbtype=$lbtype&time=$time";
    }
}

sub title_end_handler {
    my($self, $tag) = @_;
    my $text = join("", @{$self->handler("text")});
    $text =~ s/^\s+//;
    $text =~ s/\s+$//;
    $text =~ s/\s+/ /g;
    print "$text ($title)$tag";
    $self->handler("text", undef);
    $self->handler("end", undef);
}

sub fully_label_extended($$) {
    my ($f, $l) = @_;
    my $vob = vobtag($f);
    $f =~ s/^$vob\/(.*)/$1/;
    my @names = split '/', $f;
    return "$vob/.\@\@/$l/" . join("/$l/", @names) . "/$l";
}

sub vobtag($) {
    my $f = shift;
    my %res;
    do {
	(%res) = $CT->cmd("des -s vob:$f");
	$f = dirname($f) if $res{"status"};
    } while $res{"status"} and length($f) > 1;
    my ($vob) = @{$res{stdout}};
    chomp($vob);
    return $vob;
}

sub setview() {
    my (%res) = $CT->cmd("setview doc");
    if ($res{"status"}) {
	my @res = @{$res{stderr}};
	warn "@res\n";
	return 0;
    }
    return 1;
}

sub usage($) {
    print header(), "\n", start_html(basename($0)), "\n", h1("Usage"), "\n",
    p("Some parameters expected:", a({href=>$doc}, "documentation")),
    "\n", end_html(), "\n";
    exit 0;
}

sub error($$$$$) {
    my ($text, $file, $orig, $lbtype, $time) = @_;
    print start_html(basename($0)), "\n", h1("Error"), "\n",
    p("Can't open file $file: $text"), "\n";
    my $f = rootify($orig);
    my $v = vobtag($f);
    if ($v) {
	if ($lbtype) {
	    my (%res) = $CT->cmd("des -s lbtype:$lbtype\@$v");
	    if (-r viewify($f)) {
		print p("Label $lbtype was not found on",
			a({href=>$f}, basename($orig))), "\n";
		if ($res{"status"}) {
		    print p("$lbtype is not a label type in $v"), "\n";
		}
	    }
	} else {
	    print p("No version of", a({href=>$f}, basename($orig)),
		    "was found at time: $time"), "\n";
	}
    } else {
	print p("$f is not in a vob"), "\n";
    }
    print p(a({href=>$doc}, "Documentation")), "\n", end_html(), "\n";
    exit 0;
}

sub lock_time($$) {
    my ($lbtype, $vob) = @_;
    my (%res) = $CT->cmd("lslock -fmt '%d' lbtype:$lbtype\@$vob");
    if ($res{"status"}) {
	return 0;
    } else {
	my ($time) = @{$res{stdout}};
	return $time;
    }
}

sub fully_version_extended($$) {
    my ($f, $time) = @_;
    my $vob = vobtag($f);
    $f =~ s:^$vob/(.*):$1:;
    my @names = split '/', $f;
    $f = version_extended("$vob/.", $time);
    for (my $i=0; $i < @names; $i++) {
	$f = version_extended(join('/', $f, $names[$i]), $time);
	$f =~ s:\@\@(/[^\@]+$):$1:;
    }
    return $f;
}

sub version_extended($$) {
    my ($f, $time) = @_;
    my $cmd = "find $f -dir -ver \"{! created_since($time)}\" -print";
    my (%res) = $CT->cmd($cmd);
    if ($res{"status"}) {
	return 0;
    } else {
	my $re = "/main/($sitebr-[0-9]+/)?[0-9]";
	my @matches = grep m:$re:o, @{$res{stdout}};
	if (@matches) {
	    my $g = $matches[-1]; chomp($g);
    	    return $g;
	} else { return 0; }
    }
}