File Coverage

lib/CGI/Application/Plugin/HelpMan.pm

Criterion	Covered	Total	%
statement	59	140	42.1
branch	14	58	24.1
condition	2	19	10.5
subroutine	11	25	44.0
pod	8	10	80.0
total	94	252	37.3

package CGI::Application::Plugin::HelpMan;
use strict;
use warnings;
#use base 'CGI::Application';
use LEOCHARRE::DEBUG;
use Carp;
use Exporter;
use vars qw($VERSION @ISA @EXPORT_OK %EXPORT_TAGS);
@ISA = qw/ Exporter /;
@EXPORT_OK = (qw(
__abs_path_doc_to_html
__find_abs
__string_looks_like_command
__term_to_command
__term_to_namespace
_doc_html
_term_abs_path
hm_abs_tmp
hm_doc_body
hm_doc_title
hm_found_term_abs
hm_found_term_doc
hm_found_term_query
hm_set_term
hm_term_get
hm_help_title
hm_help_body
_hm_reset_data
_set_term_as_caller

));
%EXPORT_TAGS = (
   ALL => \@EXPORT_OK,
   basic => \@EXPORT_OK,
   all => \@EXPORT_OK,
);
$VERSION = sprintf "%d.%02d", q$Revision: 1.9 $ =~ /(\d+)/g;

# 1) is there something to look for?
sub hm_found_term_query {
   my $self = shift;
   $self->hm_term_get or return 0;
   return 1;
}

# 2) can we resolve it to disk?
sub hm_found_term_abs {
   my $self = shift;
   $self->_term_abs_path or return 0;
   return 1;
}

sub _term_abs_path {
   my $self = shift;
   $self->{_hm_data_}->{_term_abs_path} ||= __find_abs($self->hm_term_get) or return;
   return $self->{_hm_data_}->{_term_abs_path}
}

# 3) does it have doc?
sub hm_found_term_doc {
   my $self = shift;
   $self->_doc_html or return 0;
   return 1;
}

# body text for template
sub hm_doc_body {
   my $self = shift;
   my $html = $self->_doc_html or return 0;
   if( $html=~m/]*>(.+)<\/body>/si ){
      my $body = $1;

      # sometimes Pod::Html will output even when there's no doc.
      my $length = length($html);
      debug("length $length\n");
      # if less then 500, report nothing.
      $length > 500 or return 0;
      return $body;
   }
   return 0;
}

# title text for template
sub hm_doc_title {
   my $self = shift;
   my $title;

   my $html = $self->_doc_html or return 0;


   if( $html=~m/]*>(.+)<\/title>/si ){
      $title = $1;
      debug("[$title]via html\n");
      return $title;

   }
   elsif( $self->hm_term_get ){
      my $namespace = __term_to_namespace($self->hm_term_get);
      debug("[$namespace] via term to namespace\n");
      return $namespace;
   }

   return 0;
}

sub hm_abs_tmp {
   my $self = shift;
   my $d = $self->param('abs_tmp');
   $d ||= '/tmp';
   return $d;
}

# force set the term
sub hm_set_term {
   my $self = shift;
   my $term = shift;
   defined $term or confess('missing arg');
   $self->{_hm_data_}->{_man_searchterm} = $term;
   return 1;
}

# term from query string, then from namespace of caller, your cgi app
sub hm_term_get {
   my $self = shift;

   unless( $self->{_hm_data_}->{_man_searchterm} ){

      # first try from query
      my $term = $self->query->param('query');

      # then from caller
      $term ||= caller; # was using caller(1), wrong.
      $self->{_hm_data_}->{_man_searchterm} = $term;
      debug(" term is [$term]\n");
   }
   return $self->{_hm_data_}->{_man_searchterm};
}






# # private methods....

