#!/usr/bin/env perl # Copyright (C) Yichun Zhang (agentzh) # Copyright (C) Guanlan Dai # TODO: port this script into the nginx core for greater flexibility # and better performance. # for maximum startup speed #use strict; #use warnings; sub split_sh_args ($); sub join_sh_args ($); sub resolve_includes ($$); our $VERSION = '0.28'; # OpenResty's build system would patch the following line to initialize # the $nginx_path variable to point to the path of its own nginx binary # directly. my $nginx_path; my $WNOHANG = 1; my $is_win32 = ($^O eq 'MSWin32'); #$is_win32 = 1; my $cwd; my @all_args = @ARGV; my (@http_confs, @stream_confs, @http_includes, @main_confs, @main_includes, @shdicts, @ns, @src_a); my $errlog_level = "warn"; my ($use_gdb, $use_valgrind, $use_rr, $version, $gdb_opts, $user_runner); my ($use_stap, $stap_opts); my ($conns_num, @inc_dirs, $jit_dumper, $valgrind_opts, $resolve_ipv6); my $lua_shared_dicts = ''; my $no_stream; { # Note: we do not use external modules like Getopt::Long because we want # to maximum startup speed. my @args = @ARGV; my $nargs = @args; my $found_opts; while (@args) { my $arg = shift @args; if ($arg =~ /^-/) { $found_opts = 1; if ($arg eq '-I') { my $v = shift @args; if (!defined $v) { die "option -I takes an argument but found none.\n"; } push @inc_dirs, $v; next; } if ($arg =~ /^-I=?(.*)/) { push @inc_dirs, $1; next; } if ($arg eq '-e') { my $v = shift @args; if (!defined $v) { die "option -e takes an argument but found none.\n"; } push @src_a, $v; next; } if ($arg =~ /^-e=?(.*)/) { push @src_a, $1; next; } if ($arg eq '-l') { my $v = shift @args; if (!defined $v) { die "option -l takes an argument but found none.\n"; } my $quoted_lua_lib = quote_as_lua_str($v); my $lua = "require($quoted_lua_lib)"; push @src_a, $lua; next; } if ($arg =~ /^-l=?(.*)/) { my $v = $1; my $quoted_lua_lib = quote_as_lua_str($v); my $lua = "require($quoted_lua_lib)"; push @src_a, $lua; next; } if ($arg eq '-j') { if (defined $jit_dumper) { die "duplicate -j opton found.\n"; } $jit_dumper = shift @args; if (!defined $jit_dumper) { die "option -j takes an argument but found none.\n"; } next; } if ($arg =~ /^-j=?(.*)/) { if (defined $jit_dumper) { die "duplicate -j opton found.\n"; } $jit_dumper = $1; next; } if ($arg eq '-c') { $conns_num = shift @args; if (!defined $conns_num) { die "option -c takes an argument but found none.\n"; } next; } if ($arg =~ /^-c=?(.*)/) { $conns_num = $1; next; } if ($arg eq '--') { @ARGV = @args; last; } if ($arg =~ /^--ns=(.*)/) { push @ns, $1; next; } if ($arg eq '--ns') { my $v = shift @args; if (!defined $v) { die "option --ns takes an argument but ", "found none.\n"; } push @ns, $v; next; } if ($arg =~ /^--shdict=(.*)/) { push @shdicts, $1; next; } if ($arg eq '--shdict') { my $v = shift @args; if (!defined $v) { die "option --shdict takes an argument but ", "found none.\n"; } push @shdicts, $v; next; } if ($arg =~ /^--nginx=(.*)/) { $nginx_path = $1; next; } if ($arg eq '--nginx') { $nginx_path = shift @args; if (!defined $nginx_path) { die "option --nginx takes an argument but ", "found none.\n"; } next; } if ($arg =~ /^--http-conf=(.*)/) { push @http_confs, $1; next; } if ($arg =~ /^--stream-conf=(.*)/) { push @stream_confs, $1; next; } if ($arg =~ /^--main-conf=(.*)/) { push @main_confs, $1; next; } if ($arg eq '--http-conf') { my $v = shift @args; if (!defined $v) { die "option --http-conf takes an argument but ", "found none.\n"; } push @http_confs, $v; next; } if ($arg eq '--stream-conf') { my $v = shift @args; if (!defined $v) { die "option --stream-conf takes an argument but ", "found none.\n"; } push @stream_confs, $v; next; } if ($arg eq '--main-conf') { my $v = shift @args; if (!defined $v) { die "option --main-conf takes an argument but ", "found none.\n"; } push @main_confs, $v; next; } if ($arg =~ /^--http-include=(.*)/) { push @http_includes, $1; next; } if ($arg eq '--http-include') { my $v = shift @args; if (!defined $v) { die "option --http-include takes an argument but ", "found none.\n"; } push @http_includes, $v; next; } if ($arg =~ /^--main-include=(.*)/) { push @main_includes, $1; next; } if ($arg eq '--main-include') { my $v = shift @args; if (!defined $v) { die "option --main-include takes an argument but ", "found none.\n"; } push @main_includes, $v; next; } if ($arg =~ /^--valgrind-opts=(.*)/) { if (defined $valgrind_opts) { die "ERROR: duplicate --valgrind-opts options\n"; } $valgrind_opts = $1; $use_valgrind = 1; next; } if ($arg eq '--valgrind-opts') { if (defined $valgrind_opts) { die "ERROR: duplicate --valgrind-opts options\n"; } $valgrind_opts = shift @args; if (!defined $valgrind_opts) { die "option --valgrind-opts takes an argument but ", "found none.\n"; } $use_valgrind = 1; next; } if ($arg =~ /^--errlog-level=(.*)/) { $errlog_level = $1; next; } if ($arg eq '--errlog-level') { $errlog_level = shift @args; if (!defined $errlog_level) { die "option --errlog-level takes an argument but ", "found none.\n"; } next; } if ($arg eq '--resolve-ipv6') { $resolve_ipv6 = 1; next; } if ($arg =~ /^--user-runner=(.*)/) { if (defined $user_runner) { die "ERROR: duplicate --odb options\n"; } $user_runner = $1; next; } if ($arg eq '--user-runner') { if (defined $user_runner) { die "ERROR: duplicate --user-runner options\n"; } $user_runner = shift @args; if (!defined $user_runner) { die "option --user-runner takes an argument but ", "found none.\n"; } next; } if ($arg eq '--stap') { $use_stap = 1; next; } if ($arg =~ /^--stap-opts=(.*)/) { if (defined $stap_opts) { die "ERROR: duplicate --stap-opts options\n"; } $stap_opts = $1; $use_stap = 1; next; } if ($arg eq '--stap-opts') { if (defined $stap_opts) { die "ERROR: duplicate --stap-opts options\n"; } $stap_opts = shift @args; if (!defined $stap_opts) { die "option --stap-opts takes an argument but ", "found none.\n"; } $use_stap = 1; next; } if ($arg eq '--gdb') { $use_gdb = 1; next; } if ($arg =~ /^--gdb-opts=(.*)/) { if (defined $gdb_opts) { die "ERROR: duplicate --gdb-opts options\n"; } $gdb_opts = $1; $use_gdb = 1; next; } if ($arg eq '--gdb-opts') { if (defined $gdb_opts) { die "ERROR: duplicate --gdb-opts options\n"; } $gdb_opts = shift @args; if (!defined $gdb_opts) { die "option --gdb-opts takes an argument but ", "found none.\n"; } $use_gdb = 1; next; } if ($arg eq '--valgrind') { $use_valgrind = 1; next; } if ($arg eq '--no-stream') { $no_stream = 1; next; } if ($arg eq '--rr') { $use_rr = 1; next; } if ($arg =~ /^(?:--help|-h)$/) { usage(0); last; } if ($arg =~ /^-[vV]$/) { $version = 1; next; } warn "ERROR: unknown option $arg\n\n"; usage(1); } else { last if !$found_opts; unshift @args, $arg; last; } } if ($found_opts) { @ARGV = @args; } if (defined $conns_num) { if ($conns_num !~ /^\d+$/) { die "option -c value must be a number but found ", "'$conns_num'.\n"; } } if (defined $errlog_level) { if ($errlog_level !~ /^[a-z]+$/) { die "bad --errlog-level option value: $errlog_level"; } } if (@ns) { for my $v (@ns) { if ($v !~ /^ (?: \d{1,3} (?: \. \d{1,3} ){3} | \[ [0-9a-fA-F:]+ \] ) $/x) { die "ERROR: Invalid --ns option value: $v\n", " (expecting an IP address)\n"; } } } if (@shdicts) { for my $v (@shdicts) { if ($v !~ /^ [_a-zA-Z0-9]+ \s+ \d+ (?i) [km]? $/x) { die "ERROR: invalid --shdict option value: $v\n", " (expecting NAME SIZE)\n"; } $lua_shared_dicts .= "lua_shared_dict $v;\n"; } } } if (defined $jit_dumper) { if ($jit_dumper eq 'v') { unshift @src_a, 'require "jit.v".on()'; } elsif ($jit_dumper eq 'dump') { unshift @src_a, 'require "jit.dump".on()'; } elsif ($jit_dumper eq 'off') { unshift @src_a, 'require "jit".off()'; } else { warn "ERROR: unknown -j option value: $jit_dumper.\n"; usage(1); } } #warn join ";", @src_a; my $src; if (@src_a) { $src = join '; ', @src_a; } if (!$nginx_path) { require FindBin; require Config; die if !%Config::Config; my $ext = $Config::Config{_exe}; if (!$ext) { if ($^O eq 'msys') { $ext = '.exe'; } else { $ext = ''; } } if ($is_win32) { $nginx_path = File::Spec->catfile($FindBin::RealBin, "..", "nginx", "sbin", "nginx$ext"); } else { $nginx_path = "$FindBin::RealBin/../nginx/sbin/nginx$ext"; } if (!-f $nginx_path) { if ($is_win32) { $nginx_path = File::Spec->catfile($FindBin::RealBin, "nginx$ext"); } else { $nginx_path = "$FindBin::RealBin/nginx$ext"; } if (!-f $nginx_path) { $nginx_path = "nginx"; # find in PATH } } } #warn $nginx_path; if ($version) { warn "resty $VERSION\n"; my $cmd = "$nginx_path -V"; exec $cmd or die "Failed to run command \"$cmd\": $!\n"; } my $lua_package_path_config = ''; if (@inc_dirs) { my $package_path = ""; my $package_path2 = ""; my $package_cpath = ""; for my $dir (@inc_dirs) { #if (!-d $dir) { #die "Search directory $dir is not found.\n"; #next; #} if ($is_win32) { $package_path .= File::Spec->catfile($dir, "?.ljbc;"); $package_path .= File::Spec->catfile($dir, "?.lua;"); $package_path2 .= File::Spec->catfile($dir, "?/init.ljbc;"); $package_path2 .= File::Spec->catfile($dir, "?/init.lua;"); $package_cpath .= File::Spec->catfile($dir, "?.so;"); } else { $package_path .= "$dir/?.ljbc;$dir/?.lua;$dir/?/init.ljbc;$dir/?/init.lua;"; $package_cpath .= "$dir/?.so;"; } } $lua_package_path_config = <<_EOC_; lua_package_path "$package_path;"; lua_package_cpath "$package_cpath;"; _EOC_ } my $luafile = shift; if (!defined $src and !defined $luafile) { die qq{Neither Lua input file nor -e "" option specified.\n}; } my $conns = $conns_num || 64; my @nameservers; if (@ns > 0) { unshift @nameservers, @ns; } else { # try to read the nameservers used by the system resolver: if (open my $in, "/etc/resolv.conf") { while (<$in>) { if (/^\s*nameserver\s+(\d+(?:\.\d+){3})(?:\s+|$)/) { unshift @nameservers, $1; if (@nameservers > 10) { last; } } } close $in; } } if (!@nameservers) { # default to Google's open DNS servers unshift @nameservers, "8.8.8.8", "8.8.4.4"; } if (!$resolve_ipv6) { push @nameservers, "ipv6=off"; } #warn "@nameservers\n"; my $prefix_dir; if ($^O eq 'msys') { # to work around a bug in msys perl (at least 5.8.8 msys 64int) $prefix_dir = "resty_cli_temp"; if (-d $prefix_dir) { system("rm -rf $prefix_dir") == 0 or die $!; } mkdir $prefix_dir or die "failed to mkdir $prefix_dir: $!"; } else { if ($is_win32 || !-d '/tmp') { require File::Temp; $prefix_dir = File::Temp::tempdir(CLEANUP => 1); if ($^O eq 'MSWin32') { require Win32; $prefix_dir = Win32::GetLongPathName($prefix_dir); } } else { my $tmpdir = '/tmp/resty_'; my $N = 1000; for (my $i = 0; $i < $N; $i++) { my $name; for (my $j = 0; $j < 10; $j++) { my $code = 65 + int rand 26; if (int rand 2 == 0) { $code += 32; } $name .= chr $code; } my $dir = $tmpdir . $name; next if -d $dir; mkdir $dir or die "Cannot mkdir $dir: $!\n"; $prefix_dir = $dir; last; } if (!defined $prefix_dir) { die "failed to derive a random temp directory name after $N ", "attempts\n"; } } } #warn "prefix dir: $prefix_dir\n"; my $child_pid; END { if (!$is_win32 && defined($child_pid) && defined $prefix_dir) { my $saved_status = $?; system("rm -rf $prefix_dir") == 0 or warn "failed to remove temp directory $prefix_dir: $!"; $? = $saved_status; # restore the exit code } } my $logs_dir; if ($is_win32) { $logs_dir = File::Spec->catfile($prefix_dir, "logs"); } else { $logs_dir = "$prefix_dir/logs"; } mkdir $logs_dir or die "failed to mkdir $logs_dir: $!"; my $conf_dir; if ($is_win32) { $conf_dir = File::Spec->catfile($prefix_dir, "conf"); } else { $conf_dir = "$prefix_dir/conf"; } mkdir $conf_dir or die "failed to mkdir $conf_dir: $!"; my $inline_lua = ''; my $quoted_luafile; if (defined $src) { my $file; if ($is_win32) { $file = File::Spec->catfile($conf_dir, "a.lua"); } else { $file = "$conf_dir/a.lua"; } open my $out, ">$file" or die "Cannot open $file for writing: $!\n"; print $out $src; close $out; my $chunk_name = "=(command line -e)"; $quoted_luafile = quote_as_lua_str($file); $inline_lua = <<"_EOC_"; local fname = $quoted_luafile local f = assert(io.open(fname, "r")) local chunk = f:read("*a") local inline_gen = assert(loadstring(chunk, "$chunk_name")) _EOC_ } my $file_lua = ''; if (defined $luafile) { if (!-e $luafile) { die "Lua input file $luafile not found.\n"; } my $chunk_name = quote_as_lua_str("\@$luafile"); $quoted_luafile = quote_as_lua_str($luafile); $file_lua = <<"_EOC_"; local fname = $quoted_luafile local f = assert(io.open(fname, "r")) local chunk = f:read("*a") local file_gen = assert(loadstring(chunk, $chunk_name)) _EOC_ } my @user_args = @ARGV; my $args = gen_lua_code_for_args(\@user_args, \@all_args); my $loader = <<_EOC_; local gen do $args $inline_lua $file_lua gen = function() if inline_gen then inline_gen() end if file_gen then file_gen() end end end _EOC_ my $env_list = ''; for my $var (sort keys %ENV) { #warn $var; $env_list .= "env $var;\n"; } my $main_include_directives = resolve_includes 'main', \@main_includes; my $http_include_directives = resolve_includes 'http', \@http_includes; my $http_conf_lines = join "", map { " $_\n" } @http_confs; my $stream_conf_lines = join "", map { " $_\n" } @stream_confs; my $main_conf_lines = join "", map { " $_\n" } @main_confs; my $conf_file; if ($is_win32) { $conf_file = File::Spec->catfile($conf_dir, "nginx.conf"); } else { $conf_file = "$conf_dir/nginx.conf"; } open my $out, ">$conf_file" or die "Cannot open $conf_file for writing: $!\n"; print $out <<_EOC_; daemon off; master_process off; worker_processes 1; pid logs/nginx.pid; $env_list error_log stderr $errlog_level; #error_log stderr debug; events { worker_connections $conns; } $main_conf_lines $main_include_directives _EOC_ if (!$no_stream) { print $out <<_EOC_; stream { access_log off; lua_socket_log_errors off; resolver @nameservers; lua_regex_cache_max_entries 40960; $lua_package_path_config $stream_conf_lines } _EOC_ } print $out <<_EOC_; http { access_log off; lua_socket_log_errors off; resolver @nameservers; lua_regex_cache_max_entries 40960; $lua_shared_dicts $lua_package_path_config $http_conf_lines $http_include_directives init_by_lua_block { ngx.config.is_console = true local stdout = io.stdout local ngx_null = ngx.null local maxn = table.maxn local unpack = unpack local concat = table.concat local expand_table function expand_table(src, inplace) local n = maxn(src) local dst = inplace and src or {} for i = 1, n do local arg = src[i] local typ = type(arg) if arg == nil then dst[i] = "nil" elseif typ == "boolean" then if arg then dst[i] = "true" else dst[i] = "false" end elseif arg == ngx_null then dst[i] = "null" elseif typ == "table" then dst[i] = expand_table(arg, false) elseif typ ~= "string" then dst[i] = tostring(arg) else dst[i] = arg end end return concat(dst) end local function output(...) local args = {...} return stdout:write(expand_table(args, true)) end ngx.orig_print = ngx.print ngx.print = output ngx.orig_say = ngx.say ngx.say = function (...) local ok, err = output(...) if ok then return output("\\n") end return ok, err end print = ngx.say ngx.flush = function (...) return stdout:flush() end -- we cannot close stdout here due to a bug in Lua: ngx.eof = function (...) return true end ngx.exit = os.exit } init_worker_by_lua_block { local exit = os.exit local stderr = io.stderr local ffi = require "ffi" local function handle_err(err) if err then err = string.gsub(err, "^init_worker_by_lua:%d+: ", "") stderr:write("ERROR: ", err, "\\n") end return exit(1) end local ok, err = pcall(function () if not ngx.config or not ngx.config.ngx_lua_version or ngx.config.ngx_lua_version < 10009 then error("at least ngx_lua 0.10.9 is required") end local signal_graceful_exit = require("ngx.process").signal_graceful_exit if not signal_graceful_exit then error("lua-resty-core library is too old; " .. "missing the signal_graceful_exit() function " .. "in ngx.process") end $loader -- print("calling timer.at...") local ok, err = ngx.timer.at(0, function () -- io.stderr:write("timer firing") local ok, err = xpcall(gen, function (err) -- level 3: we skip this function and the -- error() call itself in our stacktrace local trace = debug.traceback(err, 3) return handle_err(trace) end) if not ok then return handle_err(err) end if ffi.abi("win") then return exit(0) end signal_graceful_exit() end) if not ok then return handle_err(err) end -- print("timer created") end) if not ok then return handle_err(err) end } } _EOC_ close $out; my @cmd = ($nginx_path, '-p', "$prefix_dir/", '-c', "conf/nginx.conf"); if ($use_gdb) { if ($use_valgrind) { die "ERROR: options --gdb and --valgrind cannot be specified at the ", "same time.\n"; } if ($use_rr) { die "ERROR: options --gdb and --rr cannot be specified at the ", "same time.\n"; } if ($use_stap) { die "ERROR: options --gdb and --stap cannot be specified at the ", "same time.\n"; } #warn "use gdb opts: $gdb_opts"; unshift @cmd, "gdb", defined $gdb_opts ? (split_sh_args $gdb_opts) : (), "--args", } elsif ($use_rr) { if ($use_valgrind) { die "ERROR: options --rr and --valgrind cannot be specified at the ", "same time.\n"; } if ($use_stap) { die "ERROR: options --rr and --stap cannot be specified at the ", "same time.\n"; } unshift @cmd, "rr", "record", } elsif ($use_stap) { if ($use_valgrind) { die "ERROR: options --stap and --valgrind cannot be specified at the ", "same time.\n"; } @cmd = ("stap", defined $stap_opts ? (split_sh_args $stap_opts) : (), '-c', join_sh_args \@cmd); } elsif ($use_valgrind) { my @new = ('valgrind'); if (defined $valgrind_opts) { push @new, split_sh_args $valgrind_opts; } unshift @cmd, @new; } elsif (defined $user_runner) { unshift @cmd, split_sh_args $user_runner; #warn "cmd: @cmd"; } for my $sig (qw/ INT TERM QUIT HUP USR1 USR2 WINCH PIPE /) { $SIG{$sig} = \&forward_signal; } my $pid = fork(); if (!defined $pid) { die "fork() failed: $!\n"; } if ($pid == 0) { # child process #use Data::Dumper; #warn "exec ", Dumper \@cmd; #warn "exec [@cmd]..."; exec(@cmd) or die "ERROR: failed to run command \"@cmd\": $!\n"; } else { $child_pid = $pid; waitpid($child_pid, 0); my $rc = 0; if ($?) { $rc = ($? >> 8); if ($rc == 0) { $rc = $?; } } exit $rc; } sub usage { my $rc = shift; my $msg = <<_EOC_; resty [options] [lua-file [args]] Options: -c NUM Set maximal connection count (default: 64). -e PROG Run the inlined Lua code in "prog". --errlog-level LEVEL Set nginx error_log level. Can be debug, info, notice, warn, error, crit, alert, or emerg. --gdb Use GDB to run the underlying nginx C process. --gdb-opts OPTS Pass extra command-line options to GDB. --help Print this help. --http-conf CONF Specifies nginx.conf snippet inserted into the http {} configuration block (multiple instances are supported). --http-include PATH Include the specified file in the nginx http configuration block (multiple instances are supported). -I DIR Add dir to the search paths for Lua libraries. -j dump Use LuaJIT's jit.dump module to output detailed info of the traces generated by the JIT compiler. -j off Turn off the LuaJIT JIT compiler. -j v Use LuaJIT's jit.v module to output brief info of the traces generated by the JIT compiler. -l LIB Require library "lib". --main-conf CONF Specifies nginx.conf snippet inserted into the nginx main {} configuration block (multiple instances are supported). --main-include PATH Include the specified file in the nginx main configuration block (multiple instances are supported). --nginx Specify the nginx path (this option might be removed in the future). --no-stream Disable the stream {} configuration in auto-generated nginx.conf. --ns IP Specify a custom name server (multiple instances are supported). --resolve-ipv6 Make the nginx resolver lookup both IPv4 and IPv6 addresses. --rr Use Mozilla rr to record the execution of the underlying nginx C process. --shdict 'NAME SIZE' Create the specified lua shared dicts in the http configuration block (multiple instances are supported). --stap Use sysetmtap to run the underlying nginx C process. --stap-opts OPTS Pass extra systemtap command line options. --user-runner CMD Use CMD as user runner for the underlying nginx process. -V Print version numbers and nginx configurations. --valgrind Use valgrind to run nginx. --valgrind-opts OPTS Pass extra options to valgrind. For bug reporting instructions, please see: Copyright (C) Yichun Zhang (agentzh). All rights reserved. _EOC_ if ($rc == 0) { print $msg; exit(0); } warn $msg; exit($rc); } sub get_bracket_level { my %bracket_levels; my $bracket_level = 0; my $max_level = 0; # scan all args and store level of closing brackets for my $arg (@_) { while ($arg =~ /\](=*)\]/g) { my $level = length($1); if ($level > $max_level) { $max_level = $level; } $bracket_levels{$level} = 1; } } # if args contain closing bracket if (%bracket_levels) { # find the shortest form of the long brackets accordingly for (my $i = 1; $i < $max_level; $i++) { if (!exists $bracket_levels{$i}) { $bracket_level = $i; last; } } if ($bracket_level == 0) { $bracket_level = $max_level + 1; } return $bracket_level; } return 1; } sub quote_as_lua_str { my ($str) = @_; my $bracket_level = get_bracket_level($str); my $left_bracket = "[" . "=" x $bracket_level . "["; my $right_bracket = "]" . "=" x $bracket_level . "]"; return $left_bracket . $str . $right_bracket; } sub gen_lua_code_for_args { my ($user_args, $all_args) = @_; my $luasrc = "arg = {}\n"; # arg[n] (n = 0) $luasrc .= "arg[0] = $quoted_luafile\n"; # arg[n] (n > 0) for my $i (0 .. $#user_args) { my $index = $i + 1; my $quoted_arg = quote_as_lua_str($user_args[$i]); $luasrc .= "arg[$index] = $quoted_arg\n"; } my $left_num = $#all_args - $#user_args; =begin cmt # arg[n] (n < 0) for my $i (0 .. $left_num - 2) { my $index = 0 - $left_num + $i + 1; my $quoted_arg = quote_as_lua_str($all_args[$i]); $luasrc .= "arg[$index] = $quoted_arg\n"; } =end cmt =cut # args[n] (n = the index of resty-cli itself) my $index = 0 - $left_num; my $quoted_arg = quote_as_lua_str($0); $luasrc .= "arg[$index] = $quoted_arg\n"; #warn $luasrc; return $luasrc; } sub resolve_includes ($$) { my ($type, $paths) = @_; if (!defined $cwd) { if ($is_win32) { require File::Spec; } else { $cwd = `pwd`; if (!$cwd || $?) { require Cwd; $cwd = Cwd::cwd(); } else { chomp $cwd; } } } my $s = ''; for my $path (@$paths) { if (!-f $path) { die "ERROR: could not find $type include file '$path'"; } my $abs_path; if ($is_win32) { $abs_path = File::Spec->rel2abs($path); } elsif ($path =~ m{^/}) { $abs_path = $path; } else { $abs_path = "$cwd/$path"; } $s .= "include $abs_path;"; } return $s; } sub forward_signal { my $signame = shift; if ($signame eq 'HUP') { $signame = 'QUIT'; } if ($child_pid) { #warn "killing $child_pid with $signame ...\n"; my $loaded_time_hires; if ($signame eq 'INT' || $signame eq 'PIPE') { # Note: we use eval here just because explicit use of %! # would trigger auto-loading of the Errno module, which # hurts script startup time. eval q# if (kill(QUIT => $child_pid) == 0) { if (not $!{ESRCH}) { die "failed to send QUIT signal to process ", "$child_pid: $!"; } } #; if ($@) { die "failed to eval: $@"; } require Time::HiRes; $loaded_time_hires = 1; Time::HiRes::sleep(0.1); kill KILL => $child_pid; exit($signame eq 'INT' ? 130 : 141); } else { # Note: we use eval here just because explicit use of %! # would trigger auto-loading of the Errno module, which # hurts script startup time. eval q# if (kill($signame => $child_pid) == 0) { if (not $!{ESRCH}) { die "failed to send $signame signal to process ", "$child_pid: $!"; } } #; if ($@) { die "failed to eval: $@"; } } if (!$loaded_time_hires) { require Time::HiRes; } my $nap = 0.001; my $total_nap = 0; while ($total_nap < 0.1) { #warn "sleeping $nap"; $nap *= 1.5; $total_nap += $nap; Time::HiRes::sleep($nap); # Note: we use eval here just because explicit use of %! # would trigger auto-loading of the Errno module, which # hurts script startup time. my ($ret, $echild); eval qq# \$ret = waitpid \$child_pid, $WNOHANG; \$echild = \$!{ECHILD}; #; if ($@) { die "failed to eval: $@"; } next if $ret == 0; exit 0 if $echild; if ($ret < 0) { die "failed to wait on child process $child_pid: $!"; } my $rc = 0; if ($signame eq 'INT') { $rc = 130; } elsif ($signame eq 'TERM') { $rc = 143; } if ($?) { $rc = ($? >> 8); if ($rc == 0) { $rc = $?; } } exit $rc; } } } sub join_sh_args ($) { my $args = shift; my @args = @$args; for (@args) { s/([\\\s'"><`\[\]\&\$#*?!()|;])/\\$1/g; } return join " ", @args; } sub split_sh_args ($) { my $s = shift; my @cmd; while (1) { if ($s =~ /\G (\s*) "([^"]*)" /gmscx) { my ($sep, $v) = ($1, $2); #warn "sep: [$sep], v: [$v]"; if (!$sep && @cmd) { $cmd[-1] .= $v; } else { push @cmd, $v; } } elsif ($s =~ /\G (\s*) '([^']*)' /gmscx) { my ($sep, $v) = ($1, $2); #warn "sep: [$sep], v: [$v]"; if (!$sep && @cmd) { $cmd[-1] .= $v; } else { push @cmd, $v; } } elsif ($s =~ /\G (\s*) ( (?: \\. | [^\s'"\\]+ )+ ) /gmscx) { my ($sep, $v) = ($1, $2); #warn "sep: [$sep], v: [$v]"; $v =~ s/\\(.)/$1/g; if (!$sep && @cmd) { $cmd[-1] .= $v; } else { push @cmd, $v; } } elsif ($s =~ /\G \s* (\S.*) /gmscx) { die "syntax error: $1"; } else { last; } } #use Data::Dumper; #warn "cmd: ", Dumper \@cmd; return @cmd; }