package CGI::Kwiki::Formatter::HLB;
$VERSION = '0.1';
use strict;
use base 'CGI::Kwiki', 'CGI::Kwiki::Privacy', 'DefinitionLists';
use CGI::Kwiki qw(:char_classes);

sub process_order {
    return qw(
    definition_list
    table code function 
    header_1 header_2 header_3 header_4 header_5 header_6 
    escape_html
    lists comment horizontal_line
    paragraph 
    named_http_link no_http_link http_link
    no_mailto_link mailto_link
    no_wiki_link force_wiki_link wiki_link
    inline version negation
    strong emphasis underscore
);
}

my $slide_num;
sub process {
$slide_num = 0;
my ($self, $wiki_text) = @_;
my $array = [];
push @$array, $wiki_text;
for my $method ($self->process_order) {
    $array = $self->dispatch($array, $method);
}
return $self->combine_chunks($array);
}

sub dispatch {
my ($self, $old_array, $method) = @_;
return $old_array unless $self->can($method);
my $new_array;
for my $chunk (@$old_array) {
    if (ref $chunk eq 'ARRAY') {
	push @$new_array, $self->dispatch($chunk, $method);
    }
    else {
	if (ref $chunk) {
	    push @$new_array, $chunk;
	}
	else {
	    push @$new_array, $self->$method($chunk);
	}
    }
}
return $new_array;
}

sub combine_chunks {
my ($self, $chunk_array) = @_;
my $formatted_text = '';
for my $chunk (@$chunk_array) {
    $formatted_text .= 
	(ref $chunk eq 'ARRAY') ? $self->combine_chunks($chunk) :
	(ref $chunk) ? $$chunk :
	$chunk
}
return $formatted_text;
}

sub split_method {
my ($self, $text, $regexp, $method) = @_;
my $i = 0;
map {$i++ % 2 ? \ $self->$method($_) : $_} split $regexp, $text;
}

sub user_functions {
qw(
    SLIDESHOW_SELECTOR
    total_bullets
);
}

sub isa_function {
my ($self, $function) = @_;
defined { map { ($_, 1) } $self->user_functions }->{$function} and
$self->can($function)
}

sub function {
my ($self, $text) = @_;
$self->split_method($text,
    qr{\[\&(\w+\b.*?)\]},
    'function_format',
);
}

sub function_format {
my ($self, $text) = @_;
my ($method, @args) = split;
$self->isa_function($method) 
    ? $self->$method(@args)
    : "<!-- Function not supported here: $text -->\n";
}

sub total_bullets {
my ($self) = @_;
scalar(() = $self->database->load($self->cgi->page_id) =~ /^\* /gm);
}

sub SLIDESHOW_SELECTOR {
my ($self) = @_;
$slide_num = 1;
my $page_id = $self->cgi->page_id;
my $start = $self->loc('start');
my $html = <<END;
<script src="javascript/SlideStart.js"></script>
<form>
${ \ CGI::popup_menu(
	-name => 'size',
	-values => [qw(640x480 800x600 1024x768 1280x1024 1600x1200), $self->loc('fullscreen')]
    )
}
<input type="button" id="button" value="$start" onclick="startSlides()" />
<input type="hidden" id="action" value="START" />
<input type="hidden" id="page_id" value="$page_id" />
</form>
END
$html;
}

sub TRANSCLUDE_HTTP_BODY {
my ($self, $url) = @_;
require LWP::Simple;
my $html = LWP::Simple::get($url)
    or return '';
$html =~ s#.*<body>(.*)</body>.*#$1#is;
\ $html;
}

sub table {
my ($self, $text) = @_;
my @array;
while ($text =~ /(.*?)(^\|[^\n]*\|\n.*)/ms) {
    push @array, $1;
    my $table;
    ($table, $text) = $self->parse_table($2);
    push @array, $table;
}
push @array, $text if length $text;
return @array;
}

sub parse_table {
my ($self, $text) = @_;
my $error = '';
my $rows;
while ($text =~ s/^(\|(.*)\|\n)//) {
    $error .= $1;
    my $data = $2;
    my $row = [];
    for my $datum (split /\|/, $data) {
	$datum =~ s/^\s*(.*?)\s*$/$1/;
	if ($datum =~ s/^<<(\S+)$//) {
	    my $marker = $1;
	    while ($text =~ s/^(.*\n)//) {
		my $line = $1;
		$error .= $line;
		if ($line eq "$marker\n") {
		    $marker = '';
		    last;
		}
		$datum .= $line;
	    }
	    if (length $marker) {
		return ($error, $text);
	    }
	}
	push @$row, $datum;
    }
    push @$rows, $row;
}
return ($self->format_table($rows), $text);
}

sub format_table {
my ($self, $rows) = @_;
my $cols = 0;
for (@$rows) {
    $cols = @$_ if @$_ > $cols;
}
my $table = qq{<table>\n};
for my $row (@$rows) {
    $table .= qq{<tr>\n};
    for (my $i = 0; $i < @$row; $i++) {
	my $colspan = '';
	if ($i == $#{$row} and $cols - $i > 1) {
	    $colspan = ' colspan="' . ($cols - $i) . '"';
	}
	my $cell = $self->escape_html($row->[$i]);
	$cell = qq{<pre>$cell</pre>\n}
	    if $cell =~ /\n/;
	$cell = '&nbsp;' unless length $cell;
	$table .= qq{<td$colspan>$cell</td>\n};
    }
    $table .= qq{</tr>\n};
}
$table .= qq{</table>\n};
return \$table;
}

sub no_wiki_link {
my ($self, $text) = @_;
$self->split_method($text,
    qr{!([$UPPER](?=[$WIKIWORD]*[$UPPER])(?=[$WIKIWORD]*[$LOWER])[$WIKIWORD]+)},
    'no_wiki_link_format',
);
}

sub no_wiki_link_format {
my ($self, $text) = @_;
return $text;
}

sub wiki_link {
my ($self, $text) = @_;
$self->split_method($text,
    qr{([$UPPER](?=[$WIKIWORD]*[$UPPER])(?=[$WIKIWORD]*[$LOWER])[$WIKIWORD]+)},
    'wiki_link_format',
);
}

sub force_wiki_link {
my ($self, $text) = @_;
$self->split_method($text,
    qr{(?<!\!)\[([$ALPHANUM\-:]+)\]},
    'wiki_link_format',
);
}

sub wiki_link_format {
my ($self, $text) = @_;
my $script = $self->script;
my $url = $self->escape($text);
my $wiki_link = qq{<a href="$script?$url">$text</a>};
if (not $self->database->exists($text)) {
    $wiki_link =~ s/<a/<a class="empty"/;
}
elsif (not $self->is_readable($text)) {
    $url = $self->escape($self->loc("KwikiPrivatePage"));
    $wiki_link = 
	qq{<a class="private" href="$script?$url">$text</a>};
}
return $wiki_link;
}

sub no_http_link {
my ($self, $text) = @_;
$self->split_method($text,
    qr{(!(?:https?|ftp|irc):\S+?)}m,
    'no_http_link_format',
);
}

sub no_http_link_format {
my ($self, $text) = @_;
$text =~ s#!##;
return $text;
}

sub http_link {
my ($self, $text) = @_;
$self->split_method($text,
    qr{((?:https?|ftp|irc):\S+?(?=[),.:;]?\s|$))}m,
    'http_link_format',
);
}

sub http_link_format {
my ($self, $text) = @_;
if ($text =~ /^http.*\.(?i:jpg|gif|jpeg|png)$/) {
    return $self->img_format($text);
}
else {
    return $self->link_format($text);
}
}

sub no_mailto_link {
my ($self, $text) = @_;
$self->split_method($text,
    qr{(![$ALPHANUM][$WORD\-\.]*@[$WORD][$WORD\-\.]+)}m,
    'no_mailto_link_format',
);
}

sub no_mailto_link_format {
my ($self, $text) = @_;
$text =~ s#!##;
return $text;
}

sub mailto_link {
my ($self, $text) = @_;
$self->split_method($text,
    qr{([$ALPHANUM][$WORD\-\.]*@[$WORD][$WORD\-\.]+)}m,
    'mailto_link_format',
);
}

