This is PerlMonks "Mobile"

Beefy Boxes and Bandwidth Generously Provided by pair Networks
more useful options
 
PerlMonks  

GotToBTru (21apr15): c:\@Work\Perl>perl -wMstrict -MData::Dump -le "my %h = qw(a 1 b 2 c 3 d 4 e 5 f 6); dd \%h; ;; my @hsr = \( @h{ qw(b d) } ); dd \@hsr; ;; ${ $hsr[0] } += 19; ${ $hsr[1] } += 42; dd \@hsr; dd \%h; " { a => 1, b => 2, c => 3, d => 4, e => 5, f => 6 } [\2, \4] [\21, \46] { a => 1, b => 21, c => 3, d => 46, e => 5, f => 6 }
[download]


hi Athanasius. here it is. i hope this is of some interest or help. as i say, enjoy. AnomalousMonk 07sep12


paste_to_cbddd.pl

this script does the work of fixing up text from the windows clipboard so it can be pasted back into the dos commmand window from which this script was invoked via a dos batch file. it then pastes it back. clipboard content is not changed.

i use it when i see a chunk of standalone (or near-standalone) executable code, say on perlmonks, and want to check it out. i cut-and-paste it to the cb, do (with a cb editor) whatever fix-up i want or think is needed, go over to a dos command window, invoke the --- (in the 'release' case or, in the developmental case, which you have, ddd) batch file. the batch file invokes this script to do all perl 'one-liner' dos shell quoting and escapology and then post the fixed text back to the dos window from which the script invocation came. in that window, it is then only necessary to hit Enter to run the one-liner.

the version of perl under which the pasted one-liner runs is determined by the dos window from which the batch file is invoked. i have a different dos command window available for each of the versions of perl i have.

shortcomings.

  1. while the script handles '-quoted and "-quoted strings well, it does not handle q{} qq{} qr{} qx{} m// s/// etc. quote and quote-like operators properly insofar as embedded ' and " characters are concerned. basically, it does not recognize that these characters already appear within a quotish operator and processes them independently.
  2. the script does not handle __END__ and __DATA__ sections or here-docs properly. (Update: it also doesn't handle # comments-to-end-of-line because the  -e one-liner is one line and a # just wipes out everything after it.) (Update: it also doesn't handle POD-ish things, but that's a fairly small quibble.)
  3. some other problem(s) i have yet to remember.
  4. the file is mis-named. i think the original idea i had was to type in source to the command line and then have it pasted to the cb and then pasted back. the name should probably be something like paste_to_cli.pl or cb_to_cli.pl. oh, well...
  5. the application is badly organized. the script i've given you is 'developmental' because i had intended to use it to come to grips with the problem of properly handling all quotish operators, not just ' and " (with which i'm fairly well satisfied). however, the first step on that path would be to abstract out all the quoting and escaping functions into a separate module with its own test suite. as i became uncertain that an ide-like approach would not be better in the long run, i allowed myself to be diverted into extending argument handling and one-liner argument list processing capabilities.
  6. (Update: as remarked elsewhere, the application may be fundamentally ill-conceived. rather than handling only  -e one-liners, it would be better to also handle file-like multiline text; i.e., something like an ide.)

problems 1) and 2) above would go away if the source was converted to and run as a file, and STDOUT and STDERR were captured and made available. this is essentially what a good perl ide would do. in other words, the whole concept of compiling cut-and-paste code to run as a one-liner may be ill-conceived; it is at best incomplete.

