File Coverage

blib/lib/Padre/Plugin/Plack.pm

Criterion	Covered	Total	%
statement	10	12	83.3
branch			n/a
condition			n/a
subroutine	4	4	100.0
pod			n/a
total	14	16	87.5

package Padre::Plugin::Plack;
use base 'Padre::Plugin';

use warnings;
use strict;

use Padre::Util ('_T');
use Padre::Debug;

our $VERSION = '0.01';

# Declare the Padre interfaces this plugin uses
sub padre_interfaces {
    'Padre::Plugin' => 0.29;
}

# Declare ourselves as the handler for .psgi files
sub registered_documents {
    'application/x-psgi' => 'Padre::Document::PSGI';
}

# Static cache for the dot-psgi examples (read off disk)
my %PSGI_EXAMPLES;

# Create the plugin menu
sub menu_plugins {
    my $self = shift;
    my $main = shift;

    my $menu = Wx::Menu->new;

    my $app_menu = Wx::Menu->new;
    $menu->Append( -1, _T('New PSGI App'), $app_menu );

    for my $basename ( sort keys %PSGI_EXAMPLES ) {
        Wx::Event::EVT_MENU(
            $main,
            $app_menu->Append( -1, _T($basename) ),
            sub {
                $self->on_app_load( $PSGI_EXAMPLES{$basename} );
                return;
            },
        );
    }

    my $docs_menu = Wx::Menu->new;
    $menu->Append( -1, _T('Online References'), $docs_menu );

    Wx::Event::EVT_MENU(
        $main,
        $docs_menu->Append( -1, _T('plackperl.org') ),
        sub {
            Padre::Wx::launch_browser('http://plackperl.org');
        }
    );

    Wx::Event::EVT_MENU(
        $main,
        $docs_menu->Append( -1, _T('Plack Advent Calendar') ),
        sub {
            Padre::Wx::launch_browser('http://advent.plackperl.org');
        },
    );

    Wx::Event::EVT_MENU(
        $main,
        $menu->Append( -1, _T('About') ),
        sub { $self->on_about_load },
    );

    # Return it and the label for our plug-in
    return ( $self->plugin_name => $menu );
}

sub on_app_load {
    my $self = shift;
    my $file = shift;

    my $main = $self->main;

    # Slurp in the new app content from the template file
    my $template = Padre::Util::slurp($file);
    unless ($template) {

        # Rare failure, no need to translate
        $self->main->error("Failed to find template '$file'");
        return;
    }

    # Create new document editor tab
    $main->new_document_from_string( $$template, 'application/x-psgi' );
    my $editor = $main->current->editor;
    my $doc    = $editor->{Document};

    # N.B. It used to be necessary to deliberately use application/x-perl mime type and then rebless as
    # a hack to make syntax highlighting work off the bat, but it seems to work now
    #    $doc->set_mimetype('application/x-psgi');
    #    $doc->rebless;
    $self->on_doc_load($doc);

    # The tab exists, so trigger set_tab_icon
    $doc->set_tab_icon;
}

sub is_psgi_doc {
    my $self = shift;
    my $doc = shift;

    return $doc->isa('Padre::Document::PSGI') && $doc->can('get_mimetype') && $doc->get_mimetype eq 'application/x-psgi';
}

sub editor_enable {
    my $self     = shift;
    my $editor   = shift;
    my $doc      = shift;

    # Only respond to event on psgi docs
    return unless $self->is_psgi_doc($doc);

    TRACE('->editor_enable') if DEBUG;

    $self->on_doc_load($doc);

    # Deliberately don't trigger Padre::Document::PSGI::set_tab_icon here because the tab doesn't exist yet
    # (it gets triggered by our tomfoolery in Padre::Document::PSGI::restore_cursor_position)
}

sub editor_changed {
    my $self = shift;

    my $main = $self->main or return;
    my $editor = $main->current->editor or return;
    my $doc    = $editor->{Document}  or return;

    # Only respond to event on psgi docs
    return unless $self->is_psgi_doc($doc);

    TRACE('->editor_changed') if DEBUG;

    ## TODO: add check that doc is now selected (for safety)..
    $self->on_panel_load($doc);
}

