File Coverage

blib/lib/Pod/Server.pm

Criterion	Covered	Total	%
statement	7	9	77.7
branch			n/a
condition			n/a
subroutine	3	3	100.0
pod			n/a
total	10	12	83.3

package Pod::Server;
use strict;
use warnings;
use Squatting;
use File::Which;
our $VERSION = '1.14';
$| = 1;

my $vim = which('vim');

our %CONFIG = (
  background_color          => '#112',
  foreground_color          => 'wheat',
  pre_background_color      => '#000',
  pre_foreground_color      => '#ccd',
  code_foreground_color     => '#fff',
  a_foreground_color        => '#fc4',
  a_hover_foreground_color  => '#fe8',
  font_size                 => '10pt',
  sidebar                   => 'right',
  first                     => 'Squatting',
  title                     => '#',
  tree                      => [],
  vim                       => $vim,
  vim_comment               => '#0cf',
  vim_constant              => '#0fc',
  vim_identifier            => '#0aa',
  vim_statement             => '#fc2',
  vim_preproc               => '#8fc',
  vim_type                  => '#2e8b57',
  vim_special               => '#6a5acd',
  vim_underlined            => '#fff',
  vim_error_bg              => '#f00',
  vim_error_fg              => '#fff',
  vim_todo_bg               => '#fc2',
  vim_todo_fg               => '#222',
);

sub init {
  my $app = shift;
  Pod::Server::Controllers::scan();
  my $have_vim = eval { require Text::VimColor };
  if (not $have_vim) {
    $CONFIG{vim} = undef;
  }
  $app->next::method;
}

package Pod::Server::Controllers;
use strict;
use warnings;
use File::Basename;
use File::Find;
use File::Which;
use Config;
use aliased 'Pod::Simple::Search';
use aliased 'Squatting::H';

# skip files we've already seen
my %already_seen;

# figure out where all(?) our pod is located
# (loosely based on zsh's _perl_basepods and _perl_modules)
our %perl_basepods;

our %perl_programs;
our @perl_programs;

our %perl_modules;
our @perl_modules;
sub scan {
  no warnings;
  warn "scanning for POD...\n";

  if ($Config{man1ext} ne "1") {
    %perl_programs = map {
      my ($file, $path, $suffix) = fileparse($_, qr/\.$Config{man1ext}.*$/);
      $already_seen{$_} = 1;
      ("$file" => which($file) || $_);
    } (
      glob("$Config{installman1dir}/*.$Config{man1ext}*"),
      glob("$Config{installsiteman1dir}/*.$Config{man1ext}*"),
      glob("$Config{installvendorman1dir}/*.$Config{man1ext}*")
    );
  }

  my $search = Search->new;
  $search->limit_glob('*');
  $search->progress(H->new({
    reach => sub {
      print ".";
    },
    done => sub {
      print "\n";
    },
  }));

  my $survey;
  if (scalar(@{$CONFIG{tree}})) {
    $search->inc(0);
    $survey = $search->survey(@{$CONFIG{tree}});
  }
  else {
    $survey = $search->survey;
  }

  for (keys %$survey) {
    my $key = $_;
    $key =~ s/::/\//g;
    $perl_modules{$key} = $survey->{$_};
  }
  @perl_modules  = sort keys %perl_modules;
  @perl_programs = sort keys %perl_programs;
}
%already_seen = ();

# *.pod takes precedence over *.pm
sub pod_for {
  for ($_[0]) {
    return $_ if /\.pod$/;
    my $pod = $_;
    $pod =~ s/\.pm$/\.pod/;
    if (-e $pod) {
      return $pod;
    }
    return $_;
  }
}

# *.pm takes precedence over *.pod
sub code_for {
  for ($_[0]) {
    return $_ if /\.pm$/;
    my $pm = $_;
    $pm =~ s/\.pod$/\.pm/;
    if (-e $pm) {
      return $pm;
    }
    return $_;
  }
}

# cat out a file
sub cat {
  my $file = shift;
  open(CAT, $file) || return;
  return join('', );
}

our @C = (

  C(
    Home => [ '/' ],
    get  => sub {
      my ($self) = @_;
      $self->v->{title} = $Pod::Server::CONFIG{title};
      if (defined $self->input->{base}) {
        $self->v->{base} = 'pod';
      }
      $self->render('home');
    }
  ),

  C(
    Frames => [ '/@frames' ],
    get    => sub {
      my ($self) = @_;
      $self->v->{title} = $Pod::Server::CONFIG{title};
      $self->render('_frames');
    }
  ),

  C(
    Rescan => [ '/@rescan' ],
    get => sub {
      my ($self) = @_;
      $Pod::Server::Views::HOME = undef;
      %already_seen  = ();
      %perl_basepods = ();
      %perl_programs = ();
      @perl_programs = ();
      %perl_modules  = ();
      @perl_modules  = ();
      scan();
      "OK";
    }
  ),

  C(
    Source => [ '/@source/(.*)' ],
    get => sub {
      my ($self, $module) = @_;
      my $v = $self->v;
      my $pm = $module; $pm =~ s{/}{::}g;
      my $pm_file;
      $v->{path} = [ split('/', $module) ];
      $v->{title} = "$Pod::Server::CONFIG{title} - $pm";
      if (exists $perl_modules{$module}) {
        $v->{file} = code_for $perl_modules{$module};
        if ($Pod::Server::CONFIG{vim}) {
          my $vim    = Text::VimColor->new(file => $v->{file});
          $v->{code} = $vim->html;
        } else {
          $v->{code} = cat $v->{file};
        }
        $self->render('source');
      } elsif (exists $perl_basepods{$module}) {
        $v->{file} = code_for $perl_basepods{$module};
        if ($Pod::Server::CONFIG{vim}) {
          my $vim    = Text::VimColor->new(file => $v->{file});
          $v->{code} = $vim->html
        } else {
          $v->{code} = cat $v->{file};
        }
        $self->render('source');
      } elsif (exists $perl_programs{$module}) {
        $v->{file} = $perl_programs{$module};
        if ($Pod::Server::CONFIG{vim}) {
          my $vim    = Text::VimColor->new(file => $v->{file});
          $v->{code} = $vim->html
        } else {
          $v->{code} = cat $v->{file};
        }
        $self->render('source');
      } else {
        $self->render('pod_not_found');
      }
    }
  ),

  # The job of this controller is to take $module
  # and find the file that contains the POD for it.
  # Then it asks the view to turn the POD into HTML.
  C(
    Pod => [ '/(.*)' ],
    get => sub {
      my ($self, $module) = @_;
      my $v        = $self->v;
      my $pm       = $module; $pm =~ s{/}{::}g;
      $v->{path}   = [ split('/', $module) ];
      $v->{module} = $module;
      $v->{pm}     = $pm;
      if (exists $perl_modules{$module}) {
        $v->{pod_file} = pod_for $perl_modules{$module};
        $v->{title} = "$Pod::Server::CONFIG{title} - $pm";
        $self->render('pod');
      } elsif (exists $perl_basepods{$module}) {
        $v->{pod_file} = pod_for $perl_basepods{$module};
        $v->{title} = "$Pod::Server::CONFIG{title} - $pm";
        $self->render('pod');
      } elsif (exists $perl_programs{$module}) {
        $v->{pod_file} = $perl_programs{$module};
        $v->{title} = "$Pod::Server::CONFIG{title} - $pm";
        $self->render('pod');
      } else {
        $v->{title} = "$Pod::Server::CONFIG{title} - $pm";
        $self->render('pod_not_found');
      }
    }
  ),

);

package Pod::Server::Views;
use strict;
use warnings;
use Data::Dump 'pp';
use HTML::AsSubs;
use Pod::Simple;
use Pod::Simple::HTML;
$Pod::Simple::HTML::Perldoc_URL_Prefix = '/';

# the ~literal pseudo-element -- don't entity escape this content
sub x {
  HTML::Element->new('~literal', text => $_[0])
}

our $JS;
our $HOME;
our $C = \%Pod::Server::CONFIG;

