view release on metacpan or  search on metacpan

lib/CGI/Application/Plugin/ViewCode.pm  view on Meta::CPAN

The name of the module to view. By default it is the module currently being run. Also,
since colons (':') aren't simply typed into URL's, you can just substitute '-' for '::'.

    ?rm=view_code?module=My-Base-Class

=item highlight

Boolean indicates whether syntax highlighting (using L<Syntax::Highlight::Perl::Improved>) 
is C<on> or C<off>. By default it is C<on>.

=item line_no

Boolean indicates whether the viewing of line numbers is C<on> or C<off>. By default it is C<on>.
It C<line_no> is on, you can also specify which line number you want to see by adding an anchor
to the link:

    ?rm=view_code#215

This will take you immediately to line 215 of the current application module.

=item pod

Boolean indicates whether POD is seen or not. By default it is seen>.

=back


=head2 view_pod

This extra run mode will accept the following arguments in the query string:

=over

=item module

The name of the module to view. By default it is the module currently being run. Also,
since colons (':') aren't simply typed into URL's, you can just substitute '-' for '::'.

    ?rm=view_pod?module=My-Base-Class

=back

=head1 AS A POPUP WINDOW

This plugin can be used in conjunction with L<CGI::Application::Plugin::DevPopup>. If we detect
that L<CGI::Application::Plugin::DevPopup> is running and turned on, we will create a sub-report
that includes the highlighted source code.


So you can simply do the following:

    BEGIN { $ENV{CAP_DEVPOPUP_EXEC} = 1; } # turn it on for real
    use CGI::Application::Plugin::DevPopup;
    use CGI::Application::Plugin::ViewCode;

Befault, this report will be the same thing produced by C<view_code>. If you want this
report to include the C<view_pod> report, simply set the the C<$ENV{CAP_VIEWCODE_POPUP_POD}>
to true. You can also turn off the C<view_code> report but setting 
C<$ENV{CAP_VIEWCODE_POPUP_CODE}> to false.

    # have the POD report, but not the code in the dev popup window
    BEGIN { 
        $ENV{CAP_DEVPOPUP_EXEC} = 1;       # turn it on for real
        $ENV{CAP_VIEWCODE_POPUP_POD} = 1;  # turn on POD report
        $ENV{CAP_VIEWCODE_POPUP_CODE} = 0; # turn off code report
    }
    use CGI::Application::Plugin::DevPopup;
    use CGI::Application::Plugin::ViewCode;

=cut

sub import {
    my $caller = scalar(caller);
    $caller->add_callback( init => \&_add_runmode );

    # if we are running under CGI::Application::Plugin::DevPopup
    if( $ENV{CAP_DEVPOPUP_EXEC} ) {
        # if we wan't to add the POD report
        if( exists $ENV{CAP_VIEWCODE_POPUP_POD} && $ENV{CAP_VIEWCODE_POPUP_POD} ) {
            $caller->add_callback( devpopup_report => \&_view_pod );
        }
        # include the view_code report by default unless it's turned off
        if(! (exists $ENV{CAP_VIEWCODE_POPUP_CODE} && !$ENV{CAP_VIEWCODE_POPUP_CODE}) ) {
            $caller->add_callback( devpopup_report => \&_view_code );
        }
    }
}

sub _add_runmode {
    my $self = shift;
    $self->run_modes( 
        view_code => \&_view_code,
        view_pod  => \&_view_pod
    );
}