sub mailto_link_format {
my ($self, $text) = @_;
my $dot = ($text =~ s/\.$//) ? '.' : '';
qq{<a href="mailto:$text">$text</a>$dot};
}

sub img_format {
my ($self, $url) = @_;
return qq{<img src="$url" />};
}

sub link_format {
my ($self, $text) = @_;
$text =~ s/(^\s*|\s+(?=\s)|\s$)//g;
my $url = $text;
$url = $1 if $text =~ s/(.*?) +//;
$url =~ s/^http:(?!=\/\/)//; # relative links
return qq{<a href="$url">$text</a>};
}

sub named_http_link {
my ($self, $text) = @_;
$self->split_method($text,
    qr{(?<!\!)\[([^\[\]]*?(?:https?|ftp|irc):\S.*?)\]},
    'named_http_link_format',
);
}

sub named_http_link_format {
my ($self, $text) = @_;
if ($text =~ m#(.*)((?:https?|ftp|irc):\S+)(.*)#) {
    $text = "$2 $1$3";
}
return $self->link_format($text);
}

sub version {
my ($self, $text) = @_;
$text =~ s#(?<!\!)\[\#\.\#\]#$CGI::Kwiki::VERSION#g;
return $text;
}

sub inline {
my ($self, $text) = @_;
$self->split_method($text,
    qr{(?<!\!)\[=(.*?)(?<!\\)\]},
    'inline_format',
);
}

sub inline_format {
my ($self, $text) = @_;
$text =~ s{\\ ([ \[\] ]) }{$1}xg;   # Translate \] escapes to ]
"<code>$text</code>";
}

sub negation {
my ($self, $text) = @_;
$text =~ s#\!(?=\[)##g;
return $text;
}

sub strong {
my ($self, $text) = @_;
$text =~ s#(?<![$WORD])\*(\S.*?\S|\S)\*(?![$WORD])#<strong>$1</strong>#g;
return $text;
}

sub emphasis {
my ($self, $text) = @_;
$text =~ s#(?<![$WORD<])/(\S.*?\S|\S)/(?![$WORD])#<em>$1</em>#g;
return $text;
}

sub underscore {
my ($self, $text) = @_;
$text =~ s#(?<![$WORD])_(\S.*?\S|\S)_(?![$WORD])#<u>$1</u>#g;
return $text;
}

sub code {
my ($self, $text) = @_;
$self->split_method($text,
    qr{(^ +[^ \n].*?\n)(?-ms:(?=[^ \n]|$))}ms,
    'code_format',
);
}

sub code_format {
my ($self, $text) = @_;
$self->code_postformat($self->code_preformat($text));
}

sub code_preformat {
my ($self, $text) = @_;
my ($indent) = sort { $a <=> $b } map { length } $text =~ /^( *)\S/mg;
$text =~ s/^ {$indent}//gm;
return $self->escape_html($text);
}

sub code_postformat {
my ($self, $text) = @_;
return "<code><pre>$text</pre></code>\n";
}

sub escape_html {
my ($self, $text) = @_;
$text =~ s/&/&amp;/g;
$text =~ s/</&lt;/g;
$text =~ s/>/&gt;/g;
$text;
}

sub lists {
my ($self, $text) = @_;
my $switch = 0;
return map {
    my $level = 0;
    my @tag_stack;
    if ($switch++ % 2) {
	my $text = '';
	my @lines = /(.*\n)/g;
	for my $line (@lines) {
	    $line =~ s/^([0\*]+) //;
	    my $new_level = length($1);
	    my $tag = ($1 =~ /0/) ? 'ol' : 'ul';

	    $text .= ($level && $new_level == $level) ? '</li><li>' : '';
	    if ($new_level > $level) {
		for (1..($new_level - $level)) {
		    push @tag_stack, $tag;
		    $text .= "<$tag><li>\n";
		}
		$level = $new_level;
	    }
	    elsif ($new_level < $level) {
		for (1..($level - $new_level)) {
		    $tag = pop @tag_stack;
		    $text .= $level ? '</li>' : '';
		    $text .= "</$tag>\n";
		}
		$level = $new_level;
		$text .= $level ? '</li><li>' : '';
	    }
	    $text .= "$line";
        }
        for (1..$level) {
            my $tag = pop @tag_stack;
            $text .= "</li></$tag>\n";
        }
        $_ = $self->lists_format($text);
    }
        $_;
    }
    split m!(^[0\*]+ .*?\n)(?=(?:[^0\*]|$))!ms, $text;
}

sub lists_format {
    my ($self, $text) = @_;
    return $text;
}

sub paragraph {
    my ($self, $text) = @_;
    my $switch = 0;
    return map {
        unless ($switch++ % 2) {
            $_ = $self->paragraph_format($_);
        }
        $_;
    }
    split m!(\n\s*\n)!ms, $text;
}

sub paragraph_format {
    my ($self, $text) = @_;
    return '' if $text =~ /^[\s\n]*$/;
    return $text if $text =~ /^<(o|u)l>/i;
    return "<p>\n$text\n</p>\n";
}

sub horizontal_line {
    my ($self, $text) = @_;
    $self->split_method($text,
        qr{(^----+\n)}m,
        'horizontal_line_format',
    );
}

sub horizontal_line_format {
    my ($self) = @_;
    my $text = "<hr />\n";
    if ($slide_num) {
        my $page_id = $self->cgi->page_id;
	my $go = $self->loc('Go');
        $text .= qq{<a target="SlideShow" href="index.cgi?action=slides&page_id=$page_id&slide_num=$slide_num">$go</a>\n};
        $slide_num++;
    }
    return $text;
}

sub comment {
    my ($self, $text) = @_;
    $self->split_method($text,
        qr{^\# (.*)\n}m,
        'comment_line_format',
    );
}

sub comment_line_format {
    my ($self, $text) = @_;
    return "<!-- $text -->\n";
}

for my $num (1..6) {
    no strict 'refs';
    *{"header_$num"} = 
    sub {
        my ($self, $text) = @_;
        $self->split_method($text,
            qr{^={$num} (.*?)(?: ={$num})?\n}m,
            "header_${num}_format",
        );
    };
    *{"header_${num}_format"} = 
    sub {
        my ($self, $text) = @_;
        return "<h$num>$text</h$num>\n";
    };
}

1;

__END__

=head1 NAME 

CGI::Kwiki::Formatter::HLB - HLB's Formatter

=cut
