Executable wrapper around Perl script on Windows

Question

I have ack (the searching tool) "installed" as a single file at C:\ack\bin\ack.pl on a Windows 10 machine and was wondering how to make it executable from the powershell window and other terminals.

I wanted to do it ideally without touching the PATHEXT variable and associating an interpreter to the extension because that has system-wide consequences. I'm only really after a shebang workalike.

First I wrote a batch script wrapper around it (ack.bat).

@echo off
perl.exe %~dp0\ack.pl %*

But that has the annoying property of handling interruptions via ^C with an are you sure? prompt.

Terminate batch job (Y/N)? y

I was curious how to make something interruptible without prompting and tried looking for an equivalent of the exec* system calls on Windows. Then I came across this answer on ServerFault which complains about the same problem and suggests generating a C program as a potential solution.

I wrote a C++ wrapper that does the trick, but it turned out quite a bit uglier than I would have liked.

---

// The strings in this file are UTF-16LE for compat with the win32 api
// The source code itself is in UTF-8.
#include <windows.h> // GetCommandLineW
#include <iostream> // wcout
#include <string> // wstring
#include <cassert> // assert
#include <utility> // pair
#include <deque> // deque, size_type
// always debug. Assert is only used when we actually want to
// crash the wrapper process.
#undef NDEBUG
// unsigned index type, probably good enough for traversing
// a vector or deque
typedef std::deque<char>::size_type uidx;
// interpreter_name must be absolute path
std::wstring interpreter_name = %%%%INTERPETER_NAME%%%% ;
std::wstring script_name = %%%%SCRIPT_NAME%%%% ;
class Reaper {
public:
 HANDLE job_handle;
 JOBOBJECT_EXTENDED_LIMIT_INFORMATION limit_info;
 Reaper() {
 job_handle = CreateJobObject(NULL, NULL);
 assert(job_handle != NULL);
 limit_info = { 0 };
 limit_info.BasicLimitInformation.LimitFlags = JOB_OBJECT_LIMIT_KILL_ON_JOB_CLOSE;
 DWORD set_success = SetInformationJobObject(
 job_handle,
 JobObjectExtendedLimitInformation,
 &limit_info,
 sizeof(limit_info));
 assert(set_success);
 }
};
Reaper& get_reaper(void) {
 static Reaper r;
 return r;
}
// the leading int is the error code.
std::pair<DWORD, std::deque<std::wstring>> argvw_of_cmdline(std::wstring command_line) {
 LPCWSTR cmd_line = command_line.c_str();
 int count = 0;
 LPWSTR *the_processed_args = CommandLineToArgvW(
 cmd_line, &count
 );
 // first we handle the error case
 if (the_processed_args == nullptr) {
 return {GetLastError(), std::deque<std::wstring>()};
 } else {
 std::deque<std::wstring> s;
 for (int i = 0; i < count; ++i) {
 s.push_back(the_processed_args[i]);
 }
 return {0, s};
 }
}
std::wstring escape_string(std::wstring ws) {
 bool contains_suspect_char = (std::wstring::npos != ws.find_first_of(L"\"" L"\\"));
 if (contains_suspect_char) {
 std::wstring out(L"\"");
 for (uidx i = 0; i < ws.size(); ++i) {
 if (ws[i] == L'"' || ws[i] == L'\\') {
 out += L'\\';
 out += ws[i];
 } else {
 out += ws[i];
 }
 }
 out += L'"';
 return out;
 } else {
 return ws;
 }
}
std::wstring cmdline_of_argvw(const std::deque<std::wstring> &argvw) {
 std::wstring the_line(L"");
 // this is okay even if the deque is empty
 // because the loop will be traversed zero times.
 uidx last_index = argvw.size() - 1;
 for (uidx i = 0; i < argvw.size() ; i++) {
 the_line += escape_string(argvw[i]);
 if (i != last_index) {
 the_line += L' ';
 }
 }
 return the_line;
}
struct RawWinProcessCreatorW {
 LPCWSTR app_name = NULL;
 LPWSTR command_line = NULL;
 LPSECURITY_ATTRIBUTES process_attributes = NULL;
 LPSECURITY_ATTRIBUTES thread_attributes = NULL;
 BOOL inherit_handles = false;
 DWORD creation_flags = 0;
 LPVOID environment = NULL;
 LPCWSTR current_directory = NULL;
 LPSTARTUPINFOW startup_info = NULL;
 LPPROCESS_INFORMATION process_information = NULL;
 bool run() {
 return CreateProcessW(
 app_name,
 command_line,
 process_attributes,
 thread_attributes,
 inherit_handles,
 creation_flags,
 environment,
 current_directory,
 startup_info,
 process_information
 );
 }
};
std::wstring current_exe_directory(void) {
 HMODULE h_module = GetModuleHandleW(nullptr);
 WCHAR path[MAX_PATH];
 memset(path, 0, sizeof(path)); 
 GetModuleFileNameW(h_module, path, MAX_PATH);
 std::wstring w_path(path);
 // if the last character is a path separator
 // remove it.
 if (w_path.back() == L'\\') {
 w_path.pop_back();
 }
 // keep popping until the last character is a \ -- thwart line continuation
 while (!w_path.empty()) {
 if (w_path.back() == L'\\') {
 w_path.pop_back();
 return w_path;
 } else {
 w_path.pop_back();
 }
 }
 return w_path;
}
int main(int argc, char **argv)
{
 std::wstring exe_dir(current_exe_directory());
 std::wstring fullpath;
 fullpath += exe_dir;
 fullpath += std::wstring(L"\\");
 fullpath += script_name;
 std::wstring old_command_line(GetCommandLineW());
 std::pair<DWORD, std::deque<std::wstring>> p = argvw_of_cmdline(old_command_line);
 DWORD err = p.first;
 assert(err == 0);
 std::deque<std::wstring> split_cl = p.second;
 // remove old executable (it's the current one)
 split_cl.pop_front();
 // need to push interpreter_name and script_name.
 // but the order is reversed.
 split_cl.push_front(fullpath);
 split_cl.push_front(interpreter_name);
 std::wstring command_line = cmdline_of_argvw(split_cl);
 // make sure to zero-initialize these things.
 STARTUPINFOW si = { 0 };
 PROCESS_INFORMATION pi = { 0 };
 RawWinProcessCreatorW r;
 r.app_name = (interpreter_name.c_str());
 r.command_line = const_cast<LPWSTR>(command_line.c_str());
 r.inherit_handles = true;
 r.startup_info = &si;
 r.process_information = &pi;
 r.creation_flags |= CREATE_SUSPENDED;
 bool success = r.run();
 assert(success);
 // DWORD last_error = GetLastError();
 // assign to the job object whatever.
 DWORD assign_status = AssignProcessToJobObject(
 get_reaper().job_handle,
 pi.hProcess
 );
 assert(assign_status);
 // resume the process.
 DWORD resume_status = ResumeThread(pi.hThread);
 // wait for the process we spawned.
 DWORD wait_res = WaitForSingleObject(pi.hProcess, INFINITE);
 assert(wait_res != WAIT_ABANDONED);
 assert(wait_res != WAIT_TIMEOUT);
 assert(wait_res != WAIT_FAILED);
 // after the process is gone, try to figure out whether it succeeded
 // and use that information when deciding how to exit yourself.
 // we're using 10, bad environment, as a sentinel.
 DWORD child_exit_status = 10;
 bool recover_exit_status_success = GetExitCodeProcess(
 pi.hProcess,
 &child_exit_status
 );
 assert(recover_exit_status_success);
 assert(child_exit_status != 10);
 return child_exit_status;
}

