File Coverage

blib/lib/Farabi/Editor.pm
Criterion Covered Total %
statement 55 435 12.6
branch 13 110 11.8
condition 1 40 2.5
subroutine 7 39 17.9
pod 0 27 0.0
total 76 651 11.6


line stmt bran cond sub pod time code
1             package Farabi::Editor;
2              
3             # ABSTRACT: Controller
4             our $VERSION = '0.47'; # VERSION
5              
6 1     1   53486 use Mojo::Base 'Mojolicious::Controller';
  1         2  
  1         9  
7 1     1   1813 use Capture::Tiny qw(capture);
  1         24395  
  1         88  
8 1     1   1614 use IPC::Run qw( start pump finish timeout );
  1         31788  
  1         79  
9 1     1   10 use Path::Tiny;
  1         2  
  1         43  
10 1     1   1133 use Pod::Functions qw(%Type);
  1         3218  
  1         7413  
11              
12             # The actions
13              
14             my $file_menu = '01.File';
15             my $edit_menu = '02.Edit';
16             my $build_menu = '03.Build';
17             my $vcs_menu = '04.VCS';
18             my $tools_menu = '05.Tools';
19             my $help_menu = '06.Help';
20              
21             my %actions = (
22             'action-new-file' => {
23             name => 'New File - Alt+N',
24             help => "Opens a new file in an editor tab",
25             menu => $file_menu,
26             order => 1,
27             },
28              
29             # 'action-new-project' => {
30             # name => 'New Project',
31             # help => "Creates a new project using Module::Starter",
32             # menu => $file_menu,
33             # order => 2,
34             # },
35             'action-open-file' => {
36             name => 'Open File(s) - Alt+O',
37             help => "Opens one or more files in an editor tab",
38             menu => $file_menu,
39             order => 3,
40             },
41             'action-save-file' => {
42             name => 'Save File - Alt+S',
43             help => "Saves the current file ",
44             menu => $file_menu,
45             order => 4,
46             },
47             'action-close-file' => {
48             name => 'Close File - Alt+W',
49             help => "Closes the current open file",
50             menu => $file_menu,
51             order => 5,
52             },
53             'action-close-all-files' => {
54             name => 'Close All Files',
55             help => "Closes all of the open files",
56             menu => $file_menu,
57             order => 6,
58             },
59             'action-goto-line' => {
60             name => 'Goto Line - Alt+L',
61             help => 'A dialog to jump to the needed line',
62             menu => $edit_menu,
63             order => 1,
64             },
65             'action-options' => {
66             name => 'Options',
67             help => 'Open the options dialog',
68             menu => $tools_menu,
69             order => 1,
70             },
71             'action-repl' => {
72             name => 'REPL - Read-Print-Eval-Loop',
73             help => 'Opens the Read-Print-Eval-Loop dialog',
74             menu => $tools_menu,
75             order => 9,
76             },
77             'action-run' => {
78             name => 'Run - Alt+Enter',
79             help => 'Run the current editor source file using the run dialog',
80             menu => $build_menu,
81             order => 5,
82             },
83             'action-help' => {
84             name => 'Getting Started',
85             help => 'A quick getting started help dialog',
86             menu => $help_menu,
87             order => 1,
88             },
89              
90             # 'action-perl-doc' => {
91             # name => 'Perl Documentation',
92             # help => 'Opens the Perl help documentation dialog',
93             # menu => $help_menu,
94             # order => 2,
95             # },
96             'action-about' => {
97             name => 'About Farabi',
98             help => 'Opens an dialog about the current application',
99             menu => $help_menu,
100             order => 3,
101             },
102             );
103              
104             sub menus {
105 1     1 0 21672 my $self = shift;
106 1         3 my $menus = ();
107              
108 1 50       21 if ( $self->app->support_can_be_enabled('Perl::Critic') ) {
109 1         9 $actions{'action-perl-critic'} = {
110             name => 'Perl Critic',
111             help => 'Run the Perl::Critic tool on the current editor tab',
112             menu => $tools_menu,
113             order => 4,
114             };
115 1         7 $actions{'action-dump-ppi-tree'} = {
116             name => 'Dump the PPI tree',
117             help => "Dumps the PPI tree into the output pane",
118             menu => $tools_menu,
119             order => 11,
120             };
121             }
122              
123 1 50       31 if ( $self->app->support_can_be_enabled('Perl::Tidy') ) {
124 1         6 $actions{'action-perl-tidy'} = {
125             name => 'Perl Tidy',
126             help => 'Run the Perl::Tidy tool on the current editor tab',
127             menu => $tools_menu,
128             order => 3,
129             };
130             }
131              
132 1 50       21 if ( $self->app->support_can_be_enabled('Perl::Strip') ) {
133 0         0 $actions{'action-perl-strip'} = {
134             name => 'Perl Strip',
135             help => 'Run Perl::Strip on the current editor tab',
136             menu => $tools_menu,
137             order => 5,
138             };
139             }
140              
141 1 50       21 if ( $self->app->support_can_be_enabled('Spellunker') ) {
142 0         0 $actions{'action-spellunker'} = {
143             name => 'Spellunker',
144             help => "Checks current tab spelling using Spellunker",
145             menu => $tools_menu,
146             order => 10,
147             };
148             }
149              
150 1 50       22 if ( $self->app->support_can_be_enabled('Code::CutNPaste') ) {
151 0         0 $actions{'action-code-cutnpaste'} = {
152             name => 'Find Cut and Paste code...',
153             help => 'Finds any duplicate Perl code in the current lib folder',
154             menu => $tools_menu,
155             order => 7,
156             };
157             }
158              
159 1 50       25 if ( $self->app->support_can_be_enabled('App::Midgen') ) {
160 0         0 $actions{'action-midgen'} = {
161             name => 'Find package dependencies (midgen)',
162             help =>
163             'Find package dependencies in the current lib folder and outputs a sample Makefile DSL',
164             menu => $tools_menu,
165             order => 7,
166             };
167             }
168              
169 1 50 33     23 if ( $self->app->support_can_be_enabled('Dist::Zilla')
170             or defined File::Which::which('make'))
171             {
172 1         261 $actions{'action-project-build'} = {
173             name => 'Build',
174             help => "Runs 'dzil build' 'perl Makefile.PL && make' on the current project",
175             menu => $build_menu,
176             order => 2,
177             };
178 1         10 $actions{'action-project-clean'} = {
179             name => 'Clean',
180             help => "Runs 'dzil clean' or 'make clean' on the current project",
181             menu => $build_menu,
182             order => 2,
183             };
184 1         6 $actions{'action-project-test'} = {
185             name => 'Test',
186             help => "Runs 'dzil test' or 'make test' on the current project",
187             menu => $build_menu,
188             order => 2,
189             };
190             }
191              
192 1         9 require File::Which;
193 1 50       8 if ( defined File::Which::which('jshint') ) {
194 0         0 $actions{'action-jshint'} = {
195             name => 'JSHint',
196             help => 'Run JSHint on the current editor tab',
197             menu => $tools_menu,
198             order => 6,
199             };
200             }
201              
202 1 50       230 if ( defined File::Which::which('git') ) {
203 1         187 $actions{'action-git-diff'} = {
204             name => 'git diff',
205             help => 'Show Git changes between commits',
206             menu => $vcs_menu,
207             order => 8,
208             };
209 1         6 $actions{'action-git-log'} = {
210             name => 'git log',
211             help => 'Show Git commits',
212             menu => $vcs_menu,
213             order => 8,
214             };
215 1         4 $actions{'action-git-status'} = {
216             name => 'git status',
217             help => 'Show Git status',
218             menu => $vcs_menu,
219             order => 8,
220             };
221             }
222              
223 1 50       6 if ( defined File::Which::which('ack') ) {
224 0         0 $actions{'action-ack'} = {
225             name => 'Find in files (ack)',
226             help =>
227             'Find the current selected text using Ack and displays results in the search tab',
228             menu => $tools_menu,
229             order => 2,
230             };
231             }
232              
233 1 50       222 if ( defined File::Which::which('cpanm') ) {
234 1         138 $actions{'action-cpanm'} = {
235             name => 'Install CPAN module (cpanminus)',
236             help =>
237             'Install the selected module via App::cpanminus (aka cpanm)',
238             menu => $tools_menu,
239             order => 3,
240             };
241             }
242              
243 1         10 for my $name ( keys %actions ) {
244 21         35 my $action = $actions{$name};
245 21         32 my $menu = $action->{menu};
246 21         35 $menu = ucfirst($menu);
247              
248 21 100       59 $menus->{$menu} = [] unless defined $menus->{$menu};
249              
250 21         24 push @{ $menus->{$menu} },
  21         103  
251             {
252             action => $name,
253             name => $action->{name},
254             order => $action->{order},
255             };
256              
257             }
258              
259 1         6 for my $name ( keys %$menus ) {
260 6         13 my $menu = $menus->{$name};
261              
262 6         20 my @sorted = sort { $a->{order} <=> $b->{order} } @$menu;
  24         83  
263 6         20 $menus->{$name} = \@sorted;
264             }
265              
266 1         8 $menus;
267             }
268              
269             # Taken from Padre::Plugin::PerlCritic
270             sub perl_critic {
271 0     0 0 0 my $self = shift;
272 0         0 my $source = $self->param('source');
273 0         0 my $severity = $self->param('severity');
274              
275             # Check source parameter
276 0 0       0 if ( !defined $source ) {
277 0         0 $self->app->log->warn('Undefined "source" parameter');
278 0         0 return;
279             }
280              
281             # Check severity parameter
282 0 0       0 if ( !defined $severity ) {
283 0         0 $self->app->log->warn('Undefined "severity" parameter');
284 0         0 return;
285             }
286              
287             # Hand off to Perl::Critic
288 0         0 require Perl::Critic;
289 0         0 my @violations =
290             Perl::Critic->new( -severity => $severity )->critique( \$source );
291              
292 0         0 my @results;
293 0         0 for my $violation (@violations) {
294 0         0 push @results,
295             {
296             policy => $violation->policy,
297             line_number => $violation->line_number,
298             description => $violation->description,
299             explanation => $violation->explanation,
300             diagnostics => $violation->diagnostics,
301             };
302             }
303              
304 0         0 $self->render( json => \@results );
305             }
306              
307             sub _capture_cmd_output {
308 0     0   0 my $self = shift;
309 0         0 my $cmd = shift;
310 0         0 my $opts = shift;
311 0         0 my $source = shift;
312 0         0 my $input = shift;
313              
314 0         0 require File::Temp;
315              
316             # Source is stored in a temporary file
317 0         0 my $source_fh;
318 0 0       0 if ( defined $source ) {
319 0         0 $source_fh = File::Temp->new;
320 0         0 print $source_fh $source;
321 0         0 close $source_fh;
322             }
323              
324             # Input is stored in a temporary file
325 0         0 my $input_fh;
326 0 0       0 if ( defined $input ) {
327 0         0 $input_fh = File::Temp->new;
328 0         0 print $input_fh $input;
329 0         0 close $input_fh;
330             }
331              
332             my ( $stdout, $stderr, $exit ) = capture {
333 0 0   0   0 if ( defined $input_fh ) {
334              
335 0 0       0 if ( defined $source_fh ) {
336 0         0 system( $cmd, @$opts, $source_fh->filename,
337             "<" . $input_fh->filename );
338             }
339             else {
340 0         0 system( $cmd, @$opts, "<" . $input_fh->filename );
341             }
342             }
343             else {
344 0 0       0 if ( defined $source_fh ) {
345 0         0 system( $cmd, @$opts, $source_fh->filename );
346             }
347             else {
348 0         0 system( $cmd, @$opts );
349             }
350             }
351 0         0 };
352 0         0 my $result = {
353             stdout => $stdout,
354             stderr => $stderr,
355             'exit' => $exit >> 8,
356             };
357              
358 0         0 return $result;
359             }
360              
361             sub run_perl {
362 0     0 0 0 my $self = shift;
363 0         0 my $source = $self->param('source');
364 0         0 my $input = $self->param('input');
365              
366 0         0 my $o = $self->_capture_cmd_output( $^X, [], $source, $input );
367              
368 0         0 $self->render( json => $o );
369             }
370              
371             sub run_perlbrew_exec {
372 0     0 0 0 my $self = shift;
373 0         0 my $source = $self->param('source');
374 0         0 my $input = $self->param('input');
375              
376 0         0 my $o = $self->_capture_cmd_output( 'perlbrew', [ 'exec', 'perl' ],
377             $source, $input );
378              
379 0         0 $self->render( json => $o );
380             }
381              
382             # Taken from Padre::Plugin::PerlTidy
383             # TODO document it in 'SEE ALSO' POD section
384             sub perl_tidy {
385 0     0 0 0 my $self = shift;
386 0         0 my $source = $self->param('source');
387              
388             # Check 'source' parameter
389 0 0       0 unless ( defined $source ) {
390 0         0 $self->app->log->warn('Undefined "source" parameter');
391 0         0 return;
392             }
393              
394 0         0 my %result = (
395             'error' => '',
396             'source' => '',
397             );
398              
399 0         0 my $destination = undef;
400 0         0 my $errorfile = undef;
401 0         0 my %tidyargs = (
402             argv => \'-nse -nst',
403             source => \$source,
404             destination => \$destination,
405             errorfile => \$errorfile,
406             );
407              
408             # TODO: suppress the senseless warning from PerlTidy
409 0         0 eval {
410 0         0 require Perl::Tidy;
411 0         0 Perl::Tidy::perltidy(%tidyargs);
412             };
413              
414 0 0       0 if ($@) {
415 0         0 $result{error} = "PerlTidy Error:\n" . $@;
416             }
417              
418 0 0       0 if ( defined $errorfile ) {
419 0         0 $result{error} .= "\n$errorfile\n";
420             }
421              
422 0         0 $result{source} = $destination;
423              
424 0         0 $self->render( json => \%result );
425             }
426              
427             sub _module_pod {
428 0     0   0 my $self = shift;
429 0         0 my $filename = shift;
430              
431 0         0 $self->app->log->info("Opening '$filename'");
432 0         0 my $pod = '';
433 0 0       0 if ( open my $fh, '<', $filename ) {
434 0         0 $pod = do { local $/ = <$fh> };
  0         0  
435 0         0 close $fh;
436             }
437             else {
438 0         0 $self->app->log->warn("Cannot open $filename");
439             }
440              
441 0         0 return $pod;
442             }
443              
444             # Convert Perl POD source to HTML
445             sub pod2html {
446 0     0 0 0 my $self = shift;
447 0   0     0 my $text = $self->param('source') // '';
448 0   0     0 my $style = $self->param('style') // 'metacpan';
449              
450 0         0 $self->render( text => _pod2html( $text, $style ), format => 'html' );
451             }
452              
453             sub _pod2html {
454 0     0   0 my $text = shift;
455 0         0 my $style = shift;
456              
457 0         0 require Pod::Simple::HTML;
458 0         0 my $psx = Pod::Simple::HTML->new;
459              
460             #$psx->no_errata_section(1);
461             #$psx->no_whining(1);
462 0         0 $psx->output_string( \my $html );
463 0         0 $psx->parse_string_document($text);
464              
465 0         0 my %stylesheets = (
466             'cpan' =>
467             [ 'assets/podstyle/orig/cpan.css', 'assets/podstyle/cpan.css' ],
468             'metacpan' => [
469             'assets/podstyle/orig/metacpan.css',
470             'assets/podstyle/metacpan/shCore.css',
471             'assets/podstyle/metacpan/shThemeDefault.css',
472             'assets/podstyle/metacpan.css'
473             ],
474             'github' =>
475             [ 'assets/podstyle/orig/github.css', 'assets/podstyle/github.css' ],
476             'none' => []
477             );
478              
479 0         0 my $t = '';
480 0         0 for my $style ( @{ $stylesheets{$style} } ) {
  0         0  
481 0         0 $t .=
482             qq{<link class="pod-stylesheet" rel="stylesheet" type="text/css" href="$style">\n};
483             }
484 0         0 $html =~ s{(</head>)}{</head>$t$1};
485              
486 0         0 return $html;
487             }
488              
489             sub md2html {
490 0     0 0 0 my $self = shift;
491 0   0     0 my $text = $self->param('text') // '';
492              
493 0         0 require Text::Markdown;
494 0         0 my $m = Text::Markdown->new;
495 0         0 my $html = $m->markdown($text);
496              
497 0         0 $self->render( text => $html );
498             }
499              
500             # Code borrowed from Padre::Plugin::Experimento - written by me :)
501             sub pod_check {
502 0     0 0 0 my $self = shift;
503 0   0     0 my $source = $self->param('source') // '';
504              
505 0         0 require Pod::Checker;
506 0         0 require IO::String;
507              
508 0         0 my $checker = Pod::Checker->new;
509 0         0 my $output = '';
510 0         0 $checker->parse_from_file( IO::String->new($source),
511             IO::String->new($output) );
512              
513 0         0 my $num_errors = $checker->num_errors;
514 0         0 my $num_warnings = $checker->num_warnings;
515 0         0 my @problems;
516              
517 0         0 say "$num_warnings, $num_errors";
518              
519             # Handle only errors/warnings. Forget about 'No POD in current document'
520 0 0 0     0 if ( $num_errors != -1 and ( $num_errors != 0 or $num_warnings != 0 ) ) {
      0        
521 0         0 for ( split /^/, $output ) {
522 0 0       0 if (/^(.+?) at line (\d+) in file \S+$/) {
523 0         0 push @problems,
524             {
525             message => $1,
526             line => int($2),
527             };
528             }
529             }
530             }
531              
532 0         0 $self->render( json => \@problems );
533             }
534              
535             # Find a list of matched actions
536             sub find_action {
537 0     0 0 0 my $self = shift;
538              
539             # Quote every special regex character
540 0   0     0 my $query = quotemeta( $self->param('action') // '' );
541              
542             # Find matched actions
543 0         0 my @matches;
544 0         0 for my $action_id ( keys %actions ) {
545 0         0 my $action = $actions{$action_id};
546 0         0 my $action_name = $action->{name};
547 0 0       0 if ( $action_name =~ /^.*$query.*$/i ) {
548 0         0 push @matches,
549             {
550             id => $action_id,
551             name => $action_name,
552             help => $action->{help},
553             };
554             }
555             }
556              
557             # Sort so that shorter matches appear first
558 0         0 @matches = sort { $a->{name} cmp $b->{name} } @matches;
  0         0  
559              
560             # And return matches array reference
561 0         0 $self->render( json => \@matches );
562             }
563              
564             # Find a list of matches files
565             sub find_file {
566 0     0 0 0 my $self = shift;
567              
568             # Quote every special regex character
569 0   0     0 my $query = quotemeta( $self->param('filename') // '' );
570              
571             # Determine directory
572 0         0 require Cwd;
573 0         0 my $dir = $self->param('dir');
574 0 0 0     0 if ( !$dir || $dir eq '' ) {
575 0         0 $dir = Cwd::getcwd;
576             }
577              
578 0         0 require File::Find::Rule;
579 0         0 my $rule = File::Find::Rule->new;
580 0         0 $rule->or(
581             $rule->new->directory->name( 'CVS', '.svn', '.git', 'blib', '.build' )
582             ->prune->discard,
583             $rule->new
584             );
585              
586 0         0 $rule->file->name(qr/$query/i);
587 0         0 my @files = $rule->in($dir);
588              
589 0         0 my @matches;
590 0         0 for my $file (@files) {
591 0         0 push @matches,
592             {
593             id => $file,
594             name => path($file)->basename,
595             };
596             }
597              
598             # Sort so that shorter matches appear first
599 0         0 @matches = sort { $a->{name} cmp $b->{name} } @matches;
  0         0  
600              
601 0         0 my $MAX_RESULTS = 100;
602 0 0       0 if ( scalar @files > $MAX_RESULTS ) {
603 0         0 @matches = @matches[ 0 .. $MAX_RESULTS - 1 ];
604             }
605              
606             # Return the matched file array reference
607 0         0 $self->render( json => \@matches );
608             }
609              
610             # Return the file contents or a failure string
611             sub open_file {
612 0     0 0 0 my $self = shift;
613              
614 0   0     0 my $filename = $self->param('filename') // '';
615              
616 0         0 my %result = ();
617 0 0       0 if ( open my $fh, '<', $filename ) {
618              
619             # Slurp the file contents
620 0         0 local $/ = undef;
621 0         0 $result{value} = <$fh>;
622 0         0 close $fh;
623              
624             # Retrieve editor mode
625 0         0 $result{mode} = _find_editor_mode_from_filename($filename);
626              
627             # Simplify filename
628 0         0 $result{filename} = path($filename)->basename;
629              
630             # Add or update record file record
631 0         0 $self->_add_or_update_recent_file_record($filename);
632              
633             # We're ok :)
634 0         0 $result{ok} = 1;
635             }
636             else {
637             # Error!
638 0         0 $result{value} = "Could not open file: $filename";
639 0         0 $result{ok} = 0;
640             }
641              
642             # Return the file contents or the error message
643 0         0 $self->render( json => \%result );
644             }
645              
646             # Add or update record file record
647             sub _add_or_update_recent_file_record {
648 0     0   0 my $self = shift;
649 0         0 my $filename = shift;
650              
651 0         0 require DBIx::Simple;
652 0         0 my $db_name = $self->app->db_name;
653 0         0 my $db = DBIx::Simple->connect("dbi:SQLite:dbname=$db_name");
654              
655 0         0 my $sql = <<'SQL';
656             SELECT id, name, datetime(last_used,'localtime')
657             FROM recent_list
658             WHERE name = ? and type = 'file'
659             SQL
660              
661 0         0 my ( $id, $name, $last_used ) = $db->query( $sql, $filename )->list;
662              
663 0 0       0 if ( defined $id ) {
664              
665             # Found recent file record, update last used timestamp;
666 0         0 $db->query(
667             q{UPDATE recent_list SET last_used = datetime('now') WHERE id = ?},
668             $id
669             );
670              
671 0         0 $self->app->log->info("Update '$filename' in recent_list");
672             }
673             else {
674             # Not found... Add new recent file record
675 0         0 $sql = <<'SQL';
676             INSERT INTO recent_list(name, type, last_used)
677             VALUES(?, 'file', datetime('now'))
678             SQL
679 0         0 $db->query( $sql, $filename );
680              
681 0         0 $self->app->log->info("Add '$filename' to recent_list");
682             }
683              
684 0         0 $db->disconnect;
685             }
686              
687             # Finds the editor mode from the filename
688             sub _find_editor_mode_from_filename {
689 0     0   0 my $filename = shift;
690              
691 0         0 my $extension;
692 0 0       0 if ( $filename =~ /\.([^.]+)$/ ) {
693              
694             # Extract file extension greedily
695 0         0 $extension = $1;
696             }
697              
698 0         0 my %extension_to_mode = (
699             pl => 'perl',
700             pm => 'perl',
701             t => 'perl',
702             css => 'css',
703             js => 'javascript',
704             json => 'javascript',
705             html => 'xml',
706             ep => 'xml',
707             md => 'markdown',
708             markdown => 'markdown',
709             conf => 'properties',
710             properties => 'properties',
711             ini => 'properties',
712             txt => 'null',
713             'log' => 'null',
714             yml => 'yaml',
715             yaml => 'yaml',
716             coffee => 'coffeescript',
717             diff => 'diff',
718             patch => 'diff',
719             sql => 'sql',
720             );
721              
722             # No extension, let us use default text mode
723 0 0       0 return 'null' unless defined $extension;
724 0         0 return $extension_to_mode{$extension};
725             }
726              
727             # Generic REPL (Read-Eval-Print-Loop)
728             sub repl_eval {
729 0     0 0 0 my $self = shift;
730 0   0     0 my $runtime_id = $_[0]->{runtime} // 'perl';
731 0   0     0 my $command = $_[0]->{command} // '';
732              
733             # The Result object
734 0         0 my %result = (
735             out => '',
736             err => '',
737             );
738              
739             # TODO make these configurable?
740 0         0 my %runtimes = (
741             'perl' => {
742              
743             # Special case that uses an internal inprocess Devel::REPL object
744             },
745             );
746              
747             # The process that we're gonna REPL
748 0         0 my $runtime = $runtimes{$runtime_id};
749              
750             # Handle the special case for Devel::REPL
751 0 0       0 if ( $runtime_id eq 'perl' ) {
752 0         0 return $self->_devel_repl_eval($command);
753             }
754              
755             # Get the REPL prompt
756 0         0 my $prompt = $runtime->{prompt};
757              
758             # If runtime is not defined, let us report it back
759 0 0       0 unless ( defined $runtime ) {
760 0         0 my %result = ( err => "Failed to find runtime '$runtime_id'", );
761              
762             # Return the REPL result
763 0         0 $self->render( json => \%result );
764 0         0 return;
765             }
766              
767             # Prepare the REPL command....
768 0         0 my @cmd = ( $runtime->{cmd} );
769              
770             # The input, output and error strings
771 0         0 my ( $in, $out, $err );
772              
773             # Open process with a timeout
774             #TODO timeout should be configurable...
775 0         0 my $h = start \@cmd, \$in, \$out, \$err, timeout(5);
776              
777             # Send command to process and wait for prompt
778 0         0 $in .= "$command\n";
779 0         0 pump $h until $out =~ /$prompt/m;
780 0 0       0 finish $h or $err = "@cmd returned $?";
781              
782             # Remove current REPL prompt
783 0         0 $out =~ s/$prompt//;
784              
785             # Result...
786 0         0 $result{out} = $out;
787 0         0 $result{err} = $err;
788              
789             # Return the REPL result
790 0         0 $self->render( json => \%result );
791             }
792              
793             # Global shared object at the moment
794             # TODO should be stored in session
795             my $devel_repl;
796              
797             # Devel::REPL (Perl)
798             sub _devel_repl_eval {
799 0     0   0 my ( $self, $code ) = @_;
800              
801             # The Result object
802 0         0 my %result = (
803             out => '',
804             err => '',
805             );
806              
807 0 0       0 unless ($devel_repl) {
808              
809             # Try to load Devel::REPL
810 0         0 eval { require Devel::REPL; };
  0         0  
811 0 0       0 if ($@) {
812              
813             # The error
814 0         0 $result{err} = 'Unable to find Devel::REPL';
815              
816             # Return the REPL result
817 0         0 $self->render( json => \%result );
818 0         0 return;
819             }
820              
821             # Create the REPL object
822 0         0 $devel_repl = Devel::REPL->new;
823              
824             # Provide Lexical environment for a Perl repl
825             # Without this, it wont remember :)
826 0         0 $devel_repl->load_plugin('LexEnv');
827             }
828              
829 0 0       0 if ( $code eq '' ) {
830              
831             # Special case for empty input
832 0         0 $result{out} = "\$\n";
833             }
834             else {
835 0         0 my @ret = $devel_repl->eval("$code");
836              
837 0 0       0 if ( $devel_repl->is_error(@ret) ) {
838 0         0 $result{err} = $devel_repl->format_error(@ret);
839 0         0 $result{out} = "\$ $code";
840             }
841             else {
842 0         0 $result{out} = "\$ $code\n@ret\n";
843             }
844             }
845              
846             # Return the REPL result
847 0         0 $self->render( json => \%result );
848             }
849              
850             # Save(s) the specified filename
851             sub save_file {
852 0     0 0 0 my $self = shift;
853 0         0 my $filename = $self->param('filename');
854 0         0 my $source = $self->param('source');
855              
856             # Define output and error strings
857 0         0 my %result = ( err => '', );
858              
859             # Check filename parameter
860 0 0       0 unless ($filename) {
861              
862             # The error
863 0         0 $result{err} = "filename parameter is invalid";
864              
865             # Return the result
866 0         0 $self->render( json => \%result );
867 0         0 return;
868             }
869              
870             # Check contents parameter
871 0 0       0 unless ($source) {
872              
873             # The error
874 0         0 $result{err} = "source parameter is invalid";
875              
876             # Return the REPL result
877 0         0 $self->render( json => \%result );
878 0         0 return;
879             }
880              
881 0 0       0 if ( open my $fh, ">", $filename ) {
882              
883             # Saving...
884 0         0 print $fh $source;
885 0         0 close $fh;
886             }
887             else {
888             # Error: Cannot open the file for writing/saving
889 0         0 $result{err} = "Cannot save $filename";
890             }
891              
892 0         0 $self->render( json => \%result );
893             }
894              
895             # Find duplicate Perl code in the current 'lib' folder
896             sub code_cutnpaste {
897              
898 0     0 0 0 my $self = shift;
899 0         0 my $dirs = $self->param('dirs');
900              
901 0         0 my %result = (
902             count => 0,
903             output => '',
904             error => '',
905             );
906              
907 0 0       0 unless ($dirs) {
908              
909             # Return the error result
910 0         0 $result{error} = "Error:\ndirs parameter is invalid";
911 0         0 $self->render( json => \%result );
912 0         0 return;
913             }
914              
915 0         0 my @dirs;
916 0         0 $dirs =~ s/^\s+|\s+$//g;
917 0 0       0 if ( $dirs ne '' ) {
918              
919             # Extract search directories
920 0         0 @dirs = split ',', $dirs;
921             }
922              
923 0         0 my $cutnpaste;
924 0         0 eval {
925             # Create an cut-n-paste object
926 0         0 require Code::CutNPaste;
927 0         0 $cutnpaste = Code::CutNPaste->new(
928             dirs => [@dirs],
929             renamed_vars => 1,
930             renamed_subs => 1,
931             );
932             };
933 0 0       0 if ($@) {
934              
935             # Return the error result
936 0         0 $result{error} = "Code::CutNPaste validation error:\n" . $@;
937 0         0 $self->render( json => \%result );
938 0         0 return;
939             }
940              
941             # Finds the duplicates
942 0         0 my $duplicates = $cutnpaste->duplicates;
943              
944             # Construct the output
945 0         0 my $output = '';
946 0         0 foreach my $duplicate (@$duplicates) {
947 0         0 my ( $left, $right ) = ( $duplicate->left, $duplicate->right );
948 0         0 $output .=
949             sprintf <<'END', $left->file, $left->line, $right->file, $right->line;
950              
951             Possible duplicate code found
952             Left: %s line %d
953             Right: %s line %d
954              
955             END
956 0         0 $output .= $duplicate->report;
957             }
958              
959             # Returns the find duplicate perl code result
960 0         0 $result{count} = scalar @$duplicates;
961 0         0 $result{output} = $output;
962              
963 0         0 $self->render( json => \%result );
964             }
965              
966             # Dumps the PPI tree for the given source parameter
967             sub dump_ppi_tree {
968              
969 0     0 0 0 my $self = shift;
970 0         0 my $source = $self->param('source');
971              
972 0         0 my %result = (
973             output => '',
974             error => '',
975             );
976              
977             # Make sure that the source parameter is not undefined
978 0 0       0 unless ( defined $source ) {
979              
980             # Return the error JSON result
981 0         0 $result{error} = "Error:\nSource parameter is undefined";
982 0         0 $self->render( json => \%result );
983 0         0 return;
984             }
985              
986             # Load PPI at runtime
987 0         0 require PPI;
988 0         0 require PPI::Dumper;
989              
990             # Load a document
991 0         0 my $module = PPI::Document->new( \$source );
992              
993             # No whitespace tokens
994 0         0 $module->prune('PPI::Token::Whitespace');
995              
996             # Create the dumper
997 0         0 my $dumper = PPI::Dumper->new($module);
998              
999             # Dump the document as a string
1000 0         0 $result{output} = $dumper->string;
1001              
1002             # Return the JSON result
1003 0         0 $self->render( json => \%result );
1004             }
1005              
1006             # Syntax check the provided source string
1007             sub syntax_check {
1008 0     0 0 0 my $self = shift;
1009 0         0 my $source = $self->param('source');
1010              
1011 0         0 my $result = $self->_capture_cmd_output( "$^X", ["-c"], $source );
1012              
1013 0         0 require Parse::ErrorString::Perl;
1014 0         0 my $parser = Parse::ErrorString::Perl->new;
1015 0         0 my @errors = $parser->parse_string( $result->{stderr} );
1016              
1017 0         0 my @problems;
1018 0         0 foreach my $error (@errors) {
1019 0         0 push @problems,
1020             {
1021             message => $error->message,
1022             file => $error->file,
1023             line => $error->line,
1024             };
1025             }
1026              
1027             # Sort problems by line numerically
1028 0         0 @problems = sort { $a->{line} <=> $b->{line} } @problems;
  0         0  
1029              
1030 0         0 $self->render( json => \@problems );
1031             }
1032              
1033             # Create a project using Module::Starter
1034             sub create_project {
1035 0     0 0 0 my $self = shift;
1036 0         0 my $opt = shift;
1037              
1038 0         0 my %args = (
1039             distro => $opt->{distro},
1040             modules => $opt->{modules},
1041             dir => $opt->{dir},
1042             builder => $opt->{builder},
1043             license => $opt->{license},
1044             author => $opt->{author},
1045             email => $opt->{email},
1046             ignores_type => $opt->{ignores_type},
1047             force => $opt->{force},
1048             );
1049              
1050 0         0 Module::Starter->create_distro(%args);
1051             }
1052              
1053             # Run git 'diff|log" and return its output
1054             sub git {
1055 0     0 0 0 my $self = shift;
1056 0   0     0 my $cmd = $self->param('cmd') // '';
1057              
1058 0         0 my %valid_cmds = ( 'diff' => 1, 'log' => 1, 'status' => 1);
1059 0         0 my $o;
1060 0 0       0 if ( defined $valid_cmds{$cmd} ) {
1061 0         0 $o = $self->_capture_cmd_output( 'git', [$cmd] );
1062             }
1063             else {
1064 0         0 $o = {
1065             stdout => 'Unknown git command',
1066             stderr => '',
1067             'exit' => 0,
1068             };
1069             }
1070              
1071 0         0 $self->render( json => $o );
1072             }
1073              
1074             # Search files in your current project folder for a textual pattern
1075             sub ack {
1076 0     0 0 0 my $self = shift;
1077 0         0 my $text = $self->param('text');
1078              
1079             #TODO needs more thought on how to secure it again --xyz-command or escaping...
1080             # WARNING at the moment this is not secure
1081 0         0 my $o = $self->_capture_cmd_output( 'ack',
1082             [ q{--literal}, q{--sort-files}, q{--match}, qq{$text} ] );
1083              
1084 0         0 $self->render( json => $o );
1085             }
1086              
1087             # Check requires & test_requires of your package for CPAN inclusion.
1088             sub midgen {
1089 0     0 0 0 my $self = shift;
1090              
1091 0         0 my $o = $self->_capture_cmd_output( 'midgen', [] );
1092              
1093             # Remove ansi color sequences
1094 0         0 $o->{stdout} =~ s/\e\[[\d;]*[a-zA-Z]//g;
1095 0         0 $o->{stderr} =~ s/\e\[[\d;]*[a-zA-Z]//g;
1096              
1097 0         0 $self->render( json => $o );
1098             }
1099              
1100             # Install module XYZ via App::cpanminus
1101             sub cpanm {
1102 0     0 0 0 my $self = shift;
1103 0   0     0 my $module = $self->param('module') // '';
1104              
1105 0         0 my $o = $self->_capture_cmd_output( 'cpanm', [$module] );
1106              
1107 0         0 $self->render( json => $o );
1108             }
1109              
1110             # Runs dzil or makefile build commands in the current project folder
1111             sub project {
1112 0     0 0 0 my $self = shift;
1113 0   0     0 my $cmd = $self->param('cmd') // '';
1114              
1115             # Detect project type
1116 0         0 my $project_type = 'dzil';
1117 0 0       0 if(-z 'dist.ini') {
    0          
1118             # Dist::Zilla (dzil) support
1119 0         0 $project_type = 'dzil';
1120             } elsif (-z 'Makefile.PL') {
1121             # Module::Install or ExtUtils::MakeMaker project
1122 0         0 $project_type = 'make';
1123             }
1124              
1125 0         0 my %valid_cmds = ( 'build'=> 1, 'test' => 1, 'clean' => 1 );
1126 0         0 my $o;
1127 0 0       0 if ( defined $valid_cmds{$cmd} ) {
1128 0 0       0 if($cmd eq 'build') {
1129 0 0       0 $o = $self->_capture_cmd_output( 'make', $project_type eq 'dzil'? ['build'] : [] ); ;
1130             } else {
1131 0         0 $o = $self->_capture_cmd_output( 'make', [$cmd] );
1132             }
1133             }
1134             else {
1135 0         0 $o = {
1136             stdout => 'Unknown project command',
1137             stderr => '',
1138             'exit' => 0,
1139             };
1140             }
1141              
1142 0         0 $self->render( json => $o );
1143             }
1144              
1145             sub perl_strip {
1146 0     0 0 0 my $self = shift;
1147 0         0 my $source = $self->param('source');
1148              
1149 0         0 my %result = (
1150             error => 1,
1151             source => '',
1152             );
1153              
1154             # Check 'source' parameter
1155 0 0       0 unless ( defined $source ) {
1156 0         0 $self->app->log->warn('Undefined "source" parameter');
1157 0         0 $self->render( json => \%result );
1158 0         0 return;
1159             }
1160              
1161 0         0 eval {
1162 0         0 require Perl::Strip;
1163 0         0 my $ps = Perl::Strip->new;
1164 0         0 $result{source} = $ps->strip($source);
1165             };
1166              
1167 0         0 $self->render( json => \%result );
1168             }
1169              
1170             sub spellunker {
1171 0     0 0 0 my $self = shift;
1172 0         0 my $text = $self->param('text');
1173              
1174 0         0 require Spellunker::Pod;
1175 0         0 my $spellunker = Spellunker::Pod->new();
1176 0         0 my @errors = $spellunker->check_text($text);
1177              
1178 0         0 my @problems;
1179 0         0 foreach my $error (@errors) {
1180 0         0 push @problems,
1181             {
1182 0         0 message => join( " ", @{ $error->[2] } ),
1183             ,
1184             file => '-',
1185             line => $error->[0],
1186             };
1187             }
1188              
1189             # Sort problems by line numerically
1190 0         0 @problems = sort { $a->{line} <=> $b->{line} } @problems;
  0         0  
1191              
1192 0         0 $self->render( json => \@problems );
1193             }
1194              
1195             sub help {
1196 0     0 0 0 my $self = shift;
1197 0   0     0 my $topic = $self->param('topic') // '';
1198 0   0     0 my $style = $self->param('style') // 'metacpan';
1199            
1200 0 0       0 if($topic eq '') {
1201 0         0 $self->render( text => "No help found" );
1202 0         0 return;
1203             }
1204              
1205 0         0 my @cmd;
1206 0 0       0 if($Type{$topic}) {
1207 0         0 @cmd = ('-f', $topic);
1208             } else {
1209 0         0 @cmd = ($topic);
1210             }
1211              
1212 0         0 my $result = $self->_capture_cmd_output( 'perldoc', [ '-T', '-u', @cmd ] );
1213              
1214 0         0 my $html = _pod2html( $result->{stdout}, $style );
1215              
1216 0         0 $self->render( text => $html );
1217             }
1218              
1219             # The default root handler
1220             sub default {
1221 1     1 0 457 my $self = shift;
1222              
1223             # Stash the source parameter so it can be used inside the template
1224 1         10 $self->stash( source => scalar $self->param('source') );
1225              
1226             # Render template "editor/default.html.ep"
1227 1         654 $self->render;
1228             }
1229              
1230             sub ping {
1231 0     0 0   $_[0]->render( text => "pong" );
1232             }
1233              
1234             1;
1235              
1236             __END__
1237              
1238             =pod
1239              
1240             =encoding UTF-8
1241              
1242             =head1 NAME
1243              
1244             Farabi::Editor - Controller
1245              
1246             =head1 VERSION
1247              
1248             version 0.47
1249              
1250             =head1 AUTHOR
1251              
1252             Ahmad M. Zawawi <ahmad.zawawi@gmail.com>
1253              
1254             =head1 COPYRIGHT AND LICENSE
1255              
1256             This software is copyright (c) 2014 by Ahmad M. Zawawi.
1257              
1258             This is free software; you can redistribute it and/or modify it under
1259             the same terms as the Perl 5 programming language system itself.
1260              
1261             =cut