view release on metacpan or  search on metacpan

bin/zen  view on Meta::CPAN

sub lookup {
  my ($name) = @_;
  foreach (@env_chain) {
    if (exists $_->{$name}) {
      return $_->{$name};
    }
  }
  return $global_vars->{$name} if exists $global_vars->{$name};

  if (exists $sections[0]->{fields}->{$name}) {
    return $sections[0]->{fields}->{$name}->{value};
  }

  return $ENV{$name} if exists $ENV{$name};
  err("lookup not found: '$name'");
}
#print lookup("HOME", [ "b",{ x1 => 1 },"a"]),"\n";

sub enter {
   my $loc = shift;
   my $env = { __loc => $loc };
   unshift @env_chain, $env;
   return $env;
}

sub leave {
  die "Env chain empty" if scalar(@env_chain)==0;
  shift @env_chain;
}

sub find_section
{
  my ($s,$ignore) = @_;
  my $ret;
  my $prefix;
  $prefix = $1 if ($s =~ m/(.+)\.\.\.$/);
  foreach (@sections) {
    my $section = $_;

    if ($prefix) {
      next if index($section->{heading}, $prefix) != 0;
    } elsif ($s ne $section->{heading}) {
      my $re = $section->{pattern};
      next unless ($s =~ m/^$re$/);
    }

    if ($ret) {
      err("find section: '$s' has two matches\n"
        . "  $section->{file}:$section->{ln}: $section->{heading}\n"
        . "  $ret->{file}:$ret->{ln}: $ret->{heading}");
    } else {
      $ret = $section;
    }
  }
  err("No section found for `$s'") unless ($ignore || $ret);
  return $ret;
}
sub load_zen_file
{
  my $filename = shift;
  my $st = stat($filename);
  my $mtime = $st->mtime;
  my $filesize = $st->size;

  open(my $fh, '<:encoding(UTF-8)', $filename)
    or die "Could not open file '$filename' $!";

  flock($fh, LOCK_EX) or die "Could not lock file '$filename' $!";

  my $ln = 0;
  my @lines = ();
  my $curr_section;
  my $curr_block;
  my $backticks;
  my $mark; # this can be useful to mark/label everything. to give them to everything.

  {
    my $level = 0;
    my $pattern;
    my $heading = '';
    die "$filename:$ln: previous code block not ended\n" if $curr_block;
    my $params = [];
    
    if ($pattern) {
      $pattern = trim1($pattern);
      $pattern =~ s/^#//;
      my @a = split /:/,$pattern;
      $pattern = $a[0];
      push @{$params}, split /,/,$a[1] if scalar(@a) > 1;
    }
    my $sec_id = $heading;
    $sec_id =~ s/[^A-Za-z0-9-]+/_/g;
    $sec_id = "sec-$sec_id";
    
    for (@sections) {
      if ($_->{id} eq $sec_id) {
        $sec_id .= "_$ln";
        last;
      }
    }
    
    $curr_section = {
      id      => $sec_id,
      type    => 'default',
      level   => $level,
      heading => $heading,
      pattern => $pattern,
      params  => $params,
      file    => $filename,
      refs    => [],
      ln      => $ln,
      defs    => [],
      labels  => {},
      blocks  => [],
      extra   => [],
      lines   => [],
      fields  => {},
      max_line_id   => 1
    };
    push @sections, $curr_section;
    if ($curr_section->{heading} =~ m/^--+\s*(.*)/) {

bin/zen  view on Meta::CPAN

  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";
      my $action = $cgi->param('action');
      my $section = $cgi->param('section');
      $action = 'view' unless $action;
      my $zenCommand = 'zen';
      $zenCommand = 'perl ./zen.pl' if -f './zen.pl';
      if ($action eq 'exec') {
         print "Content-Type: text/plain\r\n\r\n";
         open FH, "$zenCommand --exec \"$section\" $path|";
      } else {
        if (!$section) {
           print "Content-Type: text/html\r\n\r\n";
           open FH, "$zenCommand --live --html $path|";
        } else {
           print "Content-Type: text/plain\r\n\r\n";
           open FH, "$zenCommand --section \"$section\" $path|";
        }
      }
      while (<FH>) {
         print $_;
      }
      close FH;
    } elsif ($raw eq '1' && $l > 0) {
      my $mtime = stat($path)->mtime;
      print "HTTP/1.0 200 OK\r\n";
      print "Last-Modified: $mtime\r\n";
      print "Content-Type: text/plain\r\n\r\n";
      open my $fh, '<', $path or die "Can not open file: $!";
      while (<$fh>) {
        if ($l == 1) {
          last if $n == 0;
          print $_;
          $n--;
        } else {
          $l--;
        }
      }
      close $fh;
    } else {
      my ($ext) = $path =~ /\.([^.]+)$/;
      my $mime_type = $mimeTypes{lc($ext)} || 'application/octet-stream';
      open my $fh, '<:raw', $path or die "Cannot open file: $!";
      my $mtime = stat($path)->mtime;
      my $filesize = -s $path;
      print "HTTP/1.1 200 OK\r\n";
      print "Content-Type: $mime_type\r\n";
      print "Last-Modified: $mtime\r\n";
      print "Content-Length: $filesize\r\n";
      print "\r\n";
  
      # Print the binary content of the file to the CGI output
      binmode STDOUT;
      while (read $fh, my $buffer, 4096) {
          print $buffer;
      }
      close $fh;
    }
  }
  
  sub on_list_dir {
    my ($cgi, $path) = @_;
  
    if (!-d $path) {
      write_error(404, "Not found");
      return;
    }
  
    my @contents = ();
    opendir(my $dh, $path) or die "Cannot open directory: $!";
    while (my $file = readdir $dh) {
      next if $file =~ /^\./;
      next if $file =~ /~$/;
      my $filepath = "$path/$file";
      my $mtime = stat($filepath)->mtime;
      push @contents, {
        name => -d $filepath ? "$file/" : $file,
        size => -s "$path/$file",
        mtime => $mtime,
      };
    }
    @contents = sort { $a->{name} cmp $b->{name} } @contents;
  
    my $fmt = $cgi->param('fmt');
    if ($fmt) {
      if ($fmt eq "csv") {
        print "HTTP/1.1 200 OK\r\n";
        print "\r\n";
        for (@contents) {
          print "$_->{name},$_->{size},$_->{mtime}\n";
        }
        return;
      } elsif ($fmt eq 'json') {
        print "HTTP/1.1 200 OK\r\n";
        print "\r\n";
        print JSON::encode_json(\@contents);
        return;
      } else {
        write_error(400, "Bad parameter: unsupported fmt");
        return;
      }
    }
  
    print "HTTP/1.0 200 OK\r\n\r\n";
    print "<!doctype html>\n<html>\n  <head>\n    <meta charset=\"utf-8\">\n    <meta name=\"viewport\" content=\"width=device-width, initial-scale=1\">\n    <title>Index</title>\n    <style>\n      :root {\n        --navbar-height: 1.6rem;\n      }\...
    print "<div class=\"xxpad\"><h1>Index</h1>\n";
    print "<table>\n";
    print "<thead><tr class=\"sticky-top\"><th>Name</th><th>Size</th><th>Last Modified</th></tr></thead>\n";
    for (@contents) {
       my $timestr = strftime('%FT%TZ%z', localtime($_->{mtime}));
       print "<tr>";
       print "<td><a href=\"$_->{name}\">$_->{name}</a></td>";
       print "<td class=\"align-right\">$_->{size}</td>";
       print "<td>$timestr</td>";
       print "</tr>\n";
    }
    print "</table></div>";
    print "  </body>\n</html>";
  }
  
  sub on_hello {
      my $cgi  = shift;   # CGI.pm object
                              return if !ref $cgi;
  
      my $name = $cgi->param('name');
      open FH, "perl ./zen2.pl --html  $name|";
      while (<FH>) {
         print $_;
      }
      close FH
  }
  }
  
  my $server = App::zen::WebServer->new($opt_port);
  if ($opt_daemon) {