sub _doc_html {
   my $self = shift;
   unless(defined $self->{_hm_data_}->{_abs_path_htmlcode}){

      unless( $self->_term_abs_path ){
         warn("no abs path for term");
         $self->{_hm_data_}->{_abs_path_htmlcode} = 0;
         return 0;
      }
      my $help_runmode_name = $self->get_current_runmode;
      $help_runmode_name ||=undef;
      $self->{_hm_data_}->{_abs_path_htmlcode} =
         __abs_path_doc_to_html(
            $self->_term_abs_path, $self->hm_abs_tmp, $help_runmode_name );

      $self->{_hm_data_}->{_abs_path_htmlcode} ||=0;
   }

   return $self->{_hm_data_}->{_abs_path_htmlcode};
}


# GET TITLE AND BODY FOR THE CALLER, NOT A QUERY

sub hm_help_body {
   my $self = shift;
   $self->_set_term_as_caller;
   return $self->hm_doc_body;
}

sub hm_help_title {
   my $self = shift;
   $self->_set_term_as_caller;

   return $self->hm_doc_title;
}

sub _set_term_as_caller {
   my $self = shift;

   my $caller = caller(1);
   $caller or confess('caller should return');

   unless( $self->hm_term_get eq $caller ){
      $self->_hm_reset_data;
      $self->hm_set_term($caller);
   }

   return 1;
}


sub _hm_reset_data {
   my $self = shift;
   $self->{_hm_data_} =undef;
   return 1;
}


#######################################################################

# THE FOLLOWING SUBS ARE NOT OO

##############################
# get html

sub __abs_path_doc_to_html {
   my ($abs,$tmp,$runmode) = @_; defined $abs and defined $tmp or confess('missing args');
   debug("$abs\n");

   $runmode ||= 'help_view';
   debug("runomde = $runmode");
   # can we write to this place, the tmp place? # TODO $self->hm_abs_tmp ?
   chdir $tmp or confess("$!, cant chdir to $tmp"); # if you dont... breaks. because perl2html ne4eds to write a tmp file

   require Pod::Html;
   require File::Slurp;

   my $out = $tmp.'/helpman_temp_'. (int rand(600000));
   debug("$out\n");

	Pod::Html::pod2html($abs,
      "--outfile=$out",
     # "--verbose",
    # '--css=http://search.cpan.org/s/style.css'
      "--htmlroot=?rm=$runmode".'&query=', # WORKS for LINKING
      );
   #TODO needs work up there.

   my $html = File::Slurp::slurp($out) or warn("could not slurp $out");

  # debug("\n\n$html\n\n"); NO

   return $html;
}


#####################################
# find on disk

sub __find_abs {
   my $term = shift; $term or confess('missing arg');

   my $as_command = __term_to_command($term);
   my $as_namespace = __term_to_namespace($term);

   my $abs;

   require Pod::Simple::Search;
   my $pss = Pod::Simple::Search->new;
   if( $abs = $pss->find($as_namespace) ){
      debug("via namespace: [$as_namespace] -> $abs\n");
      return $abs;
   }
   elsif ( defined $as_command ){
      require File::Which;
      $abs = File::Which::which($as_command) or return;
      debug("via command: [$as_command] -> $abs\n");

      require Cwd;
      Cwd::abs_path( $abs ) or warn("cant resolve $abs") and return;
      return $abs;
   }
   return;
}

sub __term_to_command {
   my $term = shift; defined $term or return;
   $term=~s/^\s+|\s$//g;
   __string_looks_like_command($term) or return;
   return $term;
}

sub __string_looks_like_command {
   my $string = shift; $string or return;
   $string=~/^[a-z]+[\w\-]+[a-zA-Z]+$/ or return 0;
   return 1;
}

#turn some silly string into a namespace
sub __term_to_namespace {
   my $term = shift ; defined $term or confess('no term arg');
   debug($term);
	$term=~s/^\W|\W$//g;

	$term=~s/\/+/::/g;

	$term=~s/\.html?$|\.pm$|\.pl$//g;
   debug(": $term\n");
   return $term;
}



1;

__END__