---

And here's a Perl script make_wrapper.pl that generates and compiles a wrapper script.

The template is concatenated underneath the end of the __DATA__ token with %%%%INTERPETER_NAME%%%% appearing where the interpreter name is and %%%SCRIPT_NAME%%%% appearing where the script name is.

#! /usr/bin/env perl
use strict;
use warnings;
use utf8;
use Getopt::Long;
use File::Spec;
my $interpreter;
my $script;
my $cxx_compiler;
my $output;
GetOptions(
 "int|i=s" => \$interpreter,
 "script|s=s" => \$script,
 "cxx|c=s" => \$cxx_compiler,
 "output|o=s" => \$output,
);
sub escape_wide_string_literal {
 my ($contents) = @_;
 my $out = q[];
 $out .= 'L"';
 $out .= ($contents =~ s/([\"\\])/\\1ドル/gr);
 $out .= '"';
 return $out;
}
sub defined_and_nonempty {
 my ($x) = @_;
 return (defined $x) && ($x ne q[]);
}
die "need interpreter (--int|-i)" unless defined_and_nonempty($interpreter);
die "need script (--script|-s)" unless defined_and_nonempty($script);
die "need C++ compiler (--cxx|-c)" unless defined_and_nonempty($cxx_compiler);
die "need output file (--output|-o)" unless defined_and_nonempty($output);
die "interpreter must exist (--int|-i)" unless (-f $interpreter);
die "script must exist (--script|-s)" unless (-f $script);
die "C++ compiler must exist (--cxx|-c)" unless (-f $cxx_compiler);
die "intepreter must be absolute path (--int|-i)" unless (File::Spec->file_name_is_absolute($interpreter));
die "script should be relative path with no separators (.\\ is okay) (--script|-s)" if ($script =~ /\\/ and not $script =~ /\A[.][\\][^\\]*\z/);
my $cxx_template;
do {
 local $/;
 $cxx_template = <DATA>;
};
close(DATA);
die "internal error" unless defined $cxx_template;
my $interpreter_literal = escape_wide_string_literal($interpreter);
$cxx_template =~ s/%%%%INTERPETER_NAME%%%%/$interpreter_literal/g;
my $script_literal = escape_wide_string_literal($script);
$cxx_template =~ s/%%%%SCRIPT_NAME%%%%/$script_literal/g;
open my $fh, '>', "temp.cpp";
print $fh $cxx_template;
close($fh);
system($cxx_compiler, "-o", $output, "temp.cpp");
die "did not create file" unless (-f $output);
__DATA__

Answer 1

C++

Globally, your c++ seems good enought

In argvw_of_cmdline you don't have to wrap your second part in a else since you returns in the if.

You can remove a lot of things in current_exe_directory:

std::wstring current_exe_directory(void) {
 HMODULE h_module = GetModuleHandleW(nullptr);
 WCHAR path[MAX_PATH];
 memset(path, 0, sizeof(path)); 
 GetModuleFileNameW(h_module, path, MAX_PATH);
 std::wstring_view w_path(path);
 return std::wstring{ws.begin(), ws.find_last_not_of(L'\\')};
}

(note: you can improve it, but it's already kinda simplified)

You can simplify your escape_string(...) function:

std::wstring escape_string(std::wstring ws) {
 const auto esc = std::wstring{L"\\\""};
 for (size_t index = 0; (index = ws.find_first_of(esc, index)) != std::wstring::npos; index += 2) {
 ws.insert(index, 1, L'\\');
 }
 return ws;
}

Note that I didn't tested theses codes, but it should work :)

Answer 2

Disclaimer

It isn't clear to me what part you want reviews to focus on. I'm not a C++ on Windows person so I can't say much about that part of things. Your C++ is nicely formatted. The main() function could be broken down more, but it is commented well enough that it wouldn't be a burden to maintain in the current state.

Perl

Perl - even on Windows - is something I can talk about...... and your Perl is in good shape too.

• Absolutely have strict and warning pragmas, all the time, every day, for 99% of Perl, yes yes.
• Good formatting.
• Idiomatic use of die X unless Y. Your die messages are excellent as well.
• Variables are localized! (There's nothing worse than 50k lines of perl and no localization)
• Variables and subroutines are named in ways that are easy to follow. Thanks.
• I like using scalars for filehandles also. I believe this is a Perl Best Practice now.

But - like everything - it could be better:

• It is funny to me that you commented the C++ and not the Perl at all. Part of me takes this as a compliment to Perl's natural readability, but it still seems like you could comment a bit and not distract from the code.
• The primary instance where missing comments slowed me down in reading this was in the variables. Your variables names are fine, but having a comment that uses slightly different words can help avoid ambiguities and confusion.
• The next instance of where a comment would be great is explaining the "hanging" __DATA__ section. This looks really out of place, but your explanation above the code was perfect. Why not paste that into the code above the "hanging" __DATA__ section?

Beyond commentary on comments:

• The way you slurp data in from the DATA filehandle definitely works I would encapsulate it into a sub or use File::Slurp itself. Hiding the implementation would make it slightly easier to follow the code.
• my $out = q[]; isn't idiomatic Perl. I would recommend my $out = ''; which uses two single quotes instead of q[].
• Your defined_and_nonempty is pretty similar to what Perl would give you for scalar($x). Do you care if $x == 0 that it evaluates false? Again the use of q[] feels a bit odd.

Answer 3

#undef NDEBUG needs to be done before the point at which you #include <cassert>.