sub on_panel_load {
    my $self = shift;
    my $doc = shift;

    if (!$doc->panel) {
        TRACE('->on_panel_load creating panel') if DEBUG;
        require Padre::Plugin::Plack::Panel;
        $doc->panel( Padre::Plugin::Plack::Panel->new($doc) );
    }

    # Show the panel, and pass an onclose callback
    Padre::Current->main->bottom->show( $doc->panel, sub {
        $self->main->error(q{Sorry Dave, I can't do that});

        # We can't actually cancel the close, so re-create it
        $self->plackdown($doc);
        $doc->panel(undef);
        $self->on_panel_load($doc);
    });
}

sub on_panel_close {
    my $self = shift;
    my $doc = shift;

    return unless $doc && $doc->panel;

    if (my $panel = $doc->panel) {
        $self->plackdown($doc);
        $self->main->bottom->hide( $panel );
        $doc->panel(undef);
    }
}

# Note that the new tab may or may not exist at this point
# When triggered by user opening a new file (e.g. from L), tab does not exist yet
# Whereas, when triggered by user creating new app from template, tab exists
sub on_doc_load {
    my $self = shift;
    my $doc  = shift;

    TRACE('->on_doc_load') if DEBUG;

    if ( !$doc->isa('Padre::Document::PSGI') ) {
        $self->error('Not a Padre::Document::PSGI, something is broken with Padre::Plugin::Plack');
        return;
    }

    # Set the icon path, but don't actually trigger set_icon_tab() just yet
    $doc->icon_path( $self->plugin_directory_share . "/icons/16x16/logo.png" );
    $doc->plugin($self);

    # Trigger the Document's general setup event
    $doc->on_load;

    # Show the panel
    $self->on_panel_load($doc);
}

sub on_doc_close {
    my $self = shift;
    my $doc  = shift;

    TRACE('->on_doc_close') if DEBUG;

    if ( !$doc->isa('Padre::Document::PSGI') ) {
        $self->error('Not a Padre::Document::PSGI, something is broken with Padre::Plugin::Plack');
        return;
    }

    $self->on_panel_close($doc);
}

sub on_about_load {
    require Plack;
    require Class::Unload;
    my $about = Wx::AboutDialogInfo->new;
    $about->SetName("Padre::Plugin::Plack");
    $about->SetDescription(
            _T('PSGI/Plack support for Padre') . "\n"
          . _T('by') . "\n"
          . 'Patrick Donelan ([e-mail])' . "\n\n"
          . _T('This system is running Plack version')
          . " $Plack::VERSION\n"
          . 'http://plackperl.org'
    );
    $about->SetVersion($VERSION);
    Class::Unload->unload('Plack');

    Wx::AboutBox($about);
    return;
}

sub load_dot_psgi_examples {
    my $self = shift;

    require File::Find::Rule;
    %PSGI_EXAMPLES =
      map { File::Basename::basename($_) => $_ }
      File::Find::Rule->file()->name('*.psgi')
      ->in( $self->plugin_directory_share . '/dot-psgi' );
}

sub plugin_enable {
    my $self = shift;

    $self->load_dot_psgi_examples;
}

sub plugin_disable {
    my $self = shift;

    # TODO: Loop over all docs and turn off their psgi goodies: panel, stop server, etc..

    # cleanup loaded classes
    require Class::Unload;
    Class::Unload->unload('Padre::Document::PSGI');
    Class::Unload->unload('Padre::Plugin::Plack::Panel');
}

sub plackup {
    my $self = shift;
    my $doc = shift;

    return unless $doc;
    TRACE('->plackup') if DEBUG;

    my $main     = $self->main;
    my $filename = $doc->filename;

    if (!$filename) {
        $main->on_save;
        $filename = $doc->filename;
        return unless $filename;
    }

    my $pwd = Cwd::cwd();
    chdir $doc->dirname;

    # Server ("Let plackup guess" means leave as unspecified)
    my $server = $doc->panel->{server}->GetValue;
    $server = $server eq _T('Let plackup guess') ? '' : "-s $server";

    # Port (required for browser url)
    my $port = $doc->panel->{port}->GetValue || 5000;
    $port = "-p $port";

    my $restart = $doc->panel->{restart}->GetValue ? '-r' : '';
    my $plackup_options = $doc->panel->{plackup_options}->GetValue;

    require File::Which;
    my $plackup = File::Which::which('plackup');
    if (!$plackup) {
        $main->error('Command "plackup" not found in $PATH, are you sure you have Plack installed correctly?');
        return;
    }

    my $cmd = qq{$plackup $port $restart $server $plackup_options "$filename"};
    TRACE("->plackup $cmd") if DEBUG;
    $self->run_command($doc, $cmd);

    # restore previous dir
    chdir $pwd;
}

sub plackdown {
    my $self = shift;
    my $doc = shift;

    return unless $doc;

    TRACE('->plackdown') if DEBUG;

    my $process = $doc->process;
    return unless $process;

    # sanity check
    if (!$process->IsAlive) {
        TRACE('->plackdown process was dead but not undef, strange') if DEBUG;
        $doc->process(undef);
    }

    my $processid = $process->GetProcessId();
    my $panel = $doc->panel;

    require Proc::Killfam;
    my @signals = qw(INT TERM QUIT KILL STOP);
    for my $sig (@signals) {
        TRACE( "Sending $sig to PID: $processid" ) if DEBUG;
        my $signalled = Proc::Killfam::killfam($sig, $processid);

        if ($panel->{restart}->GetValue) {
            # with auto-restart, we expect 3 processes
            return if $signalled > 1;
        } else {
            # otherwise, just one
            return if $signalled > 0;
        }
    }

    $panel->output->AppendText("\n" . "Process PID $processid did not respond, you may need to kill it manually\n" );
}

sub run_command {
    my ( $self, $doc, $command ) = (@_);

    my $panel = $doc->panel;

    # clear the panel
    $panel->output->Remove( 0, $panel->output->GetLastPosition );

    # If this is the first time a command has been run, set up the ProcessStream bindings.
    unless ($panel->{bound}) {
        TRACE(' setting up ProcessStream bindings') if DEBUG;

        require Wx::Perl::ProcessStream;
        if ( $Wx::Perl::ProcessStream::VERSION < .20 ) {
            $self->main->error(
                sprintf(
                    _T(
                            'Wx::Perl::ProcessStream is version %s'
                          . ' which is known to cause problems. Get at least 0.20 by typing'
                          . "\ncpan Wx::Perl::ProcessStream"
                    ),
                    $Wx::Perl::ProcessStream::VERSION
                )
            );
            return 1;
        }

        Wx::Perl::ProcessStream::EVT_WXP_PROCESS_STREAM_STDOUT(
            $panel->output,
            sub {
                $_[1]->Skip(1);
                my $outpanel = $_[0];
                $outpanel->style_good;
                $outpanel->AppendText( $_[1]->GetLine . "\n" );
                return;
            },
        );
        Wx::Perl::ProcessStream::EVT_WXP_PROCESS_STREAM_STDERR(
            $panel->output,
            sub {
                $_[1]->Skip(1);
                my $outpanel = $_[0];
                $outpanel->style_neutral;
                $outpanel->AppendText( $_[1]->GetLine . "\n" );

                return;
            },
        );
        Wx::Perl::ProcessStream::EVT_WXP_PROCESS_STREAM_EXIT(
            $panel->output,
            sub {
                $_[1]->Skip(1);
                $_[1]->GetProcess->Destroy;

                TRACE(' PROCESS_STREAM_EXIT') if DEBUG;

                my $outpanel = $_[0];
                $outpanel->style_neutral;
                $outpanel->AppendText( "\nProcess terminated\n");
                $panel->set_as_stopped;

                $doc->process( undef );
            },
        );
        $panel->{bound} = 1;
    }

    # Start the command
    my $process = Wx::Perl::ProcessStream::Process->new( $command, "Run $command", $panel->output );
    $doc->process( $process->Run );

    # Check if we started the process or not
    if ( $doc->process ) {
        $panel->set_as_started;

    } else {

        # Failed to start the command. Clean up.
        $panel->set_as_stopped; # should already be stopped, but just in case
        Wx::MessageBox( sprintf( _T("Failed to start server via '%s'"), $command ), _T("Error"), Wx::wxOK, $self );
    }

    return;
}

# This method belonds in Padre::Plugin::Plack::Panel but we keep it here
# to speed up the dev edit-reload cycle
sub build_panel {
    my $self = shift;
    my $doc   = shift;
    my $panel = shift;

    require Scalar::Util;
    $panel->{doc}  = $doc;
    Scalar::Util::weaken( $panel->{doc} );

    # main container
    my $box = Wx::BoxSizer->new(Wx::wxVERTICAL);

    # top box, holding buttons, icons and checkboxes
    my $top_box = Wx::BoxSizer->new(Wx::wxHORIZONTAL);

    # LED showing process status
    $panel->{led} = Wx::StaticBitmap->new( $panel, -1, Wx::wxNullBitmap );
    $top_box->Add( $panel->{led}, 0, Wx::wxALIGN_CENTER_VERTICAL );

    # Servers
    my @servers = sort qw(
        Standalone
        Standalone::Prefork
        Standalone::Prefork::Server::Starter
        FCGI
        FCGI::EV
        CGI
        AnyEvent
        Coro
        POE
        Danga::Socket
        Server::Simple
        ReverseHTTP
        Apache1
        Apache2
    );
    unshift @servers, _T('Let plackup guess');
    $top_box->AddSpacer(5);
    $top_box->Add( Wx::StaticText->new( $panel, -1, _T('Server:') ), 0, Wx::wxALIGN_CENTER_VERTICAL );
    $panel->{server} = Wx::ComboBox->new( $panel, -1, 'Standalone', Wx::wxDefaultPosition, Wx::wxDefaultSize, [ @servers ], Wx::wxCB_DROPDOWN );
    $top_box->Add( $panel->{server}, 0, Wx::wxALIGN_CENTER_VERTICAL );

    # Port
    $top_box->AddSpacer(5);
    $top_box->Add( Wx::StaticText->new( $panel, -1, _T('Port:') ), 0, Wx::wxALIGN_CENTER_VERTICAL );
    $panel->{port} = Wx::TextCtrl->new( $panel, -1, '5000' );
    $top_box->Add( $panel->{port}, 0, Wx::wxALIGN_CENTER_VERTICAL );

    # Plackup Options
    $top_box->AddSpacer(5);
    $top_box->Add( Wx::StaticText->new( $panel, -1, _T('Options:') ), 0, Wx::wxALIGN_CENTER_VERTICAL );
    $panel->{plackup_options} = Wx::TextCtrl->new( $panel, -1, '' );
    $top_box->Add( $panel->{plackup_options}, 0, Wx::wxALIGN_CENTER_VERTICAL );

    # Restart
    $top_box->AddSpacer(5);
    $panel->{restart} = Wx::CheckBox->new( $panel, -1, _T('Auto-Restart') );
    $panel->{restart}->SetValue(1);
    $top_box->Add( $panel->{restart}, 0, Wx::wxALIGN_CENTER_VERTICAL );

    # Start/stop button
    $top_box->AddSpacer(5);
    $panel->{start_stop} = Wx::Button->new( $panel, -1, '' );
    Wx::Event::EVT_BUTTON(
        $panel, $panel->{start_stop},
        sub {
            my $panel = shift;

            # Trigger plackup/down
            if ( $panel->{start_stop}->GetLabel eq _T('Start') ) {
                $doc->plugin->plackup($doc);
            }
            else {
                $doc->plugin->plackdown($doc);
            }
        },
    );
    $top_box->Add( $panel->{start_stop}, 0, Wx::wxALIGN_CENTER_VERTICAL );

    # Browser
    $top_box->AddSpacer(5);
    $panel->{browse} = Wx::Button->new( $panel, -1, _T('View in Browser') );
    Wx::Event::EVT_BUTTON(
        $panel, $panel->{browse},
        sub {
            my $panel = shift;
            my $port = $panel->{port}->GetValue || 5000;
            Padre::Wx::launch_browser("http://0:$port");
        },
    );
    $top_box->Add( $panel->{browse}, 0, Wx::wxALIGN_CENTER_VERTICAL );

    # finishing up the top_box
    $box->Add( $top_box, 0, Wx::wxALIGN_LEFT | Wx::wxALIGN_CENTER_VERTICAL );

    # output panel for server
    require Padre::Wx::Output;
    my $output = Padre::Wx::Output->new($panel);
    $box->Add( $output, 1, Wx::wxGROW );

    # wrapping it up
    $panel->SetSizer($box);

    # holding on to some objects we'll need to manipulate later on
    $panel->{output}   = $output;

    $panel->set_as_stopped;
}

1;
__END__