#!/usr/bin/env perl

use strict;
use Getopt::Long;

my $RCSID = '$Id: bkm2a 2770 2004-03-17 22:39:32Z lefevre $';
my ($proc,$vers,$dt) = $RCSID =~
  /^.Id: (\S+) (\d+) (\d{4}-\d\d-\d\d \d\d:\d\d:\d\d)Z/ or die;

my $Usage = <<EOF;
Usage: $proc [options] bkmfile
  -?, --help            display this help and exit
  -b, --browsehotlist   generate a Browse hotlist file
  -h, --html=DIR        generate HTML files in a directory
  -l, --languages=LANG  comma-separated list of languages
  -m, --nmirrors=NUMBER max number of mirrors
  -n, --netscape        generate a Netscape bookmarks file
  -o, --opera           generate an Opera bookmarks file
  -s, --stronghelp=DIR  generate a StrongHelp file
  -v, --version         output version information and exit
Read the Getopt::Long man page to see how the options are processed.
EOF

my ($dest,$dir,@lang);
my $nmirrors = 1;
GetOptions(
    'help|?' => \&help,
    'browsehotlist|b' => \&dest,
    'html|h=s' => \&dest,
    'languages|l=s' => \&languages,
    'nmirrors|m=i' => \$nmirrors,
    'netscape|n' => \&dest,
    'opera|o' => \&dest,
    'stronghelp|s=s' => \&dest,
    'version|v' => \&version)
  or die $Usage;
push @lang, 'en';

@ARGV == 1 or die "$proc: there must be only one bkmfile.\n$Usage";
my $bkmfile = $ARGV[0];
open BKM, "<$bkmfile"
  or die "$proc: can't open bkmfile $bkmfile\n$!\n";
<BKM> =~ /^!Bookmarks-1\.\d+!$/
  or die "$proc: not a bkmfile\n";
<BKM> =~ /^\s*iso-8859-1\s*$/i
  or die "$proc: only iso-8859-1 is currently supported\n";
<BKM> =~ /^(\w+:\S+)?$/
  or die "$proc: the 3rd line of a bkmfile must be either a URL or empty\n";

my ($time,%k,%d);

{
  no strict 'refs';
  &$dest;
}

sub help
  {
    print $Usage;
    exit;
  }

sub dest
  {
    $dest ne '' and
      die "$proc: some options (destination format) are exclusive.\n$Usage";
    ($dest,$dir) = @_;
  }

sub languages
  {
    push @lang, split /,/, $_[1];
  }

sub version
  {
    print "$proc $vers ($dt)\n";
    exit;
  }

sub nextbkm
  {
    my $h = $_[0];
    while (<BKM>)
      {
        if (/^Id:/i)
          {
            chomp;
            my $s = $_;
            my ($nm,$nd) = (0,0);
            while (<BKM>)
              {
                substr($_,0,1) eq '#' and next;
                /^\s+(\S.*)/ and $s .= " $1", next;
                $s =~ /^([^\s:]+):\s+(\S.*?)\s*$/
                  or die "$proc: bad format";
                my ($key,$val) = ("\L$1\E",$2);
                $key =~ s/^(url-mirror)/$1.++$nm/e;
                $key =~ s/^(directory)/$1.++$nd/e;
                $h->{$key} = $val;
                /^\s*$/ and last;
                chomp($s = $_);
              }
            return 'b';
          }
        if (substr($_,0,1) eq '$')
          {
            my $type;
            if (/^\$\s*keywords\[(\S+)\]$/i)
              { $type = 'k' }
            elsif (/^\$\s*directory\[(\S+)\]$/i)
              { $type = 'd' }
            else
              { die "$proc: bad format" }
            my $f = $1 eq $lang[0] or $type = '-';
            while (<BKM>)
              {
                /^\s*$/ and last;
                /^"([^"]+)" -> "([^"]+)"$/ or die "$proc: bad format";
                $f and $h->{$1} = $2;
              }
            return $type;
          }
        $_ eq "\n" || substr($_,0,1) eq '#'
          or die "$proc: bad format (next entry or translation sequence)";
      }
    return;
  }

sub get
  {
    my ($key,$h,$f) = @_;
    my $v = $h->{$key};
    defined($v) and return $v;
    foreach (@lang)
      { defined($v = $h->{$key."[$_]"}) and return $v }
    foreach (keys %$h)
      { /^$key\[\S+\]/ and return $h->{$_} }
    $f and die "$proc: key $key not found";
    return;
  }

sub maketree
  {
    my ($root,$dir) = @_;
    $dir eq '' and return $root;
    my ($s,$t) = $dir =~ /^:\s*"([^"]+)"\s*(.*)/
      or die "$proc: bad directory tail $dir\n";
    my $subdirs = $root->[0];
    defined $subdirs->{$s} or $subdirs->{$s} = [{}];
    return &maketree($subdirs->{$s}, $t);
  }