sub _view_code {
    my $self = shift;
    my $query = $self->query;

    my %options;
    foreach my $opt qw(highlight line_no pod) {
        if( defined $query->param($opt) ) {
            $options{$opt} = $query->param($opt);
        } else {
            $options{$opt} = 1;
        }
    }
        
    # get the file to be viewed
    my $module = _module_name($query->param('module') || ref($self));
    # change into file name
    my $file = _module_file_name($module);

    # make sure the file exists
    if( $file && -e $file ) {
        my $IN;
        open($IN, $file) 
            or return _error("Could not open $file for reading! $!");
        my @lines= <$IN>;

        # if we aren't going to highlight then turn all colors/styles
        # into simple black
        my %styles = %DEFAULT_STYLES;
        my $style_sec = '';
        foreach my $style (keys %styles) {
            $styles{$style} = 'color:#000000;'
                if( !$options{highlight} );
            $style_sec .= ".$style { $styles{$style} }\n";
        }

        # now use Syntax::Highlight::Perl::Improved to do the work
        require Syntax::Highlight::Perl::Improved;
        my $formatter = Syntax::Highlight::Perl::Improved->new();
        $formatter->define_substitution(%SUBSTITUTIONS);
        foreach my $style (keys %styles) {
            $formatter->set_format($style, [qq(<span class="$style">), qq(</span>)]);
        }
        @lines = $formatter->format_string(@lines);
        
        # if we want line numbers
        if( $options{line_no} ) {
            my $i = 1;
            @lines = map { 
                (qq(<span class="LineNumber"><a name="$i">) . $i++ . qq(:</a></span>&nbsp;). $_) 
            } @lines;
        }

        # apply any other transformations necessary
        if( $options{highlight} || !$options{pod} ) {
            foreach my $line (@lines) {
                # if they don't want the pod
                if( !$options{pod} ) {
                    if( $line =~ /<span class="Comment_POD"/ ) {
                        $line = '';
                        next;
                    }
                }
                
                # if they are highlighting
                if( $options{highlight} ) {
                    if( $line =~ /<span class="Package">([^<]*)<\/span>/ ) {
                        my $package = $1;
                        my $link = $package;
                        $link =~ s/::/-/g;
                        my $rm = $self->mode_param();
                        $rm = ref $rm ? 'rm' : $rm; # not really anything we can do if their mode_param returns a sub ref
                        $link = "?$rm=view_code&amp;module=$package;view_code_no_popup=1";
                        $line =~ s/<span class="Package">[^<]*<\/span>/<a class="Package" href="$link">$package<\/a>/;
                    }    
                }
            }
        }
        my $code = join('', @lines);

        # if we are under CGI::Application::Plugin::DevPopup then let's create this as a report instead
        if( $ENV{CAP_DEVPOPUP_EXEC} && !$query->param('view_code_no_popup') ) {
            $self->devpopup->add_report(
                title   => 'View Code',
                summary => "View code of $module", 
                report  => "<style>$style_sec</style><pre>$code</pre>",
            );
        } else {
            return qq(
            <html>
            <head>
                <title>$module - View Source</title>
                <style>$style_sec</style>
            </head>
            <body>
                <pre>$code</pre>
            </body>
            </html>
            );
        }
    } else {
        return _error( ($file ? "File $file " : "Module $module ") . "does not exist!");
    }
}

sub _view_pod {
    my $self = shift;
    my $query = $self->query;

    # get the file to be viewed
    my $module = _module_name($query->param('module') || ref($self));
    # change into file name
    my $file = _module_file_name($module);

    # make sure the file exists
    if( $file && -e $file ) {
        require Pod::Xhtml;
        my $pod_parser = new Pod::Xhtml(
            StringMode   => 1,
            MakeIndex    => 0,
            FragmentOnly => 1,
            TopLinks     => 0,
            MakeMeta     => 0,
        );
        $pod_parser->parse_from_file($file);
        my $pod = $pod_parser->asString;

        # if we are under CGI::Application::Plugin::DevPopup then let's create this as a report instead
        if( $ENV{CAP_DEVPOPUP_EXEC} && !$query->param('view_code_no_popup') ) {
            $self->devpopup->add_report(
                title   => 'View POD',
                summary => "View POD of $module", 
                report  => "<pre>$pod</pre>",
            );
        } else {
            return qq(
            <html>
            <head>
                <title>$module - View POD</title>
            </head>
            <body>
                <pre>$pod</pre>
            </body>
            </html>
            );
        }
    } else {
        return _error( ($file ? "File $file " : "Module $module ") . "does not exist!");
    }
}


sub _module_name {
    my $name = shift;
    $name =~ s/-/::/g;  
    return $name;
}

sub _module_file_name {
    my $module = shift;
    # change into file name
    $module =~ s/::/\//g;
    $module .= '.pm';
    return $INC{$module};
}


sub _error {
    my $message = shift;
    return qq(
    <html>
      <head>
        <title>View Source Error!</title>
      </head>
      <body>
        <h1 style="color: red">Error!</h1>
        <strong>Sorry, but there was an error in your 
        request to view the source: 
        <blockquote><em>$message</em></blockquote>
      </body>
    </html>
    );
}

1;

__END__

=head1 SECURITY