Bivio::UI::HTML::Widget::SourceCode
# Copyright (c) 2001-2010 bivio Software, Inc. All rights reserved.
# $Id$
package Bivio::UI::HTML::Widget::SourceCode;
use strict;
use Bivio::Base 'UI.Widget';
use Bivio::UI::ViewLanguageAUTOLOAD;
my($_HTML) = b_use('Bivio.HTML');
my($_C) = b_use('IO.Config');
my($_D) = b_use('Bivio.Die');
my($_CL) = b_use('IO.ClassLoader');
my($_F) = b_use('UI.Facade');
my($_SU) = b_use('Bivio.ShellUtil');
my($_IGNORE_POD) = {
'=for' => 1,
'=over' => 1,
'=back' => 1,
'=cut' => 1,
};
my($_CACHE);
$_C->register(my $_CFG = {
source_dir => $_C->REQUIRED,
});
sub handle_config {
my(undef, $cfg) = @_;
($_CFG->{source_dir} = $cfg->{source_dir}) =~ s,/+$,,;
$_CACHE = undef;
return;
}
sub initialize {
return;
}
sub render {
my($self, $source, $buffer) = @_;
my($req) = $source->get_request;
my($package) = $req->unsafe_get('path_info')
|| ($req->get('query') || {})->{'s'};
$_D->throw('NOT_FOUND')
unless $package;
$package =~ s{^/}{};
$_D->throw('NOT_FOUND') if Bivio::Die->catch_quietly(sub {
my($p) = $_CL->unsafe_map_require($package);
$package = $p
if $p;
});
$_D->throw('NOT_FOUND')
unless $package;
$_D->throw('NOT_FOUND')
unless my $file = _file($package, $req);
#TODO: remove this and do it inline always
my($lines) = [$_SU->do_backticks("/usr/local/bin/perl2html -c -s < '$file'")];
_reformat_pod($self, $lines);
_add_links($self, $lines, $package, $req);
_add_method_anchors($self, $lines);
$lines = join('', @$lines);
$lines =~ s{
]*}{]+>)?(=[chiobpfbe]\w+)\s?(.*?)()?$,) {
$in_pod = 1;
$pod = $2;
$doc = $3;
}
next
unless $in_pod;
if ($pod && $doc && $pod eq '=for' && $doc =~ s/^html\s//) {
$line =~ s/=for\shtml\s//;
next;
}
$line = _unescape_pod($line);
unless ($pod) {
$line = '# '.$line;
next;
}
$line =~ s/$pod\s?//;
if ($_IGNORE_POD->{$pod}) {
$line =~ s/$doc// if $doc;
$line =~ s/\n//;
}
else {
if ($doc) {
$doc = _unescape_pod($doc);
# the \Q calls quotemeta()
$line =~ s,\Q$doc,$doc,;
}
$line = '# '.$line;
}
if ($pod eq '=cut') {
$in_pod = 0;
}
}
return;
}
sub _require {
my($pkg) = @_;
# avoid autoloading other modules and corrupting this one
return ''
if $pkg =~ /AUTOLOAD/;
return $_D->eval(sub {$_CL->unsafe_map_require($pkg)});
}
sub _unescape_pod {
my($line) = @_;
$line =~ s,E,<,g;
$line =~ s,E,>,g;
$line =~ s,I<(.*?)>,$1,g;
$line =~ s,E<lt>,<,g;
$line =~ s,E<gt>,>,g;
$line =~ s,C<(.*?)>,
}{
}ig;
DIV_b_source_code_title(String($package))
->initialize_and_render($req, $buffer);
$$buffer .= $lines;
return;
}
sub render_source_link {
my($proto, $req, $source, $name, $buffer, $method) = @_;
Link(
$name,
URI({
task_id => 'SOURCE',
path_info => Bivio::UNIVERSAL->is_super_of($source)
? $source->as_classloader_map_name : $source,
$method ? (anchor => $method) : (),
}),
)->initialize_and_render($req, $buffer);
return;
}
sub _add_links {
my($self, $lines, $ignore_package, $req) = @_;
my($vars) = {};
my($render) = sub {
my($prefix, $map_name, $pkg, $var, $widget) = @_;
my($name) = $map_name || $pkg || $var || $widget;
if ($map_name) {
return $prefix . $map_name
unless _require($pkg = $map_name);
}
elsif ($pkg) {
return $pkg
unless _require($pkg);
}
elsif ($var) {
return $var
unless $pkg = $vars->{$var};
}
else {
# We prefer XHTMLWidget over other widgets. It's
# not easy to determine in which context a widget will
# be loaded.
foreach my $map (
'XHTMLWidget',
grep(/Widget/, @{$_CL->all_map_names}),
) {
last
if _require($pkg = "$map.$widget");
$pkg = undef;
}
return $widget
unless $pkg;
}
my($b);
$self->render_source_link($req, $pkg, $name, \$b);
return ($prefix || '') . $b;
};
foreach my $line (@$lines) {
$vars->{$1} = $2
if $line =~ m{my.*?\((\$_\w+)\).*use\(.*?'(\w+\.\w+)};
$line =~ s{
(\b|'|")([A-Z]\w+\.[A-Z]\w+)
| ((?:[A-Z]\w+::)+[A-Z]\w+)
| (\$_[A-Z0-9]+\b)
| (?<=[^:])(\b[A-Z]\w+)(?=\()
}{$render->($1, $2, $3, $4, $5)}exg;
}
return;
}
sub _add_method_anchors {
my($self, $lines) = @_;
foreach my $line (@$lines) {
$line =~ s{>(sub (\w+) <)}{>$1};
}
return;
}
sub _contains {
my($values, $item) = @_;
return grep($item eq $_, @$values) ? 1 : 0;
}
sub _file {
my($package, $req) = @_;
return ($_CACHE ||= {})->{$package} ||= _file_find($package, $req);
}
sub _file_find {
my($file, $req) = @_;
if ($file =~ /^View\./) {
$file =~ s/^View\.//;
$file .= '.bview';
$file = $_F->get_local_file_name('VIEW', $file, $req);
}
else {
$file =~ s,::,/,g;
$file = "$_CFG->{source_dir}/$file.pm";
}
return -f $file ? $file : undef;
}
sub _reformat_pod {
my($self, $lines) = @_;
my($in_pod) = 0;
foreach my $line (@$lines) {
my($pod, $doc);
if ($line =~ m,^($1,g;
$line =~ s,B<(.*?)>,$1,g;
$line =~ s,I<(.*?)>,$1,g;
$line =~ s,L<(.*?)\|.*?>,$1,g;
$line =~ s,L<(.*?)>,$1,g;
return $line;
}
1;