z2w

#! /usr/bin/perl
#   z2w - convert ZeroMQ document to Wikidot format
#   - converts [[code type="textdiagram"]] via ditaa
#   - converts zmq_something(3) into URL to http://api.zeromq.org
#   Eventually meant to produce print-ready output via tex
#
#   Usage: z2w docfile
#
#   Creates Wikidot file as specified by .output and images in images/.
#
#   Dependencies (Ubuntu 10.10 packages):
#       pygmentize
#       imagemagick (mogrify tool)
#
#   By Pieter Hintjens, free for remixing without conditions.
#   Images are stored in the github repository at
#   https://github.com/imatix/zguide
#
require 'sflcvdp.pl';                   #   SFL date picture formatting
use Digest::SHA1 qw(sha1_hex);

@languages = ('Ada', 'Basic', 'C', 'C++', 'C#', 'Clojure', 'CL', 'Erlang',
              'F#', 'Felix', 'Go', 'Haskell', 'Haxe', 'Java', 'Lua', 'Node.js',
              'Objective-C', 'ooc', 'Perl', 'PHP', 'Python', 'Ruby', 'Scala');

#   File extensions for each language
%extension = ('Ada' => 'ada',
              'Basic' => 'bas',
              'C' => 'c',
              'C++' => 'cpp',
              'C#' => 'cs',
              'CL' => 'lisp',
              'Clojure' => 'clj',
              'Erlang' => 'es',
              'F#' => 'fsx',
              'Felix' => 'flx',
              'Go' => 'go',
              'Haskell' => 'hs',
              'Haxe' => 'hx',
              'Java' => 'java',
              'Lua' => 'lua',
              'Node.js' => 'js',
              'Objective-C' => 'm',
              'ooc' => 'ooc',
              'Perl' => 'pl',
              'PHP' => 'php',
              'Python' => 'py',
              'Racket' => 'rkt',
              'Ruby' => 'rb',
              'Scala' => 'scala' );

#   Specific Pygmentizer lexer for each language, if needed
%lexer = ('Erlang' => 'erlang',
          'F#' => 'ocaml' );

$source = $ENV {'Z2W_LANG'} || "C";
$format = $ENV {'Z2W_FORM'} || "online";
printf "Generating $source/$format version of Guide...\n";

#   Inline action options
$inline_action = 0;
$inline_source = 1;
$inline_collapsed = 2;
$inline_listing = 3;

#   Ensure all languages have an examples directory
foreach (@languages) {
    $translations {$_} = 0;
    mkdir ("examples/$_") unless -d "examples/$_";
    if (!-f "examples/$_/README") {
        die "Can't create examples/$_/README: $!"
            unless open (README, ">examples/$_/README");
        print README "Examples in $_\n";
        print README "See LICENSE in examples directory\n";
    }
}
$examples = 0;
$listings = 0;
$this = 0;

die "Can't create wdtemp.txt: $!"
    unless open (OUTPUT, ">wdtemp.txt");
die "Can't create upload.sh: $!"
    unless open (UPLOAD, ">upload.sh");

signatures_load ();
writeln ('[!-- Generated documentation file, do not edit --]');

