# 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] fum"


=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 SCRIPT_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() unaccomodated

    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 \" \\\\\\\\\\\\\\\" \""
 \\\"