App-zen
view release on metacpan or search on metacpan
});
}
use integer; # otherwise it's float point, and won't work at all for large integer!
my $sortable_b64_alphabet = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ^_abcdefghijklmnopqrstuvwxyz";
sub sortable_b64_encode_int {
my $integ = int(shift);
my $l = shift;
my $alphabet = $sortable_b64_alphabet;
my $encoded = '';
my $base = length($alphabet);
my @digits = ();
my $n = $integ;
while ($n > 0) {
my $remainder = $n % $base;
$encoded = substr($alphabet, $remainder, 1) . $encoded;
$n = int($n / $base);
push @digits, $remainder;
}
return substr($alphabet, 0, 1) x ($l - length($encoded)) . $encoded;
}
#use UUID 'uuid';
use Time::HiRes qw(time);
my $uuid_seq = 1;
sub gen_uuid {
my $ms = int(time()*1000);
my $r = int(rand(64));
# my $id = ($ms << 18) + ($uuid_seq << 6) + $r;
#my $id = ($uuid_seq << 6) + $r;
my $id = ($ms << 18) + ($uuid_seq << 6) + $r;
$uuid_seq = ($uuid_seq + 1) % 4096;
return sortable_b64_encode_int($id, 12),
}
my %options = (
"--loc" => [\$opt_loc, 'Generate code location in the output'],
"--debug" => [\$opt_debug, 'Enable debug'],
"--live" => [\$opt_live, 'Render for httpd server'],
"--draft" => [\$opt_draft, 'Generate draft for latex'],
"--lang LANG" => [\$opt_lang, 'Program language for output source '],
"--target SECTION" => [\$opt_target, 'starting section'],
"--section SECTION" => [\$opt_target, 'starting section'],
"--exec SECTION" => [\$opt_exec, 'execute section'],
"--toc" => [\$opt_toc, 'generate toc'],
"--html" => [\$opt_html, 'Set output format for documentation'],
"--latex" => [\$opt_latex, 'Set output format for documentation'],
"--source-map FILENAME" => [\$opt_source_map, 'Generate source map'],
"--top-heading LEVEL" => [\$opt_top_heading, 'Set top level section type: <part|chapter|section>'],
"--document-class CLASS" => [\$opt_document_class, 'Set latex document class'],
"--verbose" => [\$opt_verbose, 'More logging'],
"--output FILENAME" => [\$opt_output_file, 'Set output file'],
"--port PORT:i" => [\$opt_port, 'Start HTTP Server at port'],
"--daemon" => [\$opt_daemon, "Run server in background"],
"--json-dump" => [\$opt_json_dump, 'Dump the document'],
"-x SECTION" => [\$opt_exec, 'short for --exec'],
"-o OUTPUTFILE" => [\$opt_output_file, 'short for --output'],
"-t SECTION" => [\$opt_target, 'short for --target'],
"-s SECTION" => [\$opt_target, 'short for --section'],
"-h" => [\$opt_help, 'Shows help information'],
);
my %optionsSpec = map {
my $k = $_;
my $ref = $options{$_}[0];
my @x = split /\s+/, $k;
my $name = $x[0];
$name =~ s/^-+//;
my $suffix;
if ($x[1]) {
my @a = split /:/, $x[1];
$suffix = "=".($a[1]||'s');
}
$name.$suffix => $ref
} keys %options;
GetOptions(%optionsSpec) or usage("Invalid options");
usage() if $opt_help || (scalar @ARGV == 0 && !$opt_port);
if ($opt_top_heading) {
while ($section_levels[0] ne $opt_top_heading) {
die "Invalid top heading: $opt_top_heading" if scalar(@section_levels) < 2;
shift @section_levels;
}
}
sub usage {
my $msg = shift;
print STDERR $msg,"\n" if $msg;
print STDERR "zen [options] <file.zen>\n";
foreach (sort keys %options) {
my @desc = split(/\n/, $options{$_}[1]);
s/:.*//;
print STDERR sprintf(" %-24s %s\n", $_, shift @desc);
print STDERR sprintf(" %-24s $_\n", '') foreach (@desc);
}
print STDERR "Zen Version: 0.11\n";
exit(1);
};
sub add_label
{
my ($sec,$name,$ln) = @_;
die unless $sec;
if (exists $sec->{labels}->{$name}) {
die "$sec->{file}:$ln: duplicated labels in same section";
}
my $lab = {
id => 'L-'.($global_label_id++),
section => $sec,
file =>$sec->{file},
ln => $ln
};
$sec->{labels}->{$name} = $lab;
return $lab;
}
sub add_global_label
}
push @ret, split /\s+/, trim($s);
return @ret;
}
sub xtrim
{
my @a = @_;
my $n = 10000;
foreach (@a) {
my $s = $_->{text};
$s =~ m/^(\s*)/;
next if "$'" eq '';
$n = length($1) if $n > length($1);
}
return @a if $n == 0;
return map {
my $s = $_->{text};
if ($n < length($s)) {
$s = substr($s, $n);
} else {
$s = '';
}
$_->{text} = $s;
$_
} @a;
}
sub emit {
my $output = shift;
my $output_filename = shift;
my @lines = @_;
my $loc_format;
my $lang = ($opt_lang || $g_curr_lang);
$loc_format = $loc_formats{$lang} if ($lang && $opt_loc);
my $last_file;
my $last_ln;
dbg("emit: ", scalar(@lines), " lines");
my $ln = 1;
foreach (@lines) {
if ($loc_format) {
if (($last_file ne $_->{file}) || ($last_ln+1 != $_->{ln})) {
my $x = &$loc_format($_->{file}, $_->{ln});
print $output $x;
}
$last_file = $_->{file};
$last_ln = $_->{ln};
} elsif ($output_source_map) {
print $output_source_map "$output_filename:$ln:$_->{file}:$_->{ln}\n";
$ln++;
}
print $output $_->{text},"\n";
}
}
use Data::Dumper;
sub docgen_html {
my $zf = shift;
my $old = select(shift);
print "<!DOCTYPE HTML>\n\n<html>\n<head>\n <meta charset=\"UTF-8\">\n <meta name=\"viewport\" content=\"width=device-width, initial-scale=1\">\n\n<link rel=\"stylesheet\" href=\"https://cdn.jsdelivr.net/gh/highlightjs/cdn-release\@10.7.3/build/style...
print "<script>";
print "window.zen = ";
print JSON::encode_json({
last_modified => $zf->{last_modified},
size => $zf->{size},
});
print "</script>";
print '<div class="container">';
print '<aside class="col foldable narrow">';
print '<div class="col-header sticky-top">';
print '<span class="fill-parent">';
if ($opt_live) {
print '<a href="/">home</a>';
print '<a href="..">up</a>';
}
print '</span>';
print '<span class="flex fill-parent collapse" id="search">';
print '<button click="cancel-search">cancel</button>';
print '<input type="text" id="search-text"></input>';
print '</span>';
print "<button click=\"search\">search</button>";
print "<button click=\"expand\">++</button>";
print "<button click=\"fold\">fold</button>";
print '</div>';
print '<article>';
print '<section id="tags"></section>';
print '<section class="vskip">';
foreach (@sections) {
my $section = $_;
next if is_section_hidden($section);
my $level = $section->{level};
my $id = $section->{id};
print "<a class=\"L-$level\" href=\"#$id\">$section->{heading}</a><br>\n";
}
print '</section></article>';
print '</aside>';
my @cols = ([]);
foreach my $section (@sections) {
next if is_section_hidden($section);
if (exists $section->{fields}->{break}) {
push @cols, [];
}
push @{$cols[-1]}, $section;
}
foreach my $col (@cols) {
next if scalar @{$col} == 0;
print "<div class=\"col foldable\">";
print "<div class=\"col-header\">";
print '<span class="fill-parent">', scalar @{$col}, ' sections</span>';
print "<button click=\"show-outline\">outline</button>";
print "<button click=\"expand\">+</button>";
print "<button click=\"fold\">fold</button>";
print "</div>";
print "<article>";
use Carp qw<longmess>;
sub err
{
my $msg = shift;
my $i = 0;
print STDERR "! Error: $msg\n";
foreach (@env_chain) {
print STDERR " $i: ",$_->{__loc},"\n";
$i++;
}
my $mess = longmess();
print Dumper( $mess );
exit(1);
}
if ($opt_port) {
use warnings;
use strict;
{
package App::zen::WebServer;
use HTTP::Server::Simple::CGI;
use base qw(HTTP::Server::Simple::CGI);
use File::Slurp;
use File::stat;
use JSON;
use Fcntl qw(:flock);
use POSIX qw( strftime );
use Data::Dumper;
my %mimeTypes = (
html => 'text/html',
css => 'text/css',
js => 'text/javascript',
json => 'application/json',
svg => 'image/svg+xml',
png => 'image/png',
jpeg => 'image/jpeg',
jpg => 'image/jpeg',
gif => 'image/gif',
txt => 'text/plain',
);
sub handle_request {
my ($self, $cgi) = @_;
my $path = $cgi->path_info();
my $method = $cgi->request_method();
if ($method eq 'GET' && $path =~ m/\/$/) {
on_list_dir($cgi, ".$path");
} elsif ($method eq 'GET' && $path eq '/hello') {
on_hello($cgi);
} elsif ($method eq 'GET') {
on_get_file($cgi, ".$path");
} elsif ($method eq 'POST') {
on_append_file($cgi, ".$path");
} elsif ($method eq 'PUT') {
on_put_file($cgi, ".$path");
} else {
print "HTTP/1.0 400 Bad Request\r\n\r\nUnsupported Request\n";
}
}
# Should return the data since last fetch offset.
sub on_append_file {
my ($cgi, $path) = @_;
my $data = $cgi->param('POSTDATA');
append_to_file($path, $data);
my @stat_info = stat($path);
if (@stat_info) {
# Extract the last modification time
my $mtime = $stat_info[9];
print "HTTP/1.0 200 OK\r\n";
print "Last-Modified: $mtime\r\n";
print "Content-Length: 0\r\n\r\n";
} else {
print "HTTP/1.0 500 Server error\r\n";
}
}
sub write_error {
my ($code, $message, $body) = @_;
print "HTTP/1.1 $code $message\r\n\r\n";
print $body, "\n";
}
sub on_put_file {
my ($cgi, $path) = @_;
my $l = $cgi->url_param('l') || 0;
my $n = $cgi->url_param('n') || 0;
my $last_mtime = $cgi->url_param('last_modified');
if (-f $path) {
# override require last_mtime
my $stat = stat($path);
my $mtime = $stat->mtime;
if (!$last_mtime) {
write_error(409, "Conflict", "Missing query parameter 'last_modified' l=$l");
print Dumper $cgi;
return;
}
if ($last_mtime != $mtime) {
write_error(409, "Conflict", "last modified doesn't match: $mtime");
return;
}
}
my $data = $cgi->param('PUTDATA');
if ($l == 0) {
write_file($path, $data);
} elsif ($l > 0) {
$data .= "\n" unless !$data || substr($data, -1) eq "\n";
open my $fh, '<', $path or die "Can not open file: $!";
my $x = '';
my $y = '';
while (<$fh>) {
if ($l > 1) {
$x .= $_;
$l--;
} elsif ($l == 1) {
if ($n <= 0) {
$y .= $_;
} else {
$n--;
}
}
}
close $fh;
write_file($path, $x.$data.$y);
} else {
print "HTTP/1.0 400 Bad request\r\n";
return;
}
my $mtime = stat($path)->mtime;
if ($mtime) {
print "HTTP/1.0 200 OK\r\n";
print "Last-Modified: $mtime\r\n";
print "Content-Length: 0\r\n\r\n";
} else {
print "HTTP/1.0 500 Server error\r\n";
}
}
sub on_get_file {
my ($cgi, $path) = @_;
if (-d $path) {
print "HTTP/1.1 301 Moved Permanently\r\n";
print "Location: ", $cgi->path_info(), "/\r\n";
print "\r\n";
return;
}
unless (-f $path) {
print "HTTP/1.0 404 Not found\r\n";
print $cgi->header,
$cgi->start_html('Not found'),
$cgi->h1('Not found'),
$path,
$cgi->end_html;
return;
}
my $raw = $cgi->param('raw') || 0;
my $l = $cgi->param('l') || 0;
my $n = $cgi->param('n') || 0;
if ($path =~ m/\.(md|zen)$/ && ($raw ne '1')) {
print "HTTP/1.0 200 OK\r\n";
( run in 1.083 second using v1.01-cache-2.11-cpan-0bb4e1dffa6 )