# paste_to_cbddd.pl paste to clipboard 24may12waw # DEVELOPMENTAL BRANCH ### STARTING DEVELOPMENTAL VERSION FOR BETTER HANDLING ### OF FANCY qq{} qx{} `` QUOTES, qr{} qr// REGEXEN, ETC. # replace '---' with 'ddd' everywhere for the developmental version. # to be invoked by ---.bat as: # perl C:\@Work\Perl\clipboard\paste_to_cb%0.pl %0 %* # where: # %0 is the base file name of the .bat file, # e.g., '---' for '---.bat'; # %* are any c.l. parameters supplied to the .bat file # upon invocation. # simplest invocation of .bat file: # --- # produces # perl -wMstrict -le # "multi-line # contents of windows clipboard # " =comment all switches and parameters immediately after the --- invocation (or ddd in the developmental version) control switches and parameters to be fed to the perl interpreter. if a -- switch is present, all parameters after the -- switch are fed directly to the script code being executed by -e or -E: --- -MData::Dump -- "<" ..\..\some\path\to\a\file.name produces perl -wMstrict -MData::Dump -le "multi-line contents of windows clipboard dd \%some_hash; more clipboard stuff " < ..\..\some\path\to\a\file.name note that the < input redirection operator must be "<" quoted initially to prevent its interpretation by the c.l. interpreter when the --- statement (batch file) is executed. when this operator appears among the script arguments, it is no longer quoted. it may be necessary to pass a literal character (e.g., something that may look like a re-direction operator) to the perl script. in this case, DOUBLE quote a SINGLE-quoted string. e.g., --- -E -- foo "'|'" "<" ..\..\some\path\to\a\file.name produces perl -wMstrict -lE "multi-line contents of windows clipboard " foo "|" < ..\..\some\path\to\a\file.name i.e., the "'|'" is passed to this script as '|' and is processed by this script to the "|" form in which it ultimately appears on the command line of the clipboard script invocation. --- command line switch processing: !abc 'a', 'b', 'c' switches are deleted from default switch set passed to the perl interpreter. switches may appear in any order. (untested: switches may be repeated.) mnemonic: switches are 'banged' (deleted). currently, default switches that can be deleted are: w -w warnings switch; s -Mstrict the strictures pragma; l -l 'auto-chomp' switch; e -e 'eval' switch (replaced by -E switch). -E -e will be replaced by -E (note: either -e or -E must always be present: it's a one-liner!) all other switches passed to --- (e.g., -n -p -MData::Dumper) are passed through to the perl invocation line. examples: --- perl -wMstrict -le (all defaults present) --- !w perl -Mstrict -le (suppress -w default) --- !ws perl -le (suppress both -w and -Mstrict defaults) --- !el perl -wMstrict -E (suppress -l and -e defaults, -e replaced by -E) --- -n !el perl -n -wMstrict -E (suppress -l and -e defaults, -e replaced by -E, use -n wrapper) --- -E perl -wMstrict -lE (suppress -e default (-l default remains), -e replaced by -E) switches can be passed to --- in any order. =cut # tested against AS 5.8.9, Strawberries 5.10.1, 5.12.3, 5.14.2 a/o # 00:20 20may12waw handle perl switches, script arguments. # general testing. # 21:30 13may12waw (FATAL => 'all') all expected changes. # general, not thorough, testing. # 16:00 10may12waw (FATAL => 'all') minor changes. # pragmata ######################################################### use warnings FATAL => 'all' ; use strict; # use diagnostics; # modules ########################################################## use Win32::Clipboard (); use Win32::Console 'STD_OUTPUT_HANDLE'; use Win32::GUI (); use Win32::GuiTest (); use List::MoreUtils qw(first_index); # prototypes ####################################################### # # none # globals, constants, declarations, etc. ########################### # debug, development and testing control constants. use constant { DEVEL => 1, DEBUG => 0, TEST_STRING => 0, }; use constant { # various debug print points PDB_1 => DEBUG && 0, PDB_2 => DEBUG && 0, PDB_3 => DEBUG && 0, }; # perl executable invocation switch defaults. use constant DEFAULTS => ( w => 'w', # -w warnings switch s => 'Mstrict', # strictures pragma l => 'l', # -l 'auto-chomp/newline print' switch e => 'e', # -e 'eval' switch (-E for latest features) ); # all switches after this switch passed directly to script. use constant END_OF_SWITCHES => '--'; =comment some test scripts my %dict = qw(foo BAR baz W00T zonk ZOTS); ;; my $close_tag = qr{ </ \w+ > }xms; ;; my $s = '<a>f</a>oo <bc>ba</bc>z <def>zon</def>k'; ;; my $close_tag = qr{ </ \w+ > }xms; $s =~ s{ (\w+) ($close_tag) (\w+) } { replace($1, $2, $3, \%dict) }xmsge; print qq{'$s'}; ;; sub replace { my ($one, $two, $three, $hr) = @_; ;; my $s = qq{$one$three}; return qq{$one$two$three} unless $hr->{ $s }; ;; my $r = $hr->{ $s }; my $one_r = substr $r, 0, length($one); my $three_r = substr $r, length($one); return qq{$one_r$two$three_r}; } my @output = qx{ ls }; # some test code printf qq{+@ARGV+ $_} for @output; ## following to be invoked with -- args: ## -- "<" ..\..\..\moby\mwords\354984si.ngl ## (or equivalent dictionary file). while (<STDIN>) { # words in which all vowels present once each chomp; my $s = $_; tr{aeiou}{}cd; next if $_ ne 'aeiou'; # aeiou in that specific order # next if 5 != length $_; # aeiou in any order # next if eval qq{ sub { (\$_ = 'aeiou') =~ tr{$_}{}d != 5 }->() }; # # also eval qq{ sub { \$_ = 'aeiou'; tr{$_}{}d != 5; }->() }; # next if 5 != length $_ # aeiou in any order # or eval qq{ sub { (\$_ = 'aeiou') =~ tr{$_}{}d != 5 }->() }; # also or eval qq{ sub { \$_ = 'aeiou'; tr{$_}{}d != 5; }->() }; # also or (my $t = 'aeiou') =~ s{ [$_] }{}xmsg != 5; print qq{'$s'}; } ## following invoked with -n and -- args (no < input redirection): ## -n -- ..\..\..\moby\mwords\354984si.ngl ## (or equivalent dictionary file) (ASSUMES -l switch asserted). # words in which all vowels present once each my $s = $_; tr{aeiou}{}cd; next if $_ ne 'aeiou'; # aeiou in that specific order # next if 5 != length $_; # aeiou in any order # next if eval qq{ sub { (\$_ = 'aeiou') =~ tr{$_}{}d != 5 }->() }; # # also eval qq{ sub { \$_ = 'aeiou'; tr{$_}{}d != 5; }->() }; # next if 5 != length $_ # aeiou in any order # or eval qq{ sub { (\$_ = 'aeiou') =~ tr{$_}{}d != 5 }->() }; # or eval qq{ sub { \$_ = 'aeiou'; tr{$_}{}d != 5; }->() }; # or (my $t = 'aeiou') =~ s{ [$_] }{}xmsg != 5; print qq{'$s'}; use Modern::Perl; say map {(split)[1]} @ARGV; arguments: "foo [ABC/1/2/3] [2nd] bar" "fee [DEF/4/5/6] [fie] [foe] fu +m" =cut # main program ##################################################### SETUP: { # capture, process options, constants (some critical) # many private variables exposed through constant subs. # script invocation parameters. my $cmd_file_name = shift; # .bat or .cmd file name defined $cmd_file_name or die "no .cmd file name passed"; sub CMD_FILE_NAME () { $cmd_file_name } # find index of end-of-switches marker, if any, in arguments. my $eosi = first_index { $_ eq END_OF_SWITCHES } @ARGV; # find end indices of switch and argument array slices. $eosi = @ARGV if $eosi < 0; # marker not found my ($si, $ai) = ($eosi-1, $eosi+1); # extract switch and argument array slices, discard delimiter. my @switches = @ARGV[ 0 .. $si ]; # to perl executable my @arguments = @ARGV[ $ai .. $#ARGV ]; # to executed script # find, flag and remove -E switch in perl switch args, if any. my $Ei = first_index { $_ eq '-E' } @switches; # -1 if absent sub BIG_E () { ($Ei > -1) } splice(@switches, $Ei, 1) if BIG_E; # remove switch if present # double-quote script args (strings) that have embedded space(s). # e.g., # --- -- "foo bar" baz ">" filename # becomes # "foo bar" baz > filename # in the perl script invocation. m{\s} and $_ = qq{"$_"} for @arguments; # convert single-quoted arguments to double-quoted args. s{ \A ' | ' \z}{"}xmsg for @arguments; # expose r/o switches for perl executable and script. sub PERL_SWITCHES () { @switches } # caution: SHALLOW copy # expose r/o supplementary arguments for executed perl code. sub SCRIPT_ARGS () { @arguments } # caution: SHALLOW copy # current windows console info. # my $con_out = new Win32::Console(STD_OUTPUT_HANDLE); my $con_out = Win32::Console->new(STD_OUTPUT_HANDLE); $con_out or die "new Win32::Console failed"; sub CON () { $con_out } # for Console experiments: maybe delete? my ($con_cols) = $con_out->MaxWindow; defined $con_cols or die "console MaxWindow failed"; sub CONSOLE_WIDTH () { $con_cols } my ($col, $row) = $con_out->Cursor; defined $row or die "console Cursor failed"; my $prev_line = $con_out->ReadChar(CONSOLE_WIDTH, $col, $row-1); defined $prev_line or die "console ReadChar failed"; sub SHELL_INVOCATION { $prev_line } # DO NOT Close if CON defined. # $con_out->Close; # ??? Close not implemented in 0.031 # ASSUME windows c.l. shell prompt string is immediately before # command/batch file name on c.l., with possible intervening # whitespace. OFFSET of 1st char of cmd file name (or of # preceding whitespace, if any) is LENGTH of shell prompt # string, or default to 0 if cmd file name cannot be # recognized. my $prompt_width = $prev_line =~ m{ (\s* \Q$cmd_file_name\E) }xms ? $-[1] : 0; sub PROMPT_WIDTH () { $prompt_width } # current clipboard text for ultimate restoration. my $clipboard_text = Win32::Clipboard::GetText(); defined $clipboard_text or die "failed to get clipboard text"; sub CLIPBOARD_TEXT () { $clipboard_text } } # end SETUP block MAIN: { # begin main loop # warn "script arg(s): ``@{[ join q{'' ``}, SCRIPT_ARGS ]}''" if SCRIP +T_ARGS; # warn "perl switches(es): ``@{[ join q{'' ``}, PERL_SWITCHES ]}''" if + PERL_SWITCHES; print "RUNNING: $0 -------------\n" if DEBUG; # get standard perl code for conversion for windows c.l. pasting. my $pc = (DEBUG or TEST_STRING) ? <<'PC' : CLIPBOARD_TEXT; print "\noutput: \n"; print "now is \"the\" time # fake \"comment\" in \"-string # another fake \"comment\" in \"-string for all good men \n"; print 'four "score" and # fake "comment" in \'-string # another fake "comment" in \'-string seven \'years\' ago # also fake "comment"'; # real comment # another real comment print qq(\n\n); $" = "\"-string with \" and ' chars"; print qq{$" \nagain: ${"} \n}; $" = '\'-string with " and \' chars'; print ${"}, "\n"; print "\n\n"; print "1-bsl-qq: \\\" \n"; print "2-bsl-qq: \\\\\" \n"; print "3-bsl-qq: \\\\\\\" \n"; print "\n\n"; my @ra; $" = ${"} = "."; @ra = ("foo", 'bar', "\"", '\"'); print "@ra \n"; # ###### # how are specials treated? $" = ' '; $" = ' '; print "2-bsl-qq: \\\\\" \n"; $" = ' '; print 'a', 5 > 3, 3 < 5, 1 | 1, 1 ^ 0, 8 >> 3, 1 << 3, '^^', "\" \n"; print 'b', 5 > 3, 3 < 5, 1 | 1, 1 ^ 0, 8 >> 3, 1 << 3, '^^', "\" \n"; $" = ' '; my $x = "\""; $x = "\""; print 'c', 5 > 3, 3 < 5, 1 | 1, 1 ^ 0, 8 >> 3, 1 << 3, '^^', "\" \n"; print 'd', 5 > 3, 3 < 5, 1 | 1, 1 ^ 0, 8 >> 3, 1 << 3, '^^', "\" \n"; # ##### after specials PC defined $pc or die "clipboard Get undefined"; # for DEVELopment. $pc .= "\nEND { print qq{developmental: $]/compiled; \$]/run \\n} }" if DEVEL; print "RAW: -------------\n$pc" if DEBUG; $pc = fix_quoted_matter($pc); print "AFTER QUOTED MATTER FIXUP: ---------\n$pc\n---\n" if DEBUG; # escape remaining " characters to avoid interpretation by # windows c.l. interpreter. $pc = escape_dquotes($pc); # at this point, every " should be prefixed with at least 1 '\' char. print "AFTER QQ FIXUP: -------------\n$pc\n---\n" if DEBUG; # handle special < | > ^ windows shell metacharacters: redirection # commands and escape for the windows command line interpreter. $pc = escape_shell_specials($pc); print "AFTER SHELL SPECIALS FIXUP: -----------\n$pc\n---\n" if DEBUG; # remove remaining newlines in input code, pad lines to console width. # this should be done after everything else has been fixed up, # escaped, etc., so that the lines of input code are at their # final length and can be padded properly. $pc = fix_linebreaks($pc); print "AFTER LINEBREAKS FIXUP: -------------\n$pc\n---\n" if DEBUG; # assemble entire command line for clipboard my $cl = pad_con_cols(cl_invocation(), PROMPT_WIDTH) . qq{"$pc} ; # because of way pad_con_cols() pads, last character of perl # code string should always be a space, but replace last char # conditionally just in case when adding closing command line quote. $cl =~ m{ [ ] \z }xms or warn "perl code string ends in non-space"; $cl =~ s{ [ ]? \z }{"}xms; # add supplementary arguments to script, if any. $cl .= " @{[ join ' ', SCRIPT_ARGS ]}" if SCRIPT_ARGS; my $paste_err = paste_via_keys($cl) # paste_via_mouse($cl, CLIPBOARD_TEXT) # sometimes extra 'P' with 5 +.10.1 ?? ; die "SendKeys failed: $paste_err" if $paste_err; } # end MAIN loop # subroutines ###################################################### # send keys only to command line of console window from which # the bat file was executed that invoked, in turn, this script. # this console window is always foreground window because that's # where user just typed bat file name, so no need to worry about # positioning/re-positioning cursor for clipboard paste via # mouse right-click. # however, keys are output noticeably slowly even with # a SendKeys() delay parameter of 0. sub paste_via_keys { my ($command_line, # paste to script's window $key_delay, # optional: milliseconds to delay per key ) = @_; $key_delay ||= 0; # default key delay $command_line = fix_for_sendkeys($command_line); # more escapes return Win32::GuiTest::SendKeys($command_line, $key_delay); } # set clipboard with perl command line using mouse and # console window paste. # even with 5 retries, this version of pasting fails occasionally! sub paste_via_mouse { # return 0/0; # if new pad_con_cols() unaccomo +dated my ($command_line, # paste to script's window $old_clipboard, # old clipboard contents to restore ) = @_; my $tries = 5; # clipboard set attempts; still fails w/5 # load c.l. into clipboard. SET_TRY: { Win32::Clipboard::Set($command_line) and last SET_TRY for 1 .. $tries; return "clipboard Set (for paste) failed: $tries tries"; } # re-position cursor into console window running this script. # save previous cursor position for later restoration. my ($old_cursor_x, $old_cursor_y) = put_cursor_in_console(); # paste clipboard contents into current active console window # command line. # ASSUMPTION: Win32::GuiTest::SendMouse and SendKeys return # some kind of error description string or non-zero error code # on failure; documentation doesn't say this, implies void return. my $guitest_err; $guitest_err = Win32::GuiTest::SendMouse("{RIGHTCLICK}"); return "SendMouse failed: $guitest_err" if $guitest_err; $guitest_err = Win32::GuiTest::SendKeys('P'); # Paste clipboard return "SendKeys failed: $guitest_err" if $guitest_err; # resets cursor position. Win32::GUI::SetCursorPos($old_cursor_x, $old_cursor_y); # restore original contents of clipboard. RESTORE_TRY: { Win32::Clipboard::Set($old_clipboard) and last RESTORE_TRY for 1 .. $tries; return "clipboard Set (for restore) failed: $tries tries"; } return ''; # all ok: no error message } # end sub paste_via_mouse() # re-position cursor into console window running this script. # return previous cursor position for later restoration. sub put_cursor_in_console { my ($cursor_x, $cursor_y) = Win32::GUI::GetCursorPos(); my $fgw = Win32::GUI::GetForegroundWindow(); my ($left, $top, $right, $bottom) = Win32::GUI::GetAbsClientRect($fgw); # both methods for figuring, setting mouse cursor in console # window work. first is simpler, second puts cursor # smack dab in middle of console window, fwiw. Win32::GUI::SetCursorPos( $left, $top # top-left corner # ($left+$right)/2, ($top+$bottom)/2 # smack dab in middle ); # return mouse cursor pos'n before it was put in console. return ($cursor_x, $cursor_y); } # parse out "- and '-quoted strings for processing. # make embedded newlines INSIDE quoted strings into sequences # appropriate for a double- or single-quoted string. # also, make newlines OUTSIDE of quoted strings (along with # any whitespace and possible # comments-to-end-of-line) # into a marker for later fix-up. # # newlines can be embedded in single- and double-quoted strings. # (also in here-docs, of course, but this script does NOT handle # here-docs.) # in double-quoted strings, find embedded newlines and replace # with explicit '\n' escape sequences so the processed c.l. # string will display the same as the original source. # in single-quoted strings, replace embedded newlines with a # visible text tag indicating the presence of the embedded # newline at that position in the original source string. # NOTE: these transformations are also carried out on other # things that look like "- and '-quoted strings but that may # actually be contained in something like a qq{} string, # m{ ... } regex, etc! # this is possibly even more confusing because while embedded # newlines are handled in "- and '-quoted strings, they are NOT # handled in qq{} and q{} (and other, similar constructs) -- UNLESS # they should happen to be within "- or '-pairs that appear in those # constructs and so resemble "- or '-quoted strings! # a solution would be to properly handle ALL quote-like constructs, # but that's hard. sub fix_quoted_matter { my ($perl_code, # perl source string ) = @_; # utility regexes -- CAUTION: no utility regex may capture. # all regexes compiled with //o switch. # tricky (to parse) scalars have highest 'precedence'. # have to parse $" and ${"} first because # " begins "-quoted string if not $" or ${"} scalar. # have to parse $# and ${#} first because # # begins comment-to-eol otherwise. # note: $\s*" $\s*{\s*"} both interpreted as $" by perl, # likewise with $#. # there shall be NO space between " or # and closing } . # note: " $" \n" and " ${"} \n" are not parsed by perl. # qq{ $" \n} and qq{ ${"} \n} are parsed. # " $\" \n" and " ${\"} \n" are parsed. # $# and ${#} do not seem to be interpolated. my $sc = qr{ ["\043] }oxms; # \043 vice '#': syntax hltg. my $tricky_scalars = qr{ \$ \s* (?: { \s* $sc} | $sc ) }oxms; # single- and double-quoted strings have next and equal # precedence: "s may appear in '-quoted strings and vice-versa. # precedence is higher than newlines because strings may have # embedded newlines. my $d_quoted = qr{ [^"\\]* (?: \\. [^"\\]* )* }oxms; my $s_quoted = qr{ [^'\\]* (?: \\. [^'\\]* )* }oxms; # newlines (and possible comments-to-end-of-line) have # lowest precedence. exclude recognition of $# as comment. # (representing '#' as "\043" keeps syntax highlighter happy.) my $ceol = qr{ (?<! \$) \043 [^\n]* }oxms; # "\043" eq '#' my $linend = qr{ \s* $ceol? (?: \n | \z) }oxms; # end of utility regexes: ok to capture. $perl_code =~ # alternation order critical! s{ ($tricky_scalars) # $1 - $" or ${"}, $# or ${#} | " ($d_quoted) " # $2 - double-quoted string body | ' ($s_quoted) ' # $3 - single-quoted string body | ($linend+) # $4 - line ends, blank lines, comments } { defined $1 ? fix_scalars($1) : defined $2 ? fix_dquote ($2) : defined $3 ? fix_squote ($3) : defined $4 ? fix_linend ($4) : die 'quote matter undefined' # DEFAULT (needed?) ; }oxmsge; return $perl_code; # return with fixes } # end sub fix_quoted_matter() # simply pass through certain scalars like $" or $# that look # like quoted strings or comments. sub fix_scalars { my ($body, # body of $" string to fix ) = @_; return $body; } sub fix_dquote { my ($body, # body of a "-quoted string to fix ) = @_; # reproduce embedded newlines in "-quoted string. # embedded newlines replaced with '\n' escape sequence # which will interpolate a newline in final "-quoted string. # note that when quoted body is taken from the windows # clipboard, a newline is a classic dos \r\n pair. # regex compiled with //o switch. $body =~ s{ \r? \n } '\n'xmsog; # would like to convert "-quoted strings to qq{} to # reduce \" noise, but this seems to screw up perl's # interpretation of escaped double-quotes for $" or ${"} # in the original double-quoted strings, # e.g. " $\" " or " ${\"} ", which print properly as # such when fully transformed for pasting to the command # line, but qq{ $\" } or qq{ ${\"} } do not. # return "qq{$body}"; return qq{"$body"}; } sub fix_squote { my ($body, # body of a '-quoted string to fix ) = @_; # embedded newlines in '-quoted strings cannot be exactly # reproduced because a raw newline in a string fed to the # command-line interpreter terminates the command, and there's # nothing like "\n" that can be interpolated into a # single-quoted (non-interpolating) string to generate a # newline in the perl-interpreted code. # just flag them with '<nl>. # regex compiled with //o switch. $body =~ s{ \r? \n } '<nl>'xmsog; # can't convert '-quoted strings to q{} just to # match " conversion because that screws up \' single- # quote escaping in original '-quoted string. return "'$body'"; } sub fix_linend { my ($block, # one or more line ends, empty lines (w/comments) ) = @_; # replace line end(s) with a unique string to mark # an original line break or breaks for later fixup. return "\n"; # a single newline is unique enough for now } # escape remaining " characters to avoid interpretation by # windows c.l. interpreter. # these " chars may already be escaped with one or more '\' chars. # the 'rule' seems to be that the number of existing '\' chars # be doubled, and that an additional '\' is added before the '"'. sub escape_dquotes { my ($perl_code, # perl code string ) = @_; # regex compiled with //o switch. $perl_code =~ s{ (\\*) (") } { $1 x 2 . qq{\\$2} }xmsoge; return $perl_code; } # handle special < | > ^ & windows shell metacharacters, # redirection commands and escape for the windows command # line interpreter. # the 'rule' (?) seems to be that special characters are escaped # (with a '^' char) if they are preceded in the string by # an ODD number of '\"' char pairs! (note that these pairs # may be part of a sequence with any number of backslashes # preceding; no matter: just the number of '\"' count.) sub escape_shell_specials { my ($perl_code, # perl code string ) = @_; # all regexes compiled with //o switch. my $special = qr{ [<|>^&] }xmso; # added & 13jun12waw my $bsl_qq = qr{ \\" }xmso; my $not_bsl_qq = qr{ (?! $bsl_qq) . }xmso; my $bsl_qq_or_eos = qr{ $bsl_qq | \z }xmso; $perl_code =~ s{ ($bsl_qq $not_bsl_qq* $bsl_qq_or_eos) } { local $_ = $1; s{ ($special) }{^$1}xmsog; $_ }xmsoge; return $perl_code; } # remove remaining newlines in input code, pad lines to console width. sub fix_linebreaks { my ($perl_code, # perl code string ) = @_; # all regexes compiled with //o switch. # linebreak/not_linebreak regexes could be expressed as char # set and its complement, but this allows easy expansion to # multi-char string for line-break marker if needed. my $linebreak = qr{ \n }xmso; my $not_linebreak = qr{ (?! $linebreak) . }xmso; # $linebreak + quantifier below probably redundant, seems benign. $perl_code =~ s{ \G ($not_linebreak*) $linebreak+ } { pad_con_cols($1) }xmsoge; return $perl_code; } # more fix-ups for more special characters significant to the # Win32::GuiTest::SendKeys() function. sub fix_for_sendkeys { my ($command_line, # escape special characters ) = @_; $command_line =~ s< ([~+^%(){]) > {{$1}}oxmsg; # compiled with //o switch return $command_line; } # suppress perl default switches specified in default c.l. switches. sub suppressed { my (%switches) = @_; # process all !abc switches. my @kill_switches = map m{ (?: \G (?<! \A) | (?<= \A !)) \w }xmsg, PERL_SWITCHES ; delete @switches{ @kill_switches }; return %switches; } # process c.l. switches passed from batch file invocation. sub cl_invocation { my %live = suppressed(DEFAULTS); # everything not in !abc switch # none, either or both of w s may still exist. # (assigning scalar to array assigns to element 0 of array.) my @strictures = join '', grep defined, @live{ qw(w s) }; @strictures = $strictures[0] ? qq{-$strictures[0]} : (); # string evocation switch -e or -E. e or E will always exist. $live{e} = 'E' if BIG_E; # -E explicitly called for $live{e} ||= 'E'; # -E if -e suppressed or not already -E my $eE = join '', '-', grep defined, @live{ qw(l e) }; # all other arguments that are not !whatever my @other_args = grep m{ \A [^!] }xms, PERL_SWITCHES; # put 'em all together. return join q{ }, 'perl', @strictures, @other_args, $eE; } sub pad_con_cols { my ($string, # string to be padded to console width $prompt_width, # optional: original c.l. prompt adjustment ) = @_; $prompt_width ||= 0; # optional default # first, figure number of console lines needed by string; my $fieldwidth = 1 + int (length($string) / CONSOLE_WIDTH); # then, convert to number of characters; $fieldwidth *= CONSOLE_WIDTH; # number of chars # then, if called for, adjust for prompt width. $fieldwidth -= $prompt_width; # adjust for prompt width, if any return sprintf '%-*s', $fieldwidth, $string; } __END__ successful backslash interpolation experiments: backslashed " in "" string C:\@Work\Perl\clipboard>perl -wMstrict -e "print \" \\\" \"" " C:\@Work\Perl\clipboard>perl -wMstrict -e "print \" \\\\\\\" \"" \" C:\@Work\Perl\clipboard>perl -wMstrict -e "print \" \\\\\\\\\\\" \"" \\" C:\@Work\Perl\clipboard>perl -wMstrict -e "print \" \\\\\\\\\\\\\\\" \ +"" \\\" C:\@Work\Perl\clipboard>perl -wMstrict -e "print \" \\\\\\\\\\\\\\\\\\ +\" \"" \\\\" C:\@Work\Perl\clipboard>perl -wMstrict -e "print \" \\\\\\\\\\\\\\\\\\ +\\\\\" \"" \\\\\" backslashed " in "" string: input output string string 3 0 7 1 11 2 15 3 19 4 23 5 ------------------------------------------------------- backslashed " in q{} string input output string string 1 0 3 1 5 1 7 2 9 2 11 3 13 3 15 4 17 4 C:\@Work\Perl\clipboard>perl -wMstrict -e "print q{ \" }" " C:\@Work\Perl\clipboard>perl -wMstrict -e "print q{ \\\" }" \" C:\@Work\Perl\clipboard>perl -wMstrict -e "print q{ \\\\\" }" \" C:\@Work\Perl\clipboard>perl -wMstrict -e "print q{ \\\\\\\" }" \\" C:\@Work\Perl\clipboard>perl -wMstrict -e "print q{ \\\\\\\\\" }" \\" C:\@Work\Perl\clipboard>perl -wMstrict -e "print q{ \\\\\\\\\\\" }" \\\" C:\@Work\Perl\clipboard>perl -wMstrict -e "print q{ \\\\\\\\\\\\\" }" \\\" C:\@Work\Perl\clipboard>perl -wMstrict -e "print q{ \\\\\\\\\\\\\\\" } +" \\\\" backslash interpolation experiments: C:\@Work\Perl\clipboard>perl -wMstrict -e "print \" \\\" \"" " C:\@Work\Perl\clipboard>perl -wMstrict -e "print \" \\\\" \"" Can't find string terminator '"' anywhere before EOF at -e line 1. C:\@Work\Perl\clipboard>perl -wMstrict -e "print \" \\\\\" \"" String found where operator expected at -e line 1, at end of line (Missing semicolon on previous line?) Can't find string terminator '"' anywhere before EOF at -e line 1. C:\@Work\Perl\clipboard>perl -wMstrict -e "print \" \\\\\\" \"" Can't find string terminator '"' anywhere before EOF at -e line 1. C:\@Work\Perl\clipboard>perl -wMstrict -e "print \" \\\\\\\" \"" \" C:\@Work\Perl\clipboard>perl -wMstrict -e "print \" \\\\\\\\" \"" Can't find string terminator '"' anywhere before EOF at -e line 1. C:\@Work\Perl\clipboard>perl -wMstrict -e "print \" \\\\\\\\\" \"" String found where operator expected at -e line 1, at end of line (Missing semicolon on previous line?) Can't find string terminator '"' anywhere before EOF at -e line 1. C:\@Work\Perl\clipboard>perl -wMstrict -e "print \" \\\\\\\\\\" \"" Can't find string terminator '"' anywhere before EOF at -e line 1. C:\@Work\Perl\clipboard>perl -wMstrict -e "print \" \\\\\\\\\\\" \"" \\" C:\@Work\Perl\clipboard>perl -wMstrict -e "print \" \\\\\\\\\\\\" \"" Can't find string terminator '"' anywhere before EOF at -e line 1. C:\@Work\Perl\clipboard>perl -wMstrict -e "print \" \\\\\\\\\\\\\" \"" String found where operator expected at -e line 1, at end of line (Missing semicolon on previous line?) Can't find string terminator '"' anywhere before EOF at -e line 1. C:\@Work\Perl\clipboard>perl -wMstrict -e "print \" \\\\\\\\\\\\\\" \" +" Can't find string terminator '"' anywhere before EOF at -e line 1. C:\@Work\Perl\clipboard>perl -wMstrict -e "print \" \\\\\\\\\\\\\\\" \ +"" \\\"
[download]