our @V = (
  V(
    'html',

    layout => sub {
      my ($self, $v, @content) = @_;
      html(
        head(
          title($v->{title}),
          style(x($self->_css)),
          (
            $v->{base}
              ? base({ target => $v->{base} })
              : ()
          ),
        ),
        body(
          div({ id => 'menu' },
            a({ href => R('Home')}, "Home"), ($self->_breadcrumbs($v))
          ),
          div({ id => 'pod' }, @content),
        ),
      )->as_HTML;
    },

    _breadcrumbs => sub {
      my ($self, $v) = @_;
      my @breadcrumb;
      my @path;
      for (@{$v->{path}}) {
        push @path, $_;
        push @breadcrumb, a({ href => R('Pod', join('/', @path)) }, " > $_ ");
      }
      @breadcrumb;
    },

    _css => sub {qq|
      body {
        background: $C->{background_color};
        color: $C->{foreground_color};
        font-family: 'Trebuchet MS', sans-serif;
        font-size: $C->{font_size};
      }
      h1, h2, h3, h4 {
        margin-left: -1em;
        margin-bottom: 4px;
      }
      dl {
        margin: 0;
        padding: 0;
      }
      dt {
        margin: 1em 0 1em 1em;
      }
      dd {
        margin: -0.75em 0 0 2em;
        padding: 0;
      }
      em {
        padding: 0.25em;
        font-weight: bold;
      }
      pre {
        font-size: 9pt;
        font-family: "DejaVu Sans Mono", "Bitstream Vera Sans Mono", monospace;
        background: $C->{pre_background_color};
        color: $C->{pre_foreground_color};
      }
      code {
        font-size: 9pt;
        font-weight: bold;
        color: $C->{code_foreground_color};
      }
      a {
        color: $C->{a_foreground_color};
        text-decoration: none;
      }
      a:hover {
        color: $C->{a_hover_foreground_color};
      }
      div#menu {
        position: fixed;
        top: 0;
        left: 0;
        width: 100%;
        background: #000;
        color: #fff;
        opacity: 0.75;
      }
      ul#list {
        margin-left: -6em;
        list-style: none;
      }
      div#pod {
        width: 580px;
        margin: 2em 4em 2em 4em;
      }
      div#pod pre {
        padding: 0.5em;
        border: 1px solid #444;
        border-radius: 7px;
      }
      div#pod h1 {
        font-size: 24pt;
        border-bottom: 2px solid $C->{a_hover_foreground_color};
      }
      div#pod p {
        margin: 0.75em 0 1em 0;
        line-height: 1.4em;
      }
    |},

    home => sub {
      my ($self, $v) = @_;
      $HOME ||= div(
        a({ href => R('Home'),   target => '_top' }, "no frames"),
        em(" | "),
        a({ href => R('Frames'), target => '_top' }, "frames"),
        ul({ id => 'list' },
          li(em(">> Modules <<")),
          (
            map {
              my $pm = $_;
              $pm =~ s{/}{::}g;
              li(
                a({ href => R('Pod', $_) }, $pm )
              )
            } (sort @perl_modules)
          ),
          li(em(">> Executables <<")),
          (
            map {
              li(
                a({ href => R('Pod', $_) }, $_ )
              )
            } (sort @perl_programs),
          )
        )
      );
    },

    _frames => sub {
      my ($self, $v) = @_;
      html(
        head(
          title($v->{title})
        ),
        ($C->{sidebar} eq "right"
          ?
          frameset({ cols => '*,340' },
            frame({ name => 'pod',  src => R('Pod', $C->{first}) }),
            frame({ name => 'list', src => R('Home', { base => 'pod' }) }),
          )
          :
          frameset({ cols => '340,*' },
            frame({ name => 'list', src => R('Home', { base => 'pod' }) }),
            frame({ name => 'pod',  src => R('Pod', $C->{first}) }),
          )
        ),
      )->as_HTML;
    },

    pod => sub {
      my ($self, $v) = @_;
      my $out;
      my $pod = Pod::Simple::HTML->new;
      $pod->index(1);
      $pod->output_string(\$out);
      $pod->parse_file($v->{pod_file});
      $out =~ s/^.*//s;
      $out =~ s/.*$//s;
      $out =~ s/^(.*%3A%3A.*)$/my $x = $1; ($x =~ m{indexItem}) ? 1 : $x =~ s{%3A%3A}{\/}g; $x/gme;
      (
        x($out),
        $self->_possibilities($v),
        $self->_source($v),
      );
    },

    pod_not_found => sub {
      my ($self, $v) = @_;
      div(
        p("POD for $v->{pm} not found."),
        $self->_possibilities($v)
      )
    },

    _possibilities => sub {
      my ($self, $v) = @_;
      my @possibilities = grep { /^$v->{module}/ } @perl_modules;
      @possibilities    = grep { /^$v->{module}/ } @perl_programs if(not(@possibilities));
      my $colon = sub { my $x = shift; $x =~ s{/}{::}g; $x };
      hr,
      ul(
        map {
          li(
            a({ href => R('Pod', $_) }, $colon->($_))
          )
        } @possibilities
      );
    },

    _source => sub {
      my ($self, $v) = @_;
      hr,
      h4(a({ href => R('Source', $v->{module} )},
        "Source Code for " .
        Pod::Server::Controllers::code_for($v->{pod_file})
      ));
    },

    _vim_syntax_css => sub {qq|
      .synComment    { color: $C->{vim_comment} }
      .synConstant   { color: $C->{vim_constant} }
      .synIdentifier { color: $C->{vim_identifier} }
      .synStatement  { color: $C->{vim_statement}  ; font-weight: bold; }
      .synPreProc    { color: $C->{vim_preproc} }
      .synType       { color: $C->{vim_type}       ; font-weight: bold; }
      .synSpecial    { color: $C->{vim_special} }
      .synUnderlined { color: $C->{vim_underlined} ; text-decoration: underline; }
      .synError      { color: $C->{vim_error_fg}   ; background: $C->{vim_error_bg}; }
      .synTodo       { color: $C->{vim_todo_fg}    ; background: $C->{vim_todo_bg};  }
    |},

    source => sub {
      my ($self, $v) = @_;
      style("div#pod { width: auto; }"),
      ($C->{vim}
        ?
        ( style(x($self->_vim_syntax_css)),
          pre(x($v->{code})) )
        :
        ( pre($v->{code}) )
      )
    },

  )
);

1;

__END__