sub writetreebrowse
  {
    my ($root,$hdr) = @_;
    defined $hdr and print "<h4>$hdr</h4>\n";
    print "<ul>\n";
    foreach (sort { &dtransl($a) cmp &dtransl($b) } keys %{$root->[0]})
      { &writetreebrowse($root->[0]->{$_}, &dtransl($_)) }
    shift @$root;
    my $entry;
    foreach $entry (@$root)
      {
        foreach ($entry->[0], @{$entry->[1]})
          { print "<li><a href=\"$_\">$entry->[2]</a>\n" }
      }
    print "</ul>\n";
  }

sub writetreenetscape
  {
    my ($root,$indent,$hdr) = @_;
    defined $hdr and print ' 'x$indent, <<EOF;
<DT><H3 FOLDED ADD_DATE="$time">$hdr</H3>
EOF
    print ' 'x$indent, "<DL><p>\n";
    foreach (sort { &dtransl($a) cmp &dtransl($b) } keys %{$root->[0]})
      { &writetreenetscape($root->[0]->{$_}, $indent+4, &dtransl($_)) }
    shift @$root;
    my $entry;
    foreach $entry (@$root)
      {
        foreach ($entry->[0], @{$entry->[1]})
          {
            print ' 'x$indent, <<EOF;
    <DT><A HREF="$_" ADD_DATE="$time" LAST_VISIT="$time" LAST_MODIFIED="$time">$entry->[2]</A>
EOF
            defined $entry->[3] and print "<DD>$entry->[3]\n";
          }
      }
    print ' 'x$indent, "</DL><p>\n";
  }

sub writetreeopera
  {
    my ($root) = @_;
    my $order = 0;
    foreach (sort { &dtransl($a) cmp &dtransl($b) } keys %{$root->[0]})
      {
        my $name = &dtransl($_);
        print <<EOF;
#FOLDER
	NAME=$name
	CREATED=$time
	VISITED=0
	ORDER=$order

EOF
        $order++;
        &writetreeopera($root->[0]->{$_});
        print "-\n\n";
      }
    shift @$root;
    my $entry;
    foreach $entry (@$root)
      {
        foreach ($entry->[0], @{$entry->[1]})
          {
            print <<EOF;
#URL
	NAME=$entry->[2]
	URL=$_
	CREATED=$time
	VISITED=0
	ORDER=$order
EOF
            $order++;
            defined $entry->[3] and print "\tDESCRIPTION=$entry->[3]\n";
            print "\n";
          }
      }
  }

sub dtransl
  { $d{$_[0]} || $_[0] }

sub makebm
  {
    my ($root,$desc) = @_;
    my ($type,%h);
    while (%h = (), $type = &nextbkm(\%h))
      {
        if ($type eq 'b')
          {
            $h{'valid'} =~ /^no$/i and next;
            my ($d,$i,@mirrors,@entry);
            push @entry, &get('url-main', \%h, 1);
            foreach $i (1..$nmirrors)
              {
                my $mirror = &get("url-mirror$i", \%h, 0);
                defined $mirror or last;
                push @mirrors, $mirror;
              }
            push @entry, \@mirrors;
            my $title = &get('title', \%h, 1);
            $title =~ s/\&amp;?/&/g;
            $title =~ tr/<>/[]/;
            push @entry, $title;
            $desc and push @entry, &get('desc', \%h, 0);
            $i = 0;
            while (defined($d = &get('directory'.++$i, \%h, 0)))
              {
                my $aref = &maketree($root, ":$d");
                push @$aref, \@entry;
              }
          }
        elsif ($type eq 'k')
          { %k = %h }
        elsif ($type eq 'd')
          { %d = %h }
      }
  }

sub browsehotlist
  {
    my $root = [{}];
    &makebm($root,0);
    print <<'EOF';
<html>
<head>
<meta http-equiv="Content-Type" content="text/html; charset=ISO-8859-1">
<title>Hotlist</title>
</head>
<body>
EOF
    &writetreebrowse($root);
    print <<'EOF';
</body>
</html>
EOF
  }

sub html
  {
    die "$proc: `html' option isn't currently supported\n$Usage";
  }

sub netscape
  {
    my $root = [{}];
    $time = time;
    &makebm($root,1);
    print <<'EOF';
<!DOCTYPE NETSCAPE-Bookmark-file-1>
<!-- This is an automatically generated file.
It will be read and overwritten.
Do Not Edit! -->
<TITLE>Bookmarks</TITLE>
<H1>Bookmarks</H1>

EOF
    &writetreenetscape($root);
  }

sub opera
  {
    my $root = [{}];
    $time = time;
    &makebm($root,1);
    print "Opera Hotlist version 2.0\n\n";
    &writetreeopera($root);
  }

sub stronghelp
  {
    die "$proc: `stronghelp' option isn't currently supported\n$Usage";
  }