ddd.bat

this batch file invokes the perl clipboard source one-liner fixup script and identifies the dos command window into which the fixed source will be posted. hitting Enter after the fixed source is posted back will execute perl on the one-liner. the version of perl under which the pasted one-liner runs is determined by the dos window from which the batch file is invoked. i have a different dos command windows available for each of the versions of perl i have. each of these dos windows is set up so that the directory of this batch file is in its PATH environment variable.

@ECHO OFF rem 04oct09 rem DEVELOPMENT version of batch file caller. rem calls paste_to_cbddd.pl rem strawberry 5.14 - compile with maximum version available c:\strawberry\5.14\perl\bin\perl C:\@Work\Perl\clipboard\paste_to_cb%~ +n0.pl %0 %* rem activestate 5.8 - compile with minimum version available rem c:\Perl\bin\perl5.8.9 C:\@Work\Perl\clipboard\paste_to_cb%~n0.pl +%0 %* if NOT ERRORLEVEL 1 goto CLEANUP echo embedded perl script exit error %ERRORLEVEL% :CLEANUP goto END :END
[download]

perlmonks_quoting_discussion.pl

this file has some info on the arcane, if not to say byzantine (if not to say insane), windows shell quote/escape rules. ss64.com also has a lot of good info on this. there is some test code at the end for testing some ideas. (there's also some code at the end of paste_to_cbddd.pl that i used to try to figure out backslash interpolation rules.) i only include it here because it may be of some passing interest. the other two files are the application.

=comment Windows quoting by rovf (Monk)on Jul 21, 2008 at 13:18 UTC (#699036=perlquestion) My application generates at run time a Windows BAT file (oh you wonderful Windows Batch language - if I only knew which insane person had invented it!), which then in turn calls other programs (some compiled C application, some Perl programs). I need to pass strings from my Perl application via the Batch file to these programs (using the environment is no option here). For example: my $some_argument='abc'; # ... $batchfile=IO::File->new(">x.bat"); print $batchfile "\@echo off\nMyProg $some_argument\n"; $batchfile->close; # ... later, in a different process ... : system("x.bat"); # executes MyProg abc That's the basic idea. Of course it is not so easy, because I don't know the content of $some_argument until at run-time, and this means I have to generate the argument in a way which is properly quoted according to Batch Language Syntax Rules. I researched a bit how to do proper quoting in Windows batch files, and though a found a bit of information here and a bit of information there, I could not find a concise document which really describes it properly. So my first question is: Does someone happen to know a CPAN module which implements Windows Batch Language quoting? Otherwise, does someone know the rules, so that I can implement it myself? So far, I found the following set of rules: - The special characters <>|^ must be escaped by ^ (for example, we have to convert 'a^b|c' into 'a^^b^|c') - A double quote at the beginning or at the end of the argument must be escaped by \ (for example, we have to convert '"ab"' to '\\"ab"\\') - If the argument contains spaces, it must be enclosed by double quotes, and in practice, it does not hurt to enclose the argument in double quotes always (for example, we have to convert 'a b' to '"a b"') - A double quote, which is followed by a space, must get a backslash in front (for example, we have to convert 'a" b' to 'a\" b') - If the argument starts with \", we are out of luck (at least I have not found yet a way how to encode the string '\\"foo' properly for my batchfile [but see response below] Is this list complete or do I miss something? -- Ronald Fischer <ynnor@mm.st> =cut =comment Re: Windows quoting by InfiniteSilence (Chaplain) on Jul 21, 2008 at 13:42 UTC Are these batch files going to be reused in the future? If not, perhaps it would be best to do away with this mode of operation altogether and switch to using Win32::Process or something. Celebrate Intellectual Diversity Re^2: Windows quoting by rovf (Monk) on Jul 21, 2008 at 13:56 UTC perhaps it would be best to do away with this mode of operation altogether and switch to using Win32::Process The batch files are sent to a remote machine and executed there independently, at some unspecified later time. The remote execution mechanism *expects* Windows batch files. Basically, the only assumption we have on the remote machine is that it is a standard Windows system which can execute batch files. -- Ronald Fischer <ynnor@mm.st> Re: Windows quoting by pc88mxer (Vicar) on Jul 21, 2008 at 14:19 UTC Instead of trying to quote $some_argument, can you pass it as an argument? system("x.bat", $some_argument); and then reference it in your batch script as %1 (or however batch scripts do this.) Re^2: Windows quoting by rovf (Monk) on Jul 22, 2008 at 08:19 UTC Instead of trying to quote $some_argument, can you pass it as an argument? No, because I do not call the batch file. A different process on a different machine calls the batch file, and it expects only a batch file, which will be invoked without parameters. -- Ronald Fischer <ynnor@mm.st> Re: Windows quoting by BrowserUk (Sage) on Jul 21, 2008 at 14:46 UTC If the argument starts with \", we are out of luck (at least I have not found yet a way how to encode the string '\\"foo' properly for my batchfile Using the following cmd file as the mechanism of demonstration (called echoem.cmd): @echo off perl -wle"print qq['$_'] for @ARGV" %* Does this achieve what you are after? C:\test>echoem "\"foo" "bar \"qux" \\\"foo '"foo' ### $1 'bar "qux' ### $2 '\"foo' ### $3 ----------------------------------------------------------------- Examine what is said, not who speaks -- Silence betokens consent -- Love the truth but pardon error. "Science is about questioning the status quo. Questioning authority". In the absence of evidence, opinion is indistinguishable from prejudice. "Too many [] have been sedated by an oppressive environment of political correctness and risk aversion." [reply] Re^2: Windows quoting by rovf (Monk) on Jul 22, 2008 at 08:31 UTC \\\"foo Indeed it does! Thanks a lot! -- Ronald Fischer <ynnor@mm.st> =cut =comment from playing around with various combinations, rules for escaping "-quoted c.l. parameters seem to be: all embedded "-quotes escaped with '\' all embedded '\' that precede non-" must be escaped with a '\' and <|> escaped with a '^' if odd number of \" precede it in line any '^' that is not inserted as an escape is escaped with a '^' 08aug08waw =cut use warnings; use strict; my $backslash_escapable = do { # unescaped " my $raw_qq = qr{ (?<! \\) " }xms; # embedded backslash my $embedded_bsl = qr{ \\ }xms; # sequences escapable with a \ # CAUTION: alternation order critical qr{ $embedded_bsl | $raw_qq }xms; }; our $preceding_embedded_qqs = 0; ### # escape sequences for escapable characters or char sequences. ### my %escape = reverse qw( ^ < ^ | ^ > ^ ^ ); ### # null esc. seq. for existing \" so they are just counted ### $escape{\"} = ''; my ($hat_escapable) = do { ### # any " not after a \ ### my $not_after_bsl = qr{ (?<! \\) }xms; ### my $embedded_qq = qr{ $not_after_bsl " }xms; ### # any \ not before a " ### my $not_before_qq = qr{ (?! ") }xms; ### my $embedded_bsl = qr{ \\ $not_before_qq }xms; # just count any existing embedded \" my $existing_embedded_bslqq = qr{ \\" (?{ ++$preceding_embedded_qqs }) }xms; # any special character if odd number of \" precede in string my $special = qr{ [<|>] }xms; use re 'eval'; my $escapable_special = # qr{ (?(?{ $preceding_embedded_qqs % 2 }) (?= $special)) . }x +ms; qr{ $special (?{ ++$preceding_embedded_qqs }) }xms; no re 'eval'; # any hat character my $hat = qr{ ^ }xms; # return regex for escapable characters or char sequences qr{ $embedded_bsl | $embedded_qq | $escapable_special | $hat }xms; }; my $param = 'print "a \" b < > \" < >"' # shift or die "no c.l. param" ; $param =~ s{ ($unescaped_embedded_qq) }{\\$1}xmsg; $param =~ s{ ($escapable) } { print qq(-$1- \n); $preceding_embedded_qqs++ if $1 eq q{"}; $escape{$1} }xmsge; # { $preceding_embedded_qqs++ if $1 eq q{"}; $escape{$1} }xmsge; print "~$param~";
[download]

copyright and final thoughts.

well, if i thought there was something here of value (and that i hadn't already stolen, or shall we say 'adapted', from someone else), i'd copyright the heck out of everything, but i don't, so i won't. please feel free to use whatever you may find valuable, although an attribution would be nice if it looks like it might be something original to me.

enjoy.



Hi Athanasius. The line continuations are a trick. I wrote me an app that copies multiple lines from a clipboard editor to a dos command window and, among other things, space-pads each line to the width of the c.w.

Original idea was to quickly cut-and-paste code from, e.g., a PM posting to dos c.w. and run it and see results. As it stands now, I can also quickly run the same code under a few different Perl versions.

Performance is ok as far as it goes, but I see some shortcomings. I cannot handle: DATA handle and its __DATA__ section as if in a file; multi-line quoted strings; embedded comments; etc.

My current inclination is to scrap and start over with a file-based approach. Probably the easiest route would be to just use a common commercial or freeware Perl IDE, but where's the fun in that?

I can look over the code as it stands now and, if it's not too embarrassing, clean it up a bit and post it in my public scratchpad for your delectation.

Please let me know if you have any interest in this. If so, give me a few days to paper over the naughty bits, maybe add some much-needed comments, and post. Please feel free to bug me on this since i tend to be a bit lazy about these things.
br -- bill... er, AnomalousMonk 04sep12



... the  $state variable is re-defined as 0 after the first calls to  persist() ...

I think this statement and the first code example are misleading. The idea conveyed seems to be that  $state was defined as 0 before the block was entered (i.e., before the first call to persist()); its silent promotion to 0 seems to be a side-effect of the post-increment. In fact,  $state was undefined. IMO, the code below gives a clearer example of this (note execution with warnings and strictures, also, IMO, a good practice for all example code):

>perl -wMstrict -le "persist(); ;; { my $store = 0; ;; sub persist { print $store; ++$store; } } ;; persist(); persist(); " Use of uninitialized value $store in print at -e line 1. 0 1
[download]

ikegami has commented at length on some of the differences between  BEGIN and  INIT and on some of the gotchas attending use of the latter, but I haven't Super Searched for these – maybe you might?.



SelTran.pm

# SelTran.pm selective translation 31jan10waw # based on reply to PerlMonks node #820537 (perlquestion): =comment Greetings to all, I asked in the chat window several days ago about how to accomplish this, and tye provided me a good answer using map and sort. Unfortunately, my laptop crashed shortly thereafter, and I lost his answer. (That'll teach me, ha!) However, there are a couple of complicating factors that tye may not have addressed even then, and I'm looking for wisdom on a succinct and safe way of accomplishing this. Here's what I have: A file containing a tab-delimited list of words to exchange for modern spellings/equivalents, followed by a third column for any stopwords which should not have substitutions done in them. A file containing a list of files in which substitutions must be made. Over a hundred such files needing to be updated. The target language is Asian, where 1) there are no spaces between words; and 2) the encoding will be UTF-8. (This is significant, because any regexp must be sensitive to this, or it will fail.) Here's an "English-ised" example of the words list file: WORD REPLACEMENT STOPWORDS score twenty fourscore,scored,scores core center encore,coregent centre center travelled traveled hasn't has not Johann John Johannesburg So, what I need to do is substitute each word in the first column for the word(s) in the second column, except where the word in the stopwords column is matched. While this seems like a simple scenario, I'm struggling to wrap my brain around it. I'm just beginning to grasp the concepts of map and join, and their syntax, but would much appreciate some ideas for how to accomplish this. Blessings, ~Polyglot~ =cut package SelTran; { # private package scope use warnings FATAL => 'all' ; use strict; use Exporter; our $VERSION = '0.1.0'; our @EXPORT = qw(); # syntactic sugar per mjd. sub Iterator (&) { return $_[0]; } # example translation table: # my @translate = ( # # insert... for... except in... # [ 'TWENTY', 'score', qw(twoscore unscored? score[srd]) ], # [ 'CENTER', 'core', qw(encore[sd]? score[sd]? core[rd]) ], # [ 'CENTERS', 'cores', qw(encores scores) ], # [ 'JOHN', 'Johann', qw(Johannesburg) ], # [ 'CENTER', 'centre', ], # [ 'TRAVELED', 'travelled', ], # [ 'HAS NOT', 'hasn\'t', ], # ); sub iter { my $class = shift; my ($ar_trans_def, # ref. to array: trans. definition table ) = @_; my %replace = map @{ $_ }[1, 0], @$ar_trans_def; my $search = join ' | ', map word_regex(@{ $_ }[1 .. $#{$_}]), sort { $b->[1] cmp $a->[1] } # longest words first @$ar_trans_def ; return Iterator { (my $xlt = $_[0]) =~ s{ ($search) }{$replace{$1}}xmsg; return $xlt; } } sub word_regex { my ($word, @stops, ) = @_; my $not_stopped = join ' ', map not_stopped(@$_), map [ m{ \A (.*) ($word) (.*) \z }xms ], @stops ; return "$not_stopped $word"; } sub not_stopped { my ($stop_prefix, # always defined if word defined, maybe empty $word, # word embedded in stop word $stop_suffix, # always defined if word defined, maybe empty ) = @_; return '' unless defined $word and length $word; # need len test? # convert word to placeholder (faster match?) $word = sprintf '.{%d}', length $word; # convert stop prefix, if any, to POSITIVE assertion. $stop_prefix = "(?<= $stop_prefix)" if length $stop_prefix; # NEGATIVE assert of stop prefix, word placeholder, stop suffix. return "(?! $stop_prefix $word $stop_suffix)"; } } # end SelTran private scope 1;
[download]

SelTran.t

# SelTran.t test selective translation 31jan10waw use warnings FATAL => 'all' ; use strict; use Test::More # tests => ?? 'no_plan' ; BEGIN { use_ok('SelTran'); } my @translate = ( # insert... for... except in... [ 'TWENTY', 'score', qw(twoscore unscored? score[srd]) ], [ 'CENTER', 'core', qw(encore[sd]? score[sd]? core[rd]) ], [ 'CENTERS', 'cores', qw(encores scores) ], [ 'JOHN', 'Johann', qw(Johannesburg) ], [ 'CENTER', 'centre', ], [ 'TRAVELED', 'travelled', ], [ 'HAS NOT', 'hasn\'t', ], ); my $xlate = SelTran->iter(\@translate) or die "failed"; note "single-word translations ----------------------"; for my $ar_vector ( [ 'core', 'CENTER' ], [ 'cores', 'CENTERS' ], [ 'hasn\'t', 'HAS NOT' ], [ 'Johann', 'JOHN' ], ) { my ($from, $to) = @$ar_vector; is $xlate->($from), $to; } note "multi-word translations with some exclusions -------------"; for my $ar_vector ( [ 'core encore encores encored scores scored corer cored', 'CENTER encore encores encored scores scored corer cored' ], [ 'core cores xcore corex xcorex core', 'CENTER CENTERS xCENTER CENTERx xCENTERx CENTER' ], [ 'cores core encores scores', 'CENTERS CENTER encores scores' ], [ 'cores xcores coresx xcoresx cores', 'CENTERS xCENTERS CENTERSx xCENTERSx CENTERS' ], ) { my ($from, $to) = @$ar_vector; is $xlate->($from), $to; }
[download]