diff --git a/applets/compiler_vm/host/lib/InteractiveEdit.pm b/applets/compiler_vm/host/lib/InteractiveEdit.pm new file mode 100644 index 00000000..e77906b3 --- /dev/null +++ b/applets/compiler_vm/host/lib/InteractiveEdit.pm @@ -0,0 +1,519 @@ +#!/usr/bin/env perl + +package InteractiveEdit; + +use 5.020; + +use warnings; +use strict; + +use feature qw(switch signatures); +no warnings qw(experimental::smartmatch experimental::signatures); + +use LWP::UserAgent; +use FindBin qw($RealBin); +use Text::Balanced qw(extract_delimited); + +use parent qw(Exporter); +our @EXPORT = qw(interactive_edit); + +sub interactive_edit($self) { + my (@last_code, $unshift_last_code); + + my $code = $self->{code}; + + print " code: [$code]\n" if $self->{debug}; + + my $subcode = $code; + while ($subcode =~ s/^\s*(-[^ ]+)\s*//) {} + + my $copy_code; + if ($subcode =~ s/^\s*copy\s+(\S+)\s*//) { + my $copy = $1; + + if (open LOG, "< $RealBin/../history/$copy-$self->{lang}.hist") { + $copy_code = ; + close LOG; + goto COPY_ERROR if not $copy_code;; + chomp $copy_code; + } else { + goto COPY_ERROR; + } + + goto COPY_SUCCESS; + + COPY_ERROR: + print "No history for $copy.\n"; + exit 0; + + COPY_SUCCESS: + $code = $copy_code; + $self->{only_show} = 1; + $self->{copy_code} = 1; + } + + if ($subcode =~ m/^\s*(?:and\s+)?(?:diff|show)\s+(\S+)\s*$/) { + $self->{channel} = $1; + } + + if (open LOG, "< $RealBin/../history/$self->{channel}-$self->{lang}.hist") { + while (my $line = ) { + chomp $line; + push @last_code, $line; + } + close LOG; + } + + unshift @last_code, $copy_code if defined $copy_code; + + if ($subcode =~ m/^\s*(?:and\s+)?show(?:\s+\S+)?\s*$/i) { + if (defined $last_code[0]) { + print "$last_code[0]\n"; + } else { + print "No recent code to show.\n" + } + exit 0; + } + + my $prevchange = $last_code[0]; + my @replacements; + my $got_changes = 0; + my $got_sub = 0; + my $got_diff = 0; + my $got_undo = 0; + my $last_keyword; + + while ($subcode =~ s/^\s*(and)?\s*undo//) { + splice @last_code, 0, 1; + if (not defined $last_code[0]) { + print "No more undos remaining.\n"; + exit 0; + } else { + $code = $last_code[0]; + $prevchange = $last_code[0]; + $got_undo = 1; + } + } + + while (1) { + $got_sub = 0; + + $subcode =~ s/^\s*and\s+'/and $last_keyword '/ if defined $last_keyword; + + if ($subcode =~ m/^\s*(?:and\s+)?diff\b/i) { + $got_diff = 1; + last; + } + + if ($subcode =~ m/^\s*(?:and\s+)?(again|run|paste)\b/i) { + $self->{got_run} = lc $1; + $self->{only_show} = 0; + if ($prevchange) { + $code = $prevchange; + } else { + print "No recent code to $self->{got_run}.\n"; + exit 0; + } + } + + if ($subcode =~ m/^\s*(and)?\s*remove \s*([^']+)?\s*'/) { + $last_keyword = 'remove'; + my $modifier = 'first'; + + $subcode =~ s/^\s*(and)?\s*//; + $subcode =~ s/remove\s*([^']+)?\s*//i; + $modifier = $1 if defined $1; + $modifier =~ s/\s+$//; + + my ($e, $r) = extract_delimited($subcode, "'"); + + my $text; + + if (defined $e) { + $text = $e; + $text =~ s/^'//; + $text =~ s/'$//; + $subcode = "replace $modifier '$text' with ''$r"; + } else { + print "Unbalanced single quotes. Usage: cc remove [all, first, .., tenth, last] 'text' [and ...]\n"; + exit 0; + } + next; + } + + if ($subcode =~ s/^\s*(and)?\s*prepend '//) { + $last_keyword = 'prepend'; + $subcode = "'$subcode"; + + my ($e, $r) = extract_delimited($subcode, "'"); + + my $text; + + if (defined $e) { + $text = $e; + $text =~ s/^'//; + $text =~ s/'$//; + $subcode = $r; + + $got_sub = 1; + $got_changes = 1; + + if (not defined $prevchange) { + print "No recent code to prepend to.\n"; + exit 0; + } + + $code = $prevchange; + $code =~ s/^/$text /; + $prevchange = $code; + } else { + print "Unbalanced single quotes. Usage: cc prepend 'text' [and ...]\n"; + exit 0; + } + next; + } + + if ($subcode =~ s/^\s*(and)?\s*append '//) { + $last_keyword = 'append'; + $subcode = "'$subcode"; + + my ($e, $r) = extract_delimited($subcode, "'"); + + my $text; + + if (defined $e) { + $text = $e; + $text =~ s/^'//; + $text =~ s/'$//; + $subcode = $r; + + $got_sub = 1; + $got_changes = 1; + + if (not defined $prevchange) { + print "No recent code to append to.\n"; + exit 0; + } + + $code = $prevchange; + $code =~ s/$/ $text/; + $prevchange = $code; + } else { + print "Unbalanced single quotes. Usage: cc append 'text' [and ...]\n"; + exit 0; + } + next; + } + + if ($subcode =~ m/^\s*(and)?\s*replace\s*([^']+)?\s*'.*'\s*with\s*'.*?'/i) { + $last_keyword = 'replace'; + $got_sub = 1; + my $modifier = 'first'; + + $subcode =~ s/^\s*(and)?\s*//; + $subcode =~ s/replace\s*([^']+)?\s*//i; + $modifier = $1 if defined $1; + $modifier =~ s/\s+$//; + + my ($from, $to); + my ($e, $r) = extract_delimited($subcode, "'"); + + if (defined $e) { + $from = $e; + $from =~ s/^'//; + $from =~ s/'$//; + $from = quotemeta $from; + $from =~ s/\\ / /g; + $subcode = $r; + $subcode =~ s/\s*with\s*//i; + } else { + print "Unbalanced single quotes. Usage: cc replace 'from' with 'to' [and ...]\n"; + exit 0; + } + + ($e, $r) = extract_delimited($subcode, "'"); + + if (defined $e) { + $to = $e; + $to =~ s/^'//; + $to =~ s/'$//; + $subcode = $r; + } else { + print "Unbalanced single quotes. Usage: cc replace 'from' with 'to' [and replace ... with ... [and ...]]\n"; + exit 0; + } + + given($modifier) { + when($_ eq 'all' ) {} + when($_ eq 'last' ) {} + when($_ eq 'first' ) { $modifier = 1; } + when($_ eq 'second' ) { $modifier = 2; } + when($_ eq 'third' ) { $modifier = 3; } + when($_ eq 'fourth' ) { $modifier = 4; } + when($_ eq 'fifth' ) { $modifier = 5; } + when($_ eq 'sixth' ) { $modifier = 6; } + when($_ eq 'seventh') { $modifier = 7; } + when($_ eq 'eighth' ) { $modifier = 8; } + when($_ eq 'nineth' ) { $modifier = 9; } + when($_ eq 'tenth' ) { $modifier = 10; } + default { print "Bad replacement modifier '$modifier'; valid modifiers are 'all', 'first', 'second', ..., 'tenth', 'last'\n"; exit 0; } + } + + my $replacement = {}; + $replacement->{'from'} = $from; + $replacement->{'to'} = $to; + $replacement->{'modifier'} = $modifier; + + push @replacements, $replacement; + next; + } + + if ($subcode =~ m/^\s*(and)?\s*s\/.*\//) { + $last_keyword = undef; + $got_sub = 1; + $subcode =~ s/^\s*(and)?\s*s//; + + my ($regex, $to); + my ($e, $r) = extract_delimited($subcode, '/'); + + if (defined $e) { + $regex = $e; + $regex =~ s/^\///; + $regex =~ s/\/$//; + $subcode = "/$r"; + } else { + print "Unbalanced slashes. Usage: cc s/regex/substitution/[gi] [and s/.../.../ [and ...]]\n"; + exit 0; + } + + ($e, $r) = extract_delimited($subcode, '/'); + + if (defined $e) { + $to = $e; + $to =~ s/^\///; + $to =~ s/\/$//; + $subcode = $r; + } else { + print "Unbalanced slashes. Usage: cc s/regex/substitution/[gi] [and s/.../.../ [and ...]]\n"; + exit 0; + } + + my $suffix; + $suffix = $1 if $subcode =~ s/^([^ ]+)//; + + if (length $suffix and $suffix =~ m/[^gi]/) { + print "Bad regex modifier '$suffix'. Only 'i' and 'g' are allowed.\n"; + exit 0; + } + if (defined $prevchange) { + $code = $prevchange; + } else { + print "No recent code to change.\n"; + exit 0; + } + + my $ret = eval { + my ($ret, $a, $b, $c, $d, $e, $f, $g, $h, $i, $before, $after); + + if (not length $suffix) { + $ret = $code =~ s|$regex|$to|; + ($a, $b, $c, $d, $e, $f, $g, $h, $i) = ($1, $2, $3, $4, $5, $6, $7, $8, $9); + $before = $`; + $after = $'; + } elsif ($suffix =~ /^i$/) { + $ret = $code =~ s|$regex|$to|i; + ($a, $b, $c, $d, $e, $f, $g, $h, $i) = ($1, $2, $3, $4, $5, $6, $7, $8, $9); + $before = $`; + $after = $'; + } elsif ($suffix =~ /^g$/) { + $ret = $code =~ s|$regex|$to|g; + ($a, $b, $c, $d, $e, $f, $g, $h, $i) = ($1, $2, $3, $4, $5, $6, $7, $8, $9); + $before = $`; + $after = $'; + } elsif ($suffix =~ /^ig$/ or $suffix =~ /^gi$/) { + $ret = $code =~ s|$regex|$to|gi; + ($a, $b, $c, $d, $e, $f, $g, $h, $i) = ($1, $2, $3, $4, $5, $6, $7, $8, $9); + $before = $`; + $after = $'; + } + + if ($ret) { + $code =~ s/\$1/$a/g; + $code =~ s/\$2/$b/g; + $code =~ s/\$3/$c/g; + $code =~ s/\$4/$d/g; + $code =~ s/\$5/$e/g; + $code =~ s/\$6/$f/g; + $code =~ s/\$7/$g/g; + $code =~ s/\$8/$h/g; + $code =~ s/\$9/$i/g; + $code =~ s/\$`/$before/g; + $code =~ s/\$'/$after/g; + } + + return $ret; + }; + + if ($@) { + my $error = $@; + $error =~ s/ at .* line \d+\.\s*$//; + print "$error\n"; + exit 0; + } + + if ($ret) { + $got_changes = 1; + } + + $prevchange = $code; + } + + if ($got_sub and not $got_changes) { + print "No substitutions made.\n"; + exit 0; + } elsif ($got_sub and $got_changes) { + next; + } + + last; + } + + if (@replacements) { + use re::engine::RE2 -strict => 1; + @replacements = sort { $a->{'from'} cmp $b->{'from'} or $a->{'modifier'} <=> $b->{'modifier'} } @replacements; + + my ($previous_from, $previous_modifier); + + foreach my $replacement (@replacements) { + my $from = $replacement->{'from'}; + my $to = $replacement->{'to'}; + my $modifier = $replacement->{'modifier'}; + + if (defined $previous_from) { + if ($previous_from eq $from and $previous_modifier =~ /^\d+$/) { + $modifier -= $modifier - $previous_modifier; + } + } + + if (defined $prevchange) { + $code = $prevchange; + } else { + print "No recent code to change.\n"; + exit 0; + } + + my $ret = eval { + my $got_change; + + my ($first_char, $last_char, $first_bound, $last_bound); + $first_char = $1 if $from =~ m/^(.)/; + $last_char = $1 if $from =~ m/(.)$/; + + if ($first_char =~ /\W/) { + $first_bound = '.?'; + } else { + $first_bound = '\b'; + } + + if ($last_char =~ /\W/) { + $last_bound = '.?'; + } else { + $last_bound = '\b'; + } + + if ($modifier eq 'all') { + if ($code =~ s/($first_bound)$from($last_bound)/$1$to$2/g) { + $got_change = 1; + } + } elsif ($modifier eq 'last') { + if ($code =~ s/(.*)($first_bound)$from($last_bound)/$1$2$to$3/) { + $got_change = 1; + } + } else { + my $count = 0; + my $unescaped = $from; + $unescaped =~ s/\\//g; + if ($code =~ s/($first_bound)$from($last_bound)/if (++$count == $modifier) { "$1$to$2"; } else { "$1$unescaped$2"; }/ge) { + $got_change = 1; + } + } + return $got_change; + }; + + if ($@) { + my $error = $@; + $error =~ s/ at .* line \d+\.\s*$//; + print "$error\n"; + exit 0; + } + + if ($ret) { + $got_sub = 1; + $got_changes = 1; + } + + $prevchange = $code; + $previous_from = $from; + $previous_modifier = $modifier; + } + + if (not $got_changes) { + print "No replacements made.\n"; + exit 0; + } + } + + unless($got_undo and not $got_changes) { + $unshift_last_code = 1 unless $copy_code and not $got_changes; + } + + if ($copy_code and $got_changes) { + $self->{only_show} = 0; + } + + if ($got_undo and not $got_changes) { + $self->{only_show} = 1; + } + + unless (($self->{got_run} or $got_diff) and not $got_changes) { + if ($unshift_last_code) { + unshift @last_code, $code; + } + + open LOG, "> $RealBin/../history/$self->{channel}-$self->{lang}.hist"; + + my $i = 0; + foreach my $line (@last_code) { + last if (++$i > $self->{max_history}); + print LOG "$line\n"; + } + + close LOG; + } + + if ($got_diff) { + if ($#last_code < 1) { + print "Not enough recent code to diff.\n" + } else { + use Text::WordDiff; + my $diff = word_diff(\$last_code[1], \$last_code[0], { STYLE => 'Diff' }); + + if ($diff !~ /(?:|)/) { + $diff = "No difference."; + } else { + $diff =~ s/(.*?)(\s+)<\/del>/$1<\/del>$2/g; + $diff =~ s/(.*?)(\s+)<\/ins>/$1<\/ins>$2/g; + $diff =~ s/((?:(?!).)*)<\/del>\s*((?:(?!).)*)<\/ins>/`replaced $1 with $2`/g; + $diff =~ s/(.*?)<\/del>/`removed $1`/g; + $diff =~ s/(.*?)<\/ins>/`inserted $1`/g; + } + + print "$diff\n"; + } + exit 0; + } + + $self->{code} = $code; +} + +1; diff --git a/applets/compiler_vm/host/lib/Languages/_default.pm b/applets/compiler_vm/host/lib/Languages/_default.pm index 581454db..60276ba8 100755 --- a/applets/compiler_vm/host/lib/Languages/_default.pm +++ b/applets/compiler_vm/host/lib/Languages/_default.pm @@ -3,66 +3,129 @@ # SPDX-FileCopyrightText: 2021 Pragmatic Software # SPDX-License-Identifier: MIT +use 5.020; + use warnings; use strict; -use feature "switch"; -use feature 'unicode_strings'; -no if $] >= 5.018, warnings => "experimental::smartmatch"; +use feature qw(switch unicode_strings signatures); +no warnings qw(experimental::smartmatch experimental::signatures); package Languages::_default; -use LWP::UserAgent; -use Time::HiRes qw/gettimeofday/; -use Text::Balanced qw/extract_delimited/; -use JSON; -use Getopt::Long qw/GetOptionsFromArray :config pass_through no_ignore_case no_auto_abbrev/; use Encode; +use JSON::XS; +use Getopt::Long qw(GetOptionsFromArray :config pass_through no_ignore_case no_auto_abbrev); +use Time::HiRes qw(gettimeofday); use FindBin qw($RealBin); +use InteractiveEdit; +use Paste; +use SplitLine; + sub new { my ($class, %conf) = @_; my $self = bless {}, $class; - $self->{debug} = $conf{debug} // 0; - $self->{nick} = $conf{nick}; - $self->{channel} = $conf{channel}; - $self->{lang} = $conf{lang}; - $self->{code} = $conf{code}; - $self->{max_history} = $conf{max_history} // 10000; - $self->{arguments} = $conf{arguments} // ''; - $self->{factoid} = $conf{factoid}; - $self->{'persist-key'} = $conf{'persist-key'}; - $self->{'vm-serial'} = $conf{'vm-serial'}; - $self->{'vm-cid'} = $conf{'vm-cid'}; - $self->{'vm-vport'} = $conf{'vm-vport'}; + %$self = %conf; - $self->{default_options} = ''; - $self->{cmdline} = 'echo Hello, world!'; - - # remove leading and trailing whitespace - $self->{nick} =~ s/^\s+|\s+$//g if defined $self->{nick}; - $self->{channel} =~ s/^\s+|\s+$//g if defined $self->{channel}; - $self->{lang} =~ s/^\s+|\s+$//g if defined $self->{lang}; + $self->{debug} //= 0; + $self->{arguments} //= ''; + $self->{default_options} //= ''; + $self->{max_history} //= 10000; $self->initialize(%conf); + # remove leading and trailing whitespace + $self->{nick} =~ s/^\s+|\s+$//g; + $self->{channel} =~ s/^\s+|\s+$//g; + $self->{lang} =~ s/^\s+|\s+$//g; + return $self; } -sub initialize { - my ($self, %conf) = @_; +sub initialize($self, %conf) {} + +sub process_interactive_edit($self) { + return interactive_edit($self); } -sub pretty_format { - my $self = shift; - return $self->{code}; +sub process_standard_options($self) { + my @opt_args = split_line($self->{code}, preserve_escapes => 1, keep_spaces => 0); + + my $getopt_error; + local $SIG{__WARN__} = sub { + $getopt_error = shift; + chomp $getopt_error; + }; + + my ($info, $arguments, $paste); + GetOptionsFromArray(\@opt_args, + 'info!' => \$info, + 'args|arguments=s' => \$arguments, + 'paste!' => \$paste); + + if ($info) { + my $cmdline = $self->{cmdline}; + if (length $self->{default_options}) { + $cmdline =~ s/\$options/$self->{default_options}/; + } else { + $cmdline =~ s/\$options\s+//; + } + $cmdline =~ s/\$sourcefile/$self->{sourcefile}/g; + $cmdline =~ s/\$execfile/$self->{execfile}/g; + my $name = exists $self->{name} ? $self->{name} : $self->{lang}; + print "$name cmdline: $cmdline\n"; + exit; + } + + if (defined $arguments) { + if (not $arguments =~ s/^"(.*)"$/$1/) { + $arguments =~ s/^'(.*)'$/$1/; + } + $self->{arguments} = $arguments; + } + + if ($paste) { + $self->add_option("-paste"); + } + + $self->{code} = join ' ', @opt_args; + + if ($self->{code} =~ s/-stdin[ =]?(.*)$//) { + $self->add_option("-stdin", $1); + } } -sub preprocess_code { - my ($self, %opts) = @_; +sub process_custom_options {} +sub process_cmdline_options($self) { + my $code = $self->{code}; + + $self->{cmdline_options} = ""; + + while ($code =~ s/^\s*(-[^ ]+)\s*//) { + $self->{cmdline_options} .= "$1 "; + $self->add_option($1); + } + + $self->{cmdline_options} =~ s/\s$//; + + $self->{code} = $code; +} + +sub add_option($self, $option, $value) { + $self->{options_order} //= []; + $self->{options}->{$option} = $value; + push @{$self->{options_order}}, $option; +} + +sub pretty_format($self, $code) { + return $code; +} + +sub preprocess_code($self, %opts) { if ($self->{only_show}) { print "$self->{code}\n"; exit; @@ -136,186 +199,6 @@ sub preprocess_code { $self->{code} = $new_code; } -sub postprocess_output { - my $self = shift; - - unless($self->{got_run} and $self->{copy_code}) { - open LOG, ">> $RealBin/../log.txt"; - print LOG "--------------------------post processing----------------------------------------------\n"; - print LOG localtime() . "\n"; - print LOG "$self->{output}\n"; - close LOG; - } - - # backspace - my $boutput = ""; - my $active_position = 0; - $self->{output} =~ s/\n$//; - while ($self->{output} =~ /(.)/gms) { - my $c = $1; - if ($c eq "\b") { - if (--$active_position <= 0) { - $active_position = 0; - } - next; - } - substr($boutput, $active_position++, 1) = $c; - } - $self->{output} = $boutput; - - my @beeps = qw/*BEEP* *BING* *DING* *DONG* *CLUNK* *BONG* *PING* *BOOP* *BLIP* *BOP* *WHIRR*/; - - $self->{output} =~ s/\007/$beeps[rand @beeps]/g; -} - -sub show_output { - my $self = shift; - my $output = $self->{output}; - - unless ($self->{got_run} and $self->{copy_code}) { - open LOG, ">> $RealBin/../log.txt"; - print LOG "------------------------show output------------------------------------------------\n"; - print LOG localtime() . "\n"; - print LOG "$output\n"; - print LOG "========================================================================\n"; - close LOG; - } - - if (exists $self->{options}->{'-paste'} or (defined $self->{got_run} and $self->{got_run} eq 'paste')) { - my $cmdline = "command: $self->{cmdline}\n"; - - $cmdline =~ s/\$sourcefile/$self->{sourcefile}/g; - $cmdline =~ s/\$execfile/$self->{execfile}/g; - - my $options; - if (length $self->{cmdline_options}) { - $options = $self->{cmdline_options}; - } else { - $options = $self->{default_options}; - } - - if (exists $self->{options_paste}) { - $options .= ' ' if length $options; - $options .= $self->{options_paste}; - } - - if (length $options) { - $cmdline =~ s/\$options/$options/; - } else { - $cmdline =~ s/\$options\s+//; - } - - if (length $self->{arguments}) { - $cmdline .= "arguments: $self->{arguments}\n"; - } - - if ($self->{options}->{'-stdin'}) { - $cmdline .= "stdin: $self->{options}->{'-stdin'}\n"; - } - - my $pretty_code = $self->pretty_format($self->{code}); - - my $cmdline_opening_comment = $self->{cmdline_opening_comment} // "/************* CMDLINE *************\n"; - my $cmdline_closing_comment = $self->{cmdline_closing_comment} // "************** CMDLINE *************/\n"; - - my $output_opening_comment = $self->{output_opening_comment} // "/************* OUTPUT *************\n"; - my $output_closing_comment = $self->{output_closing_comment} // "************** OUTPUT *************/\n"; - - $pretty_code .= "\n\n"; - $pretty_code .= $cmdline_opening_comment; - $pretty_code .= "$cmdline"; - $pretty_code .= $cmdline_closing_comment; - - $output =~ s/\s+$//; - $pretty_code .= "\n"; - $pretty_code .= $output_opening_comment; - $pretty_code .= "$output\n"; - $pretty_code .= $output_closing_comment; - - my $uri = $self->paste_0x0($pretty_code); - print "$uri\n"; - exit 0; - } - - if ($self->{channel} =~ m/^#/ and length $output > 22 and open LOG, "< $RealBin/../history/$self->{channel}-$self->{lang}.last-output") { - my $last_output; - my $time = ; - - if (gettimeofday - $time > 60 * 4) { - close LOG; - } else { - while (my $line = ) { - $last_output .= $line; - } - close LOG; - - if ((not $self->{factoid}) and defined $last_output and $last_output eq $output) { - print "Same output.\n"; - exit 0; - } - } - } - - print "$output\n"; - - open LOG, "> $RealBin/../history/$self->{channel}-$self->{lang}.last-output" or die "Couldn't open $self->{channel}-$self->{lang}.last-output: $!"; - my $now = gettimeofday; - print LOG "$now\n"; - print LOG "$output"; - close LOG; -} - -sub paste_ixio { - my $self = shift; - my $text = join(' ', @_); - - $text =~ s/(.{120})\s/$1\n/g; - - my $ua = LWP::UserAgent->new(); - $ua->agent("Mozilla/5.0"); - push @{ $ua->requests_redirectable }, 'POST'; - $ua->timeout(10); - - my %post = ('f:1' => $text); - my $response = $ua->post("http://ix.io", \%post); - - if (not $response->is_success) { - return "error pasting: " . $response->status_line; - } - - my $result = $response->decoded_content; - $result =~ s/^\s+//; - $result =~ s/\s+$//; - return $result; -} - -sub paste_0x0 { - my $self = shift; - my $text = join ' ', @_; - - $text =~ s/(.{120})\s/$1\n/g; - - my $ua = LWP::UserAgent->new(); - $ua->agent("Mozilla/5.0"); - push @{ $ua->requests_redirectable }, 'POST'; - $ua->timeout(10); - - my $response = $ua->post( - "https://0x0.st", - [ file => [ undef, "filename", Content => $text, 'Content-Type' => 'text/plain' ] ], - Content_Type => 'form-data' - ); - - if (not $response->is_success) { - return "error pasting: " . $response->status_line; - } - - my $result = $response->decoded_content; - $result =~ s/^\s+//; - $result =~ s/\s+$//; - return $result; -} - sub execute { my ($self) = @_; @@ -453,697 +336,130 @@ sub execute { return $result; } -sub add_option { - my $self = shift; - my ($option, $value) = @_; +sub postprocess_output($self) { + unless($self->{got_run} and $self->{copy_code}) { + open LOG, ">> $RealBin/../log.txt"; + print LOG "--------------------------post processing----------------------------------------------\n"; + print LOG localtime() . "\n"; + print LOG "$self->{output}\n"; + close LOG; + } - $self->{options_order} = [] if not exists $self->{options_order}; + # backspace + my $boutput = ""; + my $active_position = 0; + $self->{output} =~ s/\n$//; + while ($self->{output} =~ /(.)/gms) { + my $c = $1; + if ($c eq "\b") { + if (--$active_position <= 0) { + $active_position = 0; + } + next; + } + substr($boutput, $active_position++, 1) = $c; + } + $self->{output} = $boutput; - $self->{options}->{$option} = $value; - push @{$self->{options_order}}, $option; + my @beeps = qw/*BEEP* *BING* *DING* *DONG* *CLUNK* *BONG* *PING* *BOOP* *BLIP* *BOP* *WHIRR*/; + + $self->{output} =~ s/\007/$beeps[rand @beeps]/g; } -sub process_standard_options { - my $self = shift; +sub show_output($self) { + my $output = $self->{output}; - my @opt_args = $self->split_line($self->{code}, preserve_escapes => 1, keep_spaces => 0); + unless ($self->{got_run} and $self->{copy_code}) { + open LOG, ">> $RealBin/../log.txt"; + print LOG "------------------------show output------------------------------------------------\n"; + print LOG localtime() . "\n"; + print LOG "$output\n"; + print LOG "========================================================================\n"; + close LOG; + } - my $getopt_error; - local $SIG{__WARN__} = sub { - $getopt_error = shift; - chomp $getopt_error; - }; + if (exists $self->{options}->{'-paste'} or (defined $self->{got_run} and $self->{got_run} eq 'paste')) { + my $cmdline = "command: $self->{cmdline}\n"; - my ($info, $arguments, $paste); - GetOptionsFromArray(\@opt_args, - 'info!' => \$info, - 'args|arguments=s' => \$arguments, - 'paste!' => \$paste); + $cmdline =~ s/\$sourcefile/$self->{sourcefile}/g; + $cmdline =~ s/\$execfile/$self->{execfile}/g; - if ($info) { - my $cmdline = $self->{cmdline}; - if (length $self->{default_options}) { - $cmdline =~ s/\$options/$self->{default_options}/; + my $options; + if (length $self->{cmdline_options}) { + $options = $self->{cmdline_options}; + } else { + $options = $self->{default_options}; + } + + if (exists $self->{options_paste}) { + $options .= ' ' if length $options; + $options .= $self->{options_paste}; + } + + if (length $options) { + $cmdline =~ s/\$options/$options/; } else { $cmdline =~ s/\$options\s+//; } - $cmdline =~ s/\$sourcefile/$self->{sourcefile}/g; - $cmdline =~ s/\$execfile/$self->{execfile}/g; - my $name = exists $self->{name} ? $self->{name} : $self->{lang}; - print "$name cmdline: $cmdline\n"; - exit; - } - if (defined $arguments) { - if (not $arguments =~ s/^"(.*)"$/$1/) { - $arguments =~ s/^'(.*)'$/$1/; + if (length $self->{arguments}) { + $cmdline .= "arguments: $self->{arguments}\n"; } - $self->{arguments} = $arguments; + + if ($self->{options}->{'-stdin'}) { + $cmdline .= "stdin: $self->{options}->{'-stdin'}\n"; + } + + my $pretty_code = $self->pretty_format($self->{code}); + + my $cmdline_opening_comment = $self->{cmdline_opening_comment} // "/************* CMDLINE *************\n"; + my $cmdline_closing_comment = $self->{cmdline_closing_comment} // "************** CMDLINE *************/\n"; + + my $output_opening_comment = $self->{output_opening_comment} // "/************* OUTPUT *************\n"; + my $output_closing_comment = $self->{output_closing_comment} // "************** OUTPUT *************/\n"; + + $pretty_code .= "\n\n"; + $pretty_code .= $cmdline_opening_comment; + $pretty_code .= "$cmdline"; + $pretty_code .= $cmdline_closing_comment; + + $output =~ s/\s+$//; + $pretty_code .= "\n"; + $pretty_code .= $output_opening_comment; + $pretty_code .= "$output\n"; + $pretty_code .= $output_closing_comment; + + my $uri = $self->paste_0x0($pretty_code); + print "$uri\n"; + exit 0; } - if ($paste) { - $self->add_option("-paste"); - } + if ($self->{channel} =~ m/^#/ and length $output > 22 and open LOG, "< $RealBin/../history/$self->{channel}-$self->{lang}.last-output") { + my $last_output; + my $time = ; - $self->{code} = join ' ', @opt_args; - - if ($self->{code} =~ s/-stdin[ =]?(.*)$//) { - $self->add_option("-stdin", $1); - } -} - -sub process_custom_options { -} - -sub process_cmdline_options { - my $self = shift; - my $code = $self->{code}; - - $self->{cmdline_options} = ""; - - while ($code =~ s/^\s*(-[^ ]+)\s*//) { - $self->{cmdline_options} .= "$1 "; - $self->add_option($1); - } - - $self->{cmdline_options} =~ s/\s$//; - - $self->{code} = $code; -} - -sub process_interactive_edit { - my $self = shift; - my $code = $self->{code}; - my (@last_code, $unshift_last_code); - - print " code: [$code]\n" if $self->{debug}; - - my $subcode = $code; - while ($subcode =~ s/^\s*(-[^ ]+)\s*//) {} - - my $copy_code; - if ($subcode =~ s/^\s*copy\s+(\S+)\s*//) { - my $copy = $1; - - if (open LOG, "< $RealBin/../history/$copy-$self->{lang}.hist") { - $copy_code = ; + if (gettimeofday - $time > 60 * 4) { close LOG; - goto COPY_ERROR if not $copy_code;; - chomp $copy_code; } else { - goto COPY_ERROR; - } + while (my $line = ) { + $last_output .= $line; + } + close LOG; - goto COPY_SUCCESS; - - COPY_ERROR: - print "No history for $copy.\n"; - exit 0; - - COPY_SUCCESS: - $code = $copy_code; - $self->{only_show} = 1; - $self->{copy_code} = 1; - } - - if ($subcode =~ m/^\s*(?:and\s+)?(?:diff|show)\s+(\S+)\s*$/) { - $self->{channel} = $1; - } - - if (open LOG, "< $RealBin/../history/$self->{channel}-$self->{lang}.hist") { - while (my $line = ) { - chomp $line; - push @last_code, $line; - } - close LOG; - } - - unshift @last_code, $copy_code if defined $copy_code; - - if ($subcode =~ m/^\s*(?:and\s+)?show(?:\s+\S+)?\s*$/i) { - if (defined $last_code[0]) { - print "$last_code[0]\n"; - } else { - print "No recent code to show.\n" - } - exit 0; - } - - my $prevchange = $last_code[0]; - my @replacements; - my $got_changes = 0; - my $got_sub = 0; - my $got_diff = 0; - my $got_undo = 0; - my $last_keyword; - - while ($subcode =~ s/^\s*(and)?\s*undo//) { - splice @last_code, 0, 1; - if (not defined $last_code[0]) { - print "No more undos remaining.\n"; - exit 0; - } else { - $code = $last_code[0]; - $prevchange = $last_code[0]; - $got_undo = 1; - } - } - - while (1) { - $got_sub = 0; - - $subcode =~ s/^\s*and\s+'/and $last_keyword '/ if defined $last_keyword; - - if ($subcode =~ m/^\s*(?:and\s+)?diff\b/i) { - $got_diff = 1; - last; - } - - if ($subcode =~ m/^\s*(?:and\s+)?(again|run|paste)\b/i) { - $self->{got_run} = lc $1; - $self->{only_show} = 0; - if ($prevchange) { - $code = $prevchange; - } else { - print "No recent code to $self->{got_run}.\n"; + if ((not $self->{factoid}) and defined $last_output and $last_output eq $output) { + print "Same output.\n"; exit 0; } } - - if ($subcode =~ m/^\s*(and)?\s*remove \s*([^']+)?\s*'/) { - $last_keyword = 'remove'; - my $modifier = 'first'; - - $subcode =~ s/^\s*(and)?\s*//; - $subcode =~ s/remove\s*([^']+)?\s*//i; - $modifier = $1 if defined $1; - $modifier =~ s/\s+$//; - - my ($e, $r) = extract_delimited($subcode, "'"); - - my $text; - - if (defined $e) { - $text = $e; - $text =~ s/^'//; - $text =~ s/'$//; - $subcode = "replace $modifier '$text' with ''$r"; - } else { - print "Unbalanced single quotes. Usage: cc remove [all, first, .., tenth, last] 'text' [and ...]\n"; - exit 0; - } - next; - } - - if ($subcode =~ s/^\s*(and)?\s*prepend '//) { - $last_keyword = 'prepend'; - $subcode = "'$subcode"; - - my ($e, $r) = extract_delimited($subcode, "'"); - - my $text; - - if (defined $e) { - $text = $e; - $text =~ s/^'//; - $text =~ s/'$//; - $subcode = $r; - - $got_sub = 1; - $got_changes = 1; - - if (not defined $prevchange) { - print "No recent code to prepend to.\n"; - exit 0; - } - - $code = $prevchange; - $code =~ s/^/$text /; - $prevchange = $code; - } else { - print "Unbalanced single quotes. Usage: cc prepend 'text' [and ...]\n"; - exit 0; - } - next; - } - - if ($subcode =~ s/^\s*(and)?\s*append '//) { - $last_keyword = 'append'; - $subcode = "'$subcode"; - - my ($e, $r) = extract_delimited($subcode, "'"); - - my $text; - - if (defined $e) { - $text = $e; - $text =~ s/^'//; - $text =~ s/'$//; - $subcode = $r; - - $got_sub = 1; - $got_changes = 1; - - if (not defined $prevchange) { - print "No recent code to append to.\n"; - exit 0; - } - - $code = $prevchange; - $code =~ s/$/ $text/; - $prevchange = $code; - } else { - print "Unbalanced single quotes. Usage: cc append 'text' [and ...]\n"; - exit 0; - } - next; - } - - if ($subcode =~ m/^\s*(and)?\s*replace\s*([^']+)?\s*'.*'\s*with\s*'.*?'/i) { - $last_keyword = 'replace'; - $got_sub = 1; - my $modifier = 'first'; - - $subcode =~ s/^\s*(and)?\s*//; - $subcode =~ s/replace\s*([^']+)?\s*//i; - $modifier = $1 if defined $1; - $modifier =~ s/\s+$//; - - my ($from, $to); - my ($e, $r) = extract_delimited($subcode, "'"); - - if (defined $e) { - $from = $e; - $from =~ s/^'//; - $from =~ s/'$//; - $from = quotemeta $from; - $from =~ s/\\ / /g; - $subcode = $r; - $subcode =~ s/\s*with\s*//i; - } else { - print "Unbalanced single quotes. Usage: cc replace 'from' with 'to' [and ...]\n"; - exit 0; - } - - ($e, $r) = extract_delimited($subcode, "'"); - - if (defined $e) { - $to = $e; - $to =~ s/^'//; - $to =~ s/'$//; - $subcode = $r; - } else { - print "Unbalanced single quotes. Usage: cc replace 'from' with 'to' [and replace ... with ... [and ...]]\n"; - exit 0; - } - - given($modifier) { - when($_ eq 'all' ) {} - when($_ eq 'last' ) {} - when($_ eq 'first' ) { $modifier = 1; } - when($_ eq 'second' ) { $modifier = 2; } - when($_ eq 'third' ) { $modifier = 3; } - when($_ eq 'fourth' ) { $modifier = 4; } - when($_ eq 'fifth' ) { $modifier = 5; } - when($_ eq 'sixth' ) { $modifier = 6; } - when($_ eq 'seventh') { $modifier = 7; } - when($_ eq 'eighth' ) { $modifier = 8; } - when($_ eq 'nineth' ) { $modifier = 9; } - when($_ eq 'tenth' ) { $modifier = 10; } - default { print "Bad replacement modifier '$modifier'; valid modifiers are 'all', 'first', 'second', ..., 'tenth', 'last'\n"; exit 0; } - } - - my $replacement = {}; - $replacement->{'from'} = $from; - $replacement->{'to'} = $to; - $replacement->{'modifier'} = $modifier; - - push @replacements, $replacement; - next; - } - - if ($subcode =~ m/^\s*(and)?\s*s\/.*\//) { - $last_keyword = undef; - $got_sub = 1; - $subcode =~ s/^\s*(and)?\s*s//; - - my ($regex, $to); - my ($e, $r) = extract_delimited($subcode, '/'); - - if (defined $e) { - $regex = $e; - $regex =~ s/^\///; - $regex =~ s/\/$//; - $subcode = "/$r"; - } else { - print "Unbalanced slashes. Usage: cc s/regex/substitution/[gi] [and s/.../.../ [and ...]]\n"; - exit 0; - } - - ($e, $r) = extract_delimited($subcode, '/'); - - if (defined $e) { - $to = $e; - $to =~ s/^\///; - $to =~ s/\/$//; - $subcode = $r; - } else { - print "Unbalanced slashes. Usage: cc s/regex/substitution/[gi] [and s/.../.../ [and ...]]\n"; - exit 0; - } - - my $suffix; - $suffix = $1 if $subcode =~ s/^([^ ]+)//; - - if (length $suffix and $suffix =~ m/[^gi]/) { - print "Bad regex modifier '$suffix'. Only 'i' and 'g' are allowed.\n"; - exit 0; - } - if (defined $prevchange) { - $code = $prevchange; - } else { - print "No recent code to change.\n"; - exit 0; - } - - my $ret = eval { - my ($ret, $a, $b, $c, $d, $e, $f, $g, $h, $i, $before, $after); - - if (not length $suffix) { - $ret = $code =~ s|$regex|$to|; - ($a, $b, $c, $d, $e, $f, $g, $h, $i) = ($1, $2, $3, $4, $5, $6, $7, $8, $9); - $before = $`; - $after = $'; - } elsif ($suffix =~ /^i$/) { - $ret = $code =~ s|$regex|$to|i; - ($a, $b, $c, $d, $e, $f, $g, $h, $i) = ($1, $2, $3, $4, $5, $6, $7, $8, $9); - $before = $`; - $after = $'; - } elsif ($suffix =~ /^g$/) { - $ret = $code =~ s|$regex|$to|g; - ($a, $b, $c, $d, $e, $f, $g, $h, $i) = ($1, $2, $3, $4, $5, $6, $7, $8, $9); - $before = $`; - $after = $'; - } elsif ($suffix =~ /^ig$/ or $suffix =~ /^gi$/) { - $ret = $code =~ s|$regex|$to|gi; - ($a, $b, $c, $d, $e, $f, $g, $h, $i) = ($1, $2, $3, $4, $5, $6, $7, $8, $9); - $before = $`; - $after = $'; - } - - if ($ret) { - $code =~ s/\$1/$a/g; - $code =~ s/\$2/$b/g; - $code =~ s/\$3/$c/g; - $code =~ s/\$4/$d/g; - $code =~ s/\$5/$e/g; - $code =~ s/\$6/$f/g; - $code =~ s/\$7/$g/g; - $code =~ s/\$8/$h/g; - $code =~ s/\$9/$i/g; - $code =~ s/\$`/$before/g; - $code =~ s/\$'/$after/g; - } - - return $ret; - }; - - if ($@) { - my $error = $@; - $error =~ s/ at .* line \d+\.\s*$//; - print "$error\n"; - exit 0; - } - - if ($ret) { - $got_changes = 1; - } - - $prevchange = $code; - } - - if ($got_sub and not $got_changes) { - print "No substitutions made.\n"; - exit 0; - } elsif ($got_sub and $got_changes) { - next; - } - - last; } - if (@replacements) { - use re::engine::RE2 -strict => 1; - @replacements = sort { $a->{'from'} cmp $b->{'from'} or $a->{'modifier'} <=> $b->{'modifier'} } @replacements; + print "$output\n"; - my ($previous_from, $previous_modifier); - - foreach my $replacement (@replacements) { - my $from = $replacement->{'from'}; - my $to = $replacement->{'to'}; - my $modifier = $replacement->{'modifier'}; - - if (defined $previous_from) { - if ($previous_from eq $from and $previous_modifier =~ /^\d+$/) { - $modifier -= $modifier - $previous_modifier; - } - } - - if (defined $prevchange) { - $code = $prevchange; - } else { - print "No recent code to change.\n"; - exit 0; - } - - my $ret = eval { - my $got_change; - - my ($first_char, $last_char, $first_bound, $last_bound); - $first_char = $1 if $from =~ m/^(.)/; - $last_char = $1 if $from =~ m/(.)$/; - - if ($first_char =~ /\W/) { - $first_bound = '.?'; - } else { - $first_bound = '\b'; - } - - if ($last_char =~ /\W/) { - $last_bound = '.?'; - } else { - $last_bound = '\b'; - } - - if ($modifier eq 'all') { - if ($code =~ s/($first_bound)$from($last_bound)/$1$to$2/g) { - $got_change = 1; - } - } elsif ($modifier eq 'last') { - if ($code =~ s/(.*)($first_bound)$from($last_bound)/$1$2$to$3/) { - $got_change = 1; - } - } else { - my $count = 0; - my $unescaped = $from; - $unescaped =~ s/\\//g; - if ($code =~ s/($first_bound)$from($last_bound)/if (++$count == $modifier) { "$1$to$2"; } else { "$1$unescaped$2"; }/ge) { - $got_change = 1; - } - } - return $got_change; - }; - - if ($@) { - my $error = $@; - $error =~ s/ at .* line \d+\.\s*$//; - print "$error\n"; - exit 0; - } - - if ($ret) { - $got_sub = 1; - $got_changes = 1; - } - - $prevchange = $code; - $previous_from = $from; - $previous_modifier = $modifier; - } - - if (not $got_changes) { - print "No replacements made.\n"; - exit 0; - } - } - - unless($got_undo and not $got_changes) { - $unshift_last_code = 1 unless $copy_code and not $got_changes; - } - - if ($copy_code and $got_changes) { - $self->{only_show} = 0; - } - - if ($got_undo and not $got_changes) { - $self->{only_show} = 1; - } - - unless (($self->{got_run} or $got_diff) and not $got_changes) { - if ($unshift_last_code) { - unshift @last_code, $code; - } - - open LOG, "> $RealBin/../history/$self->{channel}-$self->{lang}.hist"; - - my $i = 0; - foreach my $line (@last_code) { - last if (++$i > $self->{max_history}); - print LOG "$line\n"; - } - - close LOG; - } - - if ($got_diff) { - if ($#last_code < 1) { - print "Not enough recent code to diff.\n" - } else { - use Text::WordDiff; - my $diff = word_diff(\$last_code[1], \$last_code[0], { STYLE => 'Diff' }); - - if ($diff !~ /(?:|)/) { - $diff = "No difference."; - } else { - $diff =~ s/(.*?)(\s+)<\/del>/$1<\/del>$2/g; - $diff =~ s/(.*?)(\s+)<\/ins>/$1<\/ins>$2/g; - $diff =~ s/((?:(?!).)*)<\/del>\s*((?:(?!).)*)<\/ins>/`replaced $1 with $2`/g; - $diff =~ s/(.*?)<\/del>/`removed $1`/g; - $diff =~ s/(.*?)<\/ins>/`inserted $1`/g; - } - - print "$diff\n"; - } - exit 0; - } - - $self->{code} = $code; -} - -# splits line into quoted arguments while preserving quotes. -# a string is considered quoted only if they are surrounded by -# whitespace or json separators. -# handles unbalanced quotes gracefully by treating them as -# part of the argument they were found within. -sub split_line { - my ($self, $line, %opts) = @_; - - my %default_opts = ( - strip_quotes => 0, - keep_spaces => 0, - preserve_escapes => 1, - ); - - %opts = (%default_opts, %opts); - - my @chars = split //, $line; - - my @args; - my $escaped = 0; - my $quote; - my $token = ''; - my $last_token = ''; - my $ch = ' '; - my $last_ch; - my $next_ch; - my $i = 0; - my $pos = 0; - my $ignore_quote = 0; - my $spaces = 0; - - while (1) { - $last_ch = $ch; - - if ($i >= @chars) { - if (defined $quote) { - # reached end, but unbalanced quote... reset to beginning of quote and ignore it - $i = $pos; - $ignore_quote = 1; - $quote = undef; - $last_ch = ' '; - $token = $last_token; - } else { - # add final token and exit - push @args, $token if length $token; - last; - } - } - - $ch = $chars[$i++]; - $next_ch = $chars[$i]; - - my $dquote = $quote // 'undef'; - $spaces = 0 if $ch ne ' '; - - if ($escaped) { - if ($opts{preserve_escapes}) { - $token .= "\\$ch"; - } else { - $token .= $ch; - } - $escaped = 0; - next; - } - - if ($ch eq '\\') { - $escaped = 1; - next; - } - - if (defined $quote) { - if ($ch eq $quote and (not defined $next_ch or $next_ch =~ /[\s,:;})\].+=]/)) { - # closing quote - $token .= $ch unless $opts{strip_quotes}; - push @args, $token; - $quote = undef; - $token = ''; - } else { - # still within quoted argument - $token .= $ch; - } - next; - } - - if (($last_ch =~ /[\s:{(\[.+=]/) and not defined $quote and ($ch eq "'" or $ch eq '"')) { - if ($ignore_quote) { - # treat unbalanced quote as part of this argument - $token .= $ch; - $ignore_quote = 0; - } else { - # begin potential quoted argument - $pos = $i - 1; - $quote = $ch; - $last_token = $token; - $token .= $ch unless $opts{strip_quotes}; - } - next; - } - - if ($ch eq ' ') { - if (++$spaces > 1 and $opts{keep_spaces}) { - $token .= $ch; - next; - } else { - push @args, $token if length $token; - $token = ''; - next; - } - } - - $token .= $ch; - } - - return @args; + open LOG, "> $RealBin/../history/$self->{channel}-$self->{lang}.last-output" or die "Couldn't open $self->{channel}-$self->{lang}.last-output: $!"; + my $now = gettimeofday; + print LOG "$now\n"; + print LOG "$output"; + close LOG; } 1; diff --git a/applets/compiler_vm/host/lib/Paste.pm b/applets/compiler_vm/host/lib/Paste.pm new file mode 100644 index 00000000..9961a523 --- /dev/null +++ b/applets/compiler_vm/host/lib/Paste.pm @@ -0,0 +1,64 @@ +#!/usr/bin/env perl + +package Paste; + +use 5.020; + +use warnings; +use strict; + +use LWP::UserAgent; + +use parent qw(Exporter); +our @EXPORT = qw(paste_ixio paste_0x0); + +sub paste_ixio { + my $text = join(' ', @_); + + $text =~ s/(.{120})\s/$1\n/g; + + my $ua = LWP::UserAgent->new(); + $ua->agent("Mozilla/5.0"); + push @{ $ua->requests_redirectable }, 'POST'; + $ua->timeout(10); + + my %post = ('f:1' => $text); + my $response = $ua->post("http://ix.io", \%post); + + if (not $response->is_success) { + return "error pasting: " . $response->status_line; + } + + my $result = $response->decoded_content; + $result =~ s/^\s+//; + $result =~ s/\s+$//; + return $result; +} + +sub paste_0x0 { + my $text = join ' ', @_; + + $text =~ s/(.{120})\s/$1\n/g; + + my $ua = LWP::UserAgent->new(); + $ua->agent("Mozilla/5.0"); + push @{ $ua->requests_redirectable }, 'POST'; + $ua->timeout(10); + + my $response = $ua->post( + "https://0x0.st", + [ file => [ undef, "filename", Content => $text, 'Content-Type' => 'text/plain' ] ], + Content_Type => 'form-data' + ); + + if (not $response->is_success) { + return "error pasting: " . $response->status_line; + } + + my $result = $response->decoded_content; + $result =~ s/^\s+//; + $result =~ s/\s+$//; + return $result; +} + +1; diff --git a/applets/compiler_vm/host/lib/SplitLine.pm b/applets/compiler_vm/host/lib/SplitLine.pm new file mode 100644 index 00000000..832d537d --- /dev/null +++ b/applets/compiler_vm/host/lib/SplitLine.pm @@ -0,0 +1,130 @@ +#!/usr/bin/env perl + +package SplitLine; + +use 5.020; + +use warnings; +use strict; + +use feature 'signatures'; +no warnings 'experimental::signatures'; + +use parent qw(Exporter); +our @EXPORT = qw(split_line); + +# splits line into quoted arguments while preserving quotes. +# a string is considered quoted only if they are surrounded by +# whitespace or json separators. +# handles unbalanced quotes gracefully by treating them as +# part of the argument they were found within. +sub split_line ($line, %opts) { + my %default_opts = ( + strip_quotes => 0, + keep_spaces => 0, + preserve_escapes => 1, + ); + + %opts = (%default_opts, %opts); + + my @chars = split //, $line; + + my @args; + my $escaped = 0; + my $quote; + my $token = ''; + my $last_token = ''; + my $ch = ' '; + my $last_ch; + my $next_ch; + my $i = 0; + my $pos = 0; + my $ignore_quote = 0; + my $spaces = 0; + + while (1) { + $last_ch = $ch; + + if ($i >= @chars) { + if (defined $quote) { + # reached end, but unbalanced quote... reset to beginning of quote and ignore it + $i = $pos; + $ignore_quote = 1; + $quote = undef; + $last_ch = ' '; + $token = $last_token; + } else { + # add final token and exit + push @args, $token if length $token; + last; + } + } + + $ch = $chars[$i++]; + $next_ch = $chars[$i]; + + my $dquote = $quote // 'undef'; + $spaces = 0 if $ch ne ' '; + + if ($escaped) { + if ($opts{preserve_escapes}) { + $token .= "\\$ch"; + } else { + $token .= $ch; + } + $escaped = 0; + next; + } + + if ($ch eq '\\') { + $escaped = 1; + next; + } + + if (defined $quote) { + if ($ch eq $quote and (not defined $next_ch or $next_ch =~ /[\s,:;})\].+=]/)) { + # closing quote + $token .= $ch unless $opts{strip_quotes}; + push @args, $token; + $quote = undef; + $token = ''; + } else { + # still within quoted argument + $token .= $ch; + } + next; + } + + if (($last_ch =~ /[\s:{(\[.+=]/) and not defined $quote and ($ch eq "'" or $ch eq '"')) { + if ($ignore_quote) { + # treat unbalanced quote as part of this argument + $token .= $ch; + $ignore_quote = 0; + } else { + # begin potential quoted argument + $pos = $i - 1; + $quote = $ch; + $last_token = $token; + $token .= $ch unless $opts{strip_quotes}; + } + next; + } + + if ($ch eq ' ') { + if (++$spaces > 1 and $opts{keep_spaces}) { + $token .= $ch; + next; + } else { + push @args, $token if length $token; + $token = ''; + next; + } + } + + $token .= $ch; + } + + return @args; +} + +1;