while (<>) {
    chop;
    if (/^\./) {
        #   Process directive
        if (/^\.set\s+(\w+)=(.*)/) {
            $symbols {$1} = $2;
        }
        elsif (/^\.\-/) {
            #   Comment, ignore
        }
        elsif (/^\.end/) {
            writeln ("(More coming soon...)");
            $EOD = 1;       #   Stop output here
        }
        elsif (/^\.output\s+(\w.*)/) {
            close (OUTPUT);
            die "Can't create $1: $!"
                unless open (OUTPUT, ">$1");
            if ($prelude) {
                die "Can't open $prelude: $!"
                    unless open (PRELUDE, $prelude);
                while (<PRELUDE>) {
                    chop;
                    writeln ($_)
                }
                close (PRELUDE);
            }
        }
        elsif (/^\.prelude\s+(\w.*)/) {
            $prelude = $1;
        }
        else {
            print "Illegal directive $_ at line $.\n";
        }
    }
    elsif (/^([\+]+)\s+(.*)$/) {
        $this++;
        $prev = $this - 1;
        $next = $this + 1;
        $indent = $1;
        $header = $2;
        $anchor = $header;
        $anchor =~ s/[^a-zA-Z]/-/g;
        $anchor =~ s/\-+/-/g;
        $anchor =~ s/\-$//;
        writeln ("[[# $anchor]][[# header-$this]]");
        writeln ("[[table style=\"width:100%\"]]");
        writeln ("[[row]]");
        writeln ("[[cell]]");
        writeln ("$indent [#$anchor $header]");
        writeln ("[[/cell]]");
        writeln ("[[cell style=\"text-align:right; font-size:80%;\"]]");
        writeln ("[#top top] [#header-$prev prev] [#header-$next next]");
        writeln ("[[/cell]]");
        writeln ("[[/row]]");
        writeln ("[[/table]]");
    }
    #  Process unnamed code listing
    elsif (/\[\[code\s+language=\"(.+)\"\]\]/) {
        $listings++;
        $title = "Listing $listings";
        $name = "listing_$listings";
        $language = $1;
        $filename = "listings/$language/$name.$extension{$language}";
        mkdir ("listings") unless -d "listings";
        mkdir ("listings/$language") unless -d "listings/$language";

        die "Can't create $filename: $!"
            unless open (LISTING, ">$filename");
        while (<>) {
            last if /\[\[\/code\]\]/;
            print LISTING $_;
        }
        process_one_language ("listings", $name, $language, $title, $inline_listing);
    }
    #  Process named codeblock
    elsif (/\[\[code\s+type=\"example\"\s+title=\"([^"]+)\"\s+name=\"([^"]+)\"(\s+language=\"([^"]+)\")?\]\]/) {
        $title = zmq_symbol ($1); #  Some titles have '0MQ'
        $name = $2;
        $language = $4;
        if ($language) {
            process_one_language ("examples", $name, $language, $title, $inline_source);
        }
        elsif ($format eq "pdf") {
            process_one_language ("examples", $name, $source, $title, $inline_source);
        }
        else {
            $actions = "";
            $missing = "";
            #   Show primary language example inline
            if (process_one_language ("examples",
                $name, $source, $title, $inline_collapsed)) {
                $translations {$source} += 1;
            }
            #   Show other languages as new tabs
            foreach $language (@languages) {
                if ($language ne $source) {
                    if (process_one_language ("examples",
                        $name, $language, $title, $inline_action)) {
                        $translations {$language} += 1;
                    }
                }
            }
            if ($missing) {
                $actions = $actions." | " if $actions;
                $actions = $actions."[/main:translate $missing]";
                $actions = "[[size smaller]]".$actions."[[/size]]";
            }
            writeln ($actions);
            $examples++;
        }
        #   Discard any real contents of code block
        while (<>) {
            last if /\[\[\/code\]\]/;
            print "W: discarding code for $title - $name\n";
        }
    }
    #  Process plain code block
    elsif (/\[\[code\]\]/) {
        writeln ($_);
        while (<>) {
            chop;
            writeln ($_);
            last if /\[\[\/code\]\]/;
        }
    }
    elsif ($_ eq "[[code type=\"textdiagram\"]]") {
        #   Text diagram
        $figure = $figure + 1;
        $filename = "images/fig$figure.html";
        die "Can't create $filename: $!"
            unless open (IMAGE, ">$filename");

        print IMAGE "<html>\n";
        print IMAGE "<pre class=\"textdiagram\" id=\"fig$figure\">\n";
        while (<>) {
            chop;
            last if /\[\[\/code\]\]/;
            s/#/$figure/;
            $_ = zmq_symbol ($_);
            print IMAGE "$_\n";
        }
        print IMAGE "</pre>\n";
        print IMAGE "</html>\n";
        close (IMAGE);
        if (signature_changed ($filename)) {
            print "Processing $filename...\n";
            system ("java -jar bin/ditaa0_9.jar $filename -o -h -E output.html >/dev/null");
            #   Need to trim twice for reasons I don't care to explore
            system ("mogrify -trim images/fig$figure.png");
            system ("mogrify -trim images/fig$figure.png");
            system ("rm output.html");
            signature_update ($filename);
        }
        #   Link to resource in git, nice way to upload images
        writeln ("[[=image $symbols{GIT}/raw/$symbols{BRANCH}/images/fig$figure.png]]");
    }
    elsif (/\[\[code/) {
        print "E: unparsed code block: $_\n";
    }
    else {
        #   Normal text
        writeln ($_);
    }
}
if ($format eq "online") {
    die "Can't create scoreboard.wd: $!"
        unless open (SCOREBOARD, ">scoreboard.wd");
    print (SCOREBOARD "||||||~ Translations ($examples in total)||\n");
    foreach $language (@languages) {
        printf (SCOREBOARD "|| [/$extension{$language}:_start %s] || %3d || %3d%% ||\n",
            $language, $translations {$language},
            ($translations {$language} * 100) / $examples);
    }
    close (SCOREBOARD);
}
close (OUTPUT);
close (UPLOAD);

signatures_save ();
exit (0);


#   Writes $_ to OUTPUT after expanding all symbols

sub writeln {
    local ($_) = @_;
    $_ = expand_symbols ($_);
    print OUTPUT "$_\n" unless $EOD;
}

#   Process one example in one language

sub process_one_language {
    local ($directory, $name, $language, $title, $inline) = @_;
    local $ext = $extension{$language};

    $filename = "$directory/$language/$name.$ext";
    if (-f $filename) {
        if ($inline == $inline_source) {
            writeln ("[[include $ext:$name]]");
            writeln ("[[>]]");
            writeln ("//$name.$ext: $title//");
            writeln ("[[/>]]");
        }
        elsif ($inline == $inline_collapsed) {
            writeln ("[[collapsible show=\"$name: $title in $language\" hide=\"$name: $title in $language\"]]");
            writeln ("[[include $ext:$name]]");
            writeln ("[[/collapsible]]");
        }
        elsif ($inline == $inline_action) {
            $actions = $actions." | " if $actions;
            $actions = $actions."[*/$ext:$name $language]";
        }
        elsif ($inline == $inline_listing) {
            writeln ("[[include $ext:$name]]");
        }
        if (signature_changed ($filename)) {
            print "Processing $name (in $language)...\n";
            $lexopt = $lexer {$language}? "-l $lexer{$language}": "";
            system ("pygmentize -f bb $lexopt $filename > tempfile.bb");
            exit (1) if $?;
            system ("bin/bb2wd tempfile.bb >examples/$language/$name.wd");
            system ("rm tempfile.bb");
            print UPLOAD "cd examples/$language\n";
            print UPLOAD "    wdput zguide $ext $name \"$title in $language\"\n";
            print UPLOAD "    rm $name.wd\n";
            print UPLOAD "cd ../..\n";
            signature_update ($filename);
        }
        return 1;       #   File exists
    }
    else {
        if ($inline == $inline_source) {
            writeln ("[[include c:$name]]");
            writeln ("[[>]]");
            writeln ("//$name.c: $title//");
            writeln ("[[/>]]");
        }
        else {
            $missing = "$missing | " if $missing;
            $missing = "$missing$language";
        }
        return 0;
    }
}


#   Load signatures hash tables
sub signatures_load {
    print "I: loading signatures... ";
    undef %signatures;
    local $count = 0;
    if (open (SIGNATURES, ".signatures")) {
        while (<SIGNATURES>) {
            /([^\s]+)\s+([^\s]+)/;
            $signatures {$2} = $1;
            $count++;
        }
    }
    print "$count loaded\n";
}

#   If file signature has changed, return 1, else 0
sub signature_changed {
    local ($filename) = @_;
    $_ = `sha1sum $filename`;
    if (/([^\s]+)\s+/) {
        if ($signatures {$filename} eq $1) {
            return 0;
        }
        else {
            return 1;
        }
    }
    else {
        "E: can't sha1sum $filename\n";
        return 0;
    }
}

#   Save file signature into table
sub signature_update {
    local ($filename) = @_;
    $_ = `sha1sum $filename`;
    if (/([^\s]+)\s+/) {
        $signatures {$filename} = $1;
    }
    else {
        "E: can't sha1sum $filename\n";
        return 0;
    }
}

#   Save signatures table
sub signatures_save {
    print "I: saving signatures... ";
    local $count = 0;
    local $filename;
    if (open (SIGNATURES, ">.signatures")) {
        foreach $filename (keys %signatures) {
            print SIGNATURES "$signatures{$filename} $filename\n";
            $count++;
        }
    }
    print "$count saved\n";
}


#-- Symbol expansion code, taken from htmlpp

#   Recursively expand symbols like this (and in this order):
#
#   $(xxx)                  - value of variable
#   $(xxx?zzz)              - value of variable, or zzz if undefined
#   %(text?zzz)             - value of environment variable, or zzz if undef
#   &abc(text)              - intrinsic function with arguments
#   zmq_zzz[n]              - link to 0MQ reference manual page
#
sub expand_symbols {
    local ($_) = @_;
    local ($before,
           $match,
           $after,
           $expr);

    return unless ($_);                 #   Quit if input string is empty

    $_ = zmq_symbol ($_);

    for (;;) {
        #   Force expansion from end of string first, so things like
        #   $(xxx?$(yyy)) work properly.
        if (/[\$%]\(/ || /\&([a-z_]+)\s*\(/i) {
            $before = $`;
            $match  = $&;
            $after  = expand_symbols ($');
            $_ = $before.$match.$after;
        }
        #   $(xxx)
        if (/\$\(([A-Za-z0-9-_\.]+)\)/) {
            $_ = $`.&valueof ($1).$';
        }
        #   $(xxx?zzz)
        elsif (/\$\(([A-Za-z0-9-_\.]+)\?([^)\$]*)\)/) {
            $_ = $`.&valueof ($1, $2).$';
        }
        #   %(text)
        elsif (/\%\(([^\)]+)\)/) {
            $_ = $`.$ENV {$1}.$';
        }
        #   %(text?zzz)
        elsif (/\%\(([^\)]+)\?([^)\$]*)\)/) {
            $_ = $`.($ENV {$1}? $ENV {$1}: $2).$';
        }
        #   &abc(text)
        elsif (/\&([a-z_]+)\s*\(([^\)]*)\)/i) {
            $funct = $1;
            $args = $2;
            $before = $`;
            $after = $';
            $args =~ s/\\/\\\\/g;
            $_ = eval ("&intrinsic_$funct ($args)");
            $_ = $before.$_.$after;
            if ($@) {                   #   Syntax error in Perl statement?
                &error ("$function is not a valid intrinsic function")
                    unless $nofunc_mode;
                last;
            }
        }
        elsif (/zmq_([\w_]+)\[(.)\]/) {
            $_ = $`."[http://api.zeromq.org/2-1:zmq_$1 zmq_$1($2)]".$';
        }
        else {
            last;
        }
    }
    return $_;
}


#   Translate 0MQ into ØMQ and 0\MQ into 0MQ
sub zmq_symbol {
    local ($_) = @_;

    s/0MQ/ØMQ/g;
    s/0\\MQ/0MQ/g;
    return $_;
}


#   Subroutine returns the value of the specified symbol; it issues a
#   warning message and returns 'UNDEF' if the symbol is not defined
#   and the default value is empty.
#
sub valueof {
    local ($symbol, $default) = @_;     #   Argument is symbol name
    local ($return);                    #   Returned value
    local ($langed_symbol);             #   Language-dependent symbol

    if (defined ($symbols {$symbol})) {
        $return = $symbols {$symbol};
        return $return;
    }
    elsif (defined ($default)) {
        return ($default);
    }
    &error ("$_");
    &error ("($.) undefined symbol \"$symbol\"");
    $default_warning == 1 || do {
        &error ("I: Use \$($symbol?default) for default values.");
        $default_warning = 1;
    };
    $symbols {$symbol} = "UNDEF";
    return $symbols {$symbol};
}


#   INTRINSIC FUNCTIONS
#
#   time()                     - Format current time as hh:mm:ss
#   date()                     - Return current date value
#   date("picture")            - Format current date using picture
#   date("picture", date, lc)  - Format specified date using picture & language
#   week_day([date])           - Get day of week, 0=Sunday to 6=Saturday
#   year_week([date])          - Get week of year, 1 is first full week
#   julian_date([date])        - Get Julian date for date
#   lillian_date([date])       - Get Lillian date for date
#   date_to_days(date)         - Convert yyyymmdd to Lillian date
#   days_to_date(days)         - Convert Lillian date to yyyymmdd
#   future_date(days[,date])   - Calculate a future date
#   past_date(days[,date])     - Calculate a past date
#   date_diff(date1[,date2])   - Calculate date1 - date2
#   image_height("image.ext")  - Get image height (GIF, JPEG)
#   image_width("image.ext")   - Get image width (GIF, JPEG)
#   file_size("filename",arg)  - Get size of file: optional arg K or M
#   file_date("filename")      - Get date of file
#   file_time("filename")      - Get time of file as hh:mm:ss
#   normalise("filename")      - Normalise filename to UNIX format
#   system("command")          - Call a system utility
#   lower("string")            - Convert string to lower case
#   upper("string")            - Convert string to upper case
#

sub intrinsic_date {
    local ($picture, $value, $language) = @_;
    $value = &date_now unless $value;
    $language = $symbols{LANG} unless $language;
    if ($picture) {
        return (&conv_date_pict ($value, $picture, $language));
    }
    else {
        return ($value);
    }
}

sub intrinsic_time {
    local ($sec, $min, $hour, $day, $month, $year) = localtime;
    return (sprintf ("%2d:%02d:%02d", $hour, $min, $sec));
}

sub intrinsic_week_day {
    return (&day_of_week ($_ [0]? $_ [0]: &date_now));
}

sub intrinsic_year_week {
    return (&week_of_year ($_ [0]? $_ [0]: &date_now));
}

sub intrinsic_julian_date {
    return (&julian_date ($_ [0]? $_ [0]: &date_now));
}

sub intrinsic_lillian_date {
    return (&date_to_days ($_ [0]? $_ [0]: &date_now));
}

sub intrinsic_date_to_days {
    return (&date_to_days ($_ [0]));
}

sub intrinsic_days_to_date {
    return (&days_to_date ($_ [0]));
}

sub intrinsic_future_date {
    local ($date) = &future_date ($_ [1], 0, $_ [0], 0);
    return ($date);
}

sub intrinsic_past_date {
    local ($date) = &past_date ($_ [1], 0, $_ [0], 0);
    return ($date);
}

sub intrinsic_date_diff {
    local ($date1, $date2) = @_;
    $date1 = &date_now unless $date1;
    $date2 = &date_now unless $date2;
    local ($days) = &date_diff ($date1, 0, $date2, 0);
    return ($days);
}

sub intrinsic_image_height {
    local ($filename) = @_;
    if (! -e $filename) {
        &error ("($.) file not found: \"$filename\"");
    }
    else {
        return (&image_height ($filename));
    }
}

sub intrinsic_image_width {
    local ($filename) = @_;
    if (! -e $filename) {
        &error ("($.) file not found: \"$filename\"");
    }
    else {
        return (&image_width ($filename));
    }
}

sub intrinsic_file_size {
    local ($filename, $arg) = @_;
    local ($size) = (stat ($filename)) [7];

    if (! -e $filename) {
        &error ("($.) file not found: \"$filename\"");
    }
    elsif ($arg eq "K") {
        $size /= 1024;
    }
    elsif ($arg eq "M") {
        $size /= 1048576;
    }
    return (int ($size));
}

sub intrinsic_file_date {
    local ($filename) = @_;
    if (! -e $filename) {
        &error ("($.) file not found: \"$filename\"");
    }
    else {
        local ($mtime) = (stat ($filename)) [9];
        local ($sec,$min,$hour,$mday,$mon,$year) = localtime ($mtime);
        return (($year + 1900) * 10000 + ($mon + 1) * 100 + $mday);
    }
}

sub intrinsic_file_time {
    local ($filename) = @_;
    if (! -e $filename) {
        &error ("($.) file not found: \"$filename\"");
    }
    else {
        local ($mtime) = (stat ($filename)) [9];
        local ($sec,$min,$hour,$mday,$mon,$year) = localtime ($mtime);
        return (sprintf ("%2d:%02d:%02d", $hour, $min, $sec));
    }
}

sub intrinsic_normalise {
    local ($_) = @_;                    #   Get filename argument
    s/\\/\//g;                          #   Replace DOS-style \ by /
    s/\s/_/g;                           #   Replace white space by _
    return ($_);
}

sub intrinsic_system {
    local ($_) = `@_`;

    #   Return all but the last character, which should be a newline
    chop;
    return ($_);
}

sub intrinsic_lower {
    local ($_) = @_;                    #   Get filename argument
    tr/A-Z/a-z/;
    return ($_);
}

sub intrinsic_upper {
    local ($_) = @_;                    #   Get filename argument
    tr/a-z/A-Z/;
    return ($_);
}

sub error {
    ($_) = @_;                          #   Get argument
    print STDERR "E: $_\n";
    $have_errors = 1;                   #   We have 1 or more errors
}