CatalystX::Usul::Model::Help - Create HTML from POD

   package MyApp::Model::Help;

   use base qw(CatalystX::Usul::Model::Help);

   1;

   package MyApp::Controller::Foo;

   sub bar {
      my ($self, $c) = @_;

      $c->model( q(Help) )->get_help( $c->stash, q(Foo) );
   }

   $self->model( q(Help) )->documentation( $uri );

# @(#)$Id: Help.pm 576 2009-06-09 23:23:46Z pjf $

package CatalystX::Usul::Model::Help;

use strict;
use warnings;
use version; our $VERSION = qv( sprintf '0.3.%d', q$Rev: 576 $ =~ /\d+/gmx );
use parent qw(CatalystX::Usul::Model);

use CatalystX::Usul::Table;
use Class::C3;
use File::Spec;
use Pod::Html;

my $NUL  = q();
my $SEP  = q(/);
my $SPC  = q( );

__PACKAGE__->mk_accessors( qw(default_css libsdir name) );

sub new {
   my ($self, $app, @rest) = @_;

   my $new      = $self->next::method( $app, @rest );
   my $app_conf = $app->config || {};

   $new->default_css( $app_conf->{default_css} );
   $new->libsdir    ( $app_conf->{libsdir    } );
   $new->name       ( $app_conf->{name       } );

   return $new;
}

sub documentation {
   my ($self, $uri) = @_;

   $self->add_field( { path => $uri, subtype => q(html), type => q(file) } );
   return;
}

sub feedback_form {
   my ($self, @rest) = @_;
   my $s             = $self->context->stash;
   my $subject       = $self->query_value( q(subject) );
   my $form          = $s->{form}->{name};

   $subject ||= $self->loc( $form.q(.subject), $self->name, join $SEP, @rest );
   ($s->{html_subject} = $subject) =~ s{ \s+ }{ }gmx;

   $self->add_header;
   $self->clear_form(  { firstfld => $form.q(.body),
                         title    => $self->loc( $form.q(.title) ) } );
   $self->add_field(   { id       => $form.q(.body) } );
   $self->add_hidden(  q(subject), $subject );
   $self->add_buttons( qw(Send) );
   return;
}

sub feedback_send {
   my $self    = shift;
   my $s       = $self->context->stash;
   my $subject = $self->query_value( q(subject) ) || $self->name.' feedback';
   my $args    = { attributes  => { charset      => $s->{encoding},
                                    content_type => q(text/html) },
                   body        => $self->query_value( q(body) ) || $NUL,
                   from        => $s->{user_email},
                   mailer      => $s->{mailer},
                   mailer_host => $s->{mailer_host},
                   subject     => $subject,
                   to          => $s->{feedback_email} };

   $self->add_result( $self->send_email( $args ) );
   return;
}

sub get_help {
   # Generate the context sensitive help from the POD in the code
   my ($self, @args) = @_; my $e;

   return unless ($args[ 0 ]);

   my $controller = ucfirst ((split m{ \# }mx, $args[ 0 ])[ 0 ]);
   my $title      = $self->loc( q(helpTitle), $controller );

   $self->clear_form( { title => $title } );

   my $src   = $self->catfile( $self->libsdir,
                               $self->catfile( split m{ :: }mx, $self->name ),
                               q(Controller),
                               $controller.q(.pm) );
   my $page  = eval { $self->retrieve( $src ) };

   if ($e = $self->catch) { $self->add_error( $e ) }
   else { $self->stash_content( $page, q(sdata) ) }

   return;
}

sub module_docs {
   my ($self, $module) = @_; my $c = $self->context; my $s = $c->stash; my $e;

   my $model = $c->model( q(Navigation) );

   $model->select_this( 0, 2 );
   $model->append_to_selected( 0, $SEP.$module );

   my $title = $self->loc( q(helpTitle), $module );

   $self->clear_form( { title => $title } );

   my $page  = eval { $self->retrieve( $self->find_source( $module ) ) };

   if ($e = $self->catch) { $self->add_error( $e ) }
   else { $self->stash_form( $page ) }

   return;
}

sub module_list {
   my $self = shift; my $s = $self->context->stash; my $name;

   # Otherwise lots from modules that don't set VERSION
   no warnings; ## no critic

   my $count = 0;
   my $table = CatalystX::Usul::Table->new
      ( align  => { help    => 'center',
                    name    => 'left',
                    source  => 'center',
                    version => 'right' },
        flds   => [ qw(source help name version) ],
        hclass => { help    => q(minimal),
                    name    => q(most),
                    source  => q(minimal),
                    version => q(some) },
        labels => { help    => q( ),
                    name    => 'Module Name',
                    source  => q( ),
                    version => 'Version' } );

   for my $path (sort keys %INC) {
      next if ($path =~ m{ \A [/] }mx);

      ($name = $path) =~ s{ [/] }{::}gmx; $name =~ s{ \.pm }{}gmx;

      my $href  = $self->uri_for( $SEP.q(module_docs), $s->{lang}, $name );
      my $vsap  = q(root).$SEP.q(view_source);
      my $sref  = $self->uri_for( $vsap, $s->{lang}, $name );
      my $flds  = {};

      $flds->{name   } = $name;
      $flds->{help   } = _make_icon( 'Doucumentation',
                                     $s->{assets}.'help.gif', $href );
      $flds->{source } = _make_icon( 'Source', $s->{assets}.'f.gif', $sref );
      $flds->{version} = eval { $name->VERSION() };

      push @{ $table->values }, $flds;
      $count++;
   }

   $table->count( $count );
   $self->add_field(    { data => $table, type => q(table) } );
   $self->group_fields( { id   => q(module_list.select), nitems => 1 } );
   return;
}

sub overview {
   my $self = shift;

   $self->add_field ( { name => q(overview), type => q(label) } );
   $self->stash_meta( { id   => q(overview) } );
   delete $self->context->stash->{token};
   return;
}

sub retrieve {
   my ($self, $src) = @_; my $s = $self->context->stash; my $line;

   no warnings; ## no critic

   my $body = 0; my $page = $NUL; my $tmp = $self->tempfile;

   pod2html( '--backlink='.$self->loc( q(Back to Top) ),
             '--cachedir='.$self->tempdir,
             '--css='.$self->catfile( $s->{assets}, $self->default_css ),
             '--infile='.$src,
             '--outfile='.$tmp->pathname,
             '--quiet',
             '--title='.$s->{title} );

   while (defined ($line = $tmp->getline) ) {
      $body  = 0     if ($line =~ m{ \</body }mx);
      $page .= $line if ($body);
      $body  = 1     if ($line =~ m{ \<body }mx);
   }

   return $page;
}

# Private subroutines

sub _make_icon {
   my ($alt, $src, $href) = @_;

   return { container => 0,
            fhelp     => $alt,
            href      => $href,
            imgclass  => q(normal),
            sep       => q(),
            text      => $src,
            type      => q(anchor),
            widget    => 1 };
}

1;

__END__

# Local Variables:
# mode: perl
# tab-width: 3
# End: