Object-Remote-0.003006/0000755000372100001440000000000012644534072014164 5ustar matthewtusersObject-Remote-0.003006/lib/0000755000372100001440000000000012644534072014732 5ustar matthewtusersObject-Remote-0.003006/lib/Object/0000755000372100001440000000000012644534072016140 5ustar matthewtusersObject-Remote-0.003006/lib/Object/Remote.pm0000644000372100001440000002114212644533747017741 0ustar matthewtuserspackage Object::Remote; use Object::Remote::MiniLoop; use Object::Remote::Handle; use Object::Remote::Logging qw( :log ); use Module::Runtime qw(use_module); our $VERSION = '0.003006'; # 0.3.6 sub new::on { my ($class, $on, @args) = @_; my $conn = __PACKAGE__->connect($on); log_trace { sprintf("constructing instance of $class on connection for child pid of %i", $conn->child_pid) }; return $conn->remote_object(class => $class, args => \@args); } sub can::on { my ($class, $on, $name) = @_; my $conn = __PACKAGE__->connect($on); log_trace { "Invoking remote \$class->can('$name')" }; return $conn->remote_sub(join('::', $class, $name)); } sub new { shift; Object::Remote::Handle->new(@_)->proxy; } sub connect { my ($class, $to, @args) = @_; use_module('Object::Remote::Connection')->maybe::start::new_from_spec($to, @args); } sub current_loop { our $Current_Loop ||= Object::Remote::MiniLoop->new } 1; =head1 NAME Object::Remote - Call methods on objects in other processes or on other hosts =head1 SYNOPSIS Creating a connection: use Object::Remote; my $conn = Object::Remote->connect('myserver'); # invokes ssh Calling a subroutine: my $capture = IPC::System::Simple->can::on($conn, 'capture'); warn $capture->('uptime'); Using an object: my $eval = Eval::WithLexicals->new::on($conn); $eval->eval(q{my $x = `uptime`}); warn $eval->eval(q{$x}); Importantly: 'myserver' only requires perl 5.8+ - no non-core modules need to be installed on the far side, Object::Remote takes care of it for you! =head1 DESCRIPTION Object::Remote allows you to create an object in another process - usually one running on another machine you can connect to via ssh, although there are other connection mechanisms available. The idea here is that in many cases one wants to be able to run a piece of code on another machine, or perhaps many other machines - but without having to install anything on the far side. =head1 COMPONENTS =head2 Object::Remote The "main" API, which provides the L method to create a connection to a remote process/host, L to create an object on a connection, and L to retrieve a subref over a connection. =head2 Object::Remote::Connection The object representing a connection, which provides the L and L methods that are used by L and L to return proxies for objects and subroutines on the far side. =head2 Object::Remote::Future Code for dealing with asynchronous operations, which provides the L syntax for calling a possibly asynchronous method without blocking, and L and L to block until an asynchronous call completes or fails. =head1 METHODS =head2 connect my $conn = Object::Remote->connect('-'); # fork()ed connection my $conn = Object::Remote->connect('myserver'); # connection over ssh my $conn = Object::Remote->connect('user@myserver'); # connection over ssh my $conn = Object::Remote->connect('root@'); # connection over sudo =head2 new::on my $eval = Eval::WithLexicals->new::on($conn); my $eval = Eval::WithLexicals->new::on('myserver'); # implicit connect my $obj = Some::Class->new::on($conn, %args); # with constructor arguments =head2 can::on my $hostname = Sys::Hostname->can::on($conn, 'hostname'); my $hostname = Sys::Hostname->can::on('myserver', 'hostname'); =head1 ENVIRONMENT =over 4 =item OBJECT_REMOTE_PERL_BIN When starting a new Perl interpreter the contents of this environment variable will be used as the path to the executable. If the variable is not set the path is 'perl' =item OBJECT_REMOTE_LOG_LEVEL Setting this environment variable will enable logging and send all log messages at the specfied level or higher to STDERR. Valid level names are: trace debug verbose info warn error fatal =item OBJECT_REMOTE_LOG_FORMAT The format of the logging output is configurable. By setting this environment variable the format can be controlled via printf style position variables. See L. =item OBJECT_REMOTE_LOG_FORWARDING Forward log events from remote connections to the local Perl interpreter. Set to 1 to enable this feature which is disabled by default. See L. =item OBJECT_REMOTE_LOG_SELECTIONS Space seperated list of class names to display logs for if logging output is enabled. Default value is "Object::Remote::Logging" which selects all logs generated by Object::Remote. See L. =back =head1 KNOWN ISSUES =over 4 =item Large data structures Object::Remote communication is encapsalated with JSON and values passed to remote objects will be serialized with it. When sending large data structures or data structures with a lot of deep complexity (hashes in arrays in hashes in arrays) the processor time and memory requirements for serialization and deserialization can be either painful or unworkable. During times of serialization the local or remote nodes will be blocked potentially causing all remote interpreters to block as well under worse case conditions. To help deal with this issue it is possible to configure resource ulimits for a Perl interpreter that is executed by Object::Remote. See C for details on the perl_command attribute. =item User can starve run loop of execution opportunities The Object::Remote run loop is responsible for performing I/O and managing timers in a cooperative multitasing way but it can only do these tasks when the user has given control to Object::Remote. There are times when Object::Remote must wait for the user to return control to the run loop and during these times no I/O can be performed and no timers can be executed. As an end user of Object::Remote if you depend on connection timeouts, the watch dog or timely results from remote objects then be sure to hand control back to Object::Remote as soon as you can. =item Run loop favors certain filehandles/connections =item High levels of load can starve timers of execution opportunities These are issues that only become a problem at large scales. The end result of these two issues is quite similiar: some remote objects may block while the local run loop is either busy servicing a different connection or is not executing because control has not yet been returned to it. For the same reasons timers may not get an opportunity to execute in a timely way. Internally Object::Remote uses timers managed by the run loop for control tasks. Under high load the timers can be preempted by servicing I/O on the filehandles and execution can be severely delayed. This can lead to connection watchdogs not being updated or connection timeouts taking longer than configured. =item Deadlocks Deadlocks can happen quite easily because of flaws in programs that use Object::Remote or Object::Remote itself so the C is available. When used the run loop will periodically update the watch dog object on the remote Perl interpreter. If the watch dog goes longer than the configured interval with out being updated then it will terminate the Perl process. The watch dog will terminate the process even if a deadlock condition has occured. =item Log forwarding at scale can starve timers of execution opportunities Currently log forwarding can be problematic at large scales. When there is a large amount of log events the load produced by log forwarding can be high enough that it starves the timers and the remote object watch dogs (if in use) don't get updated in timely way causing them to erroneously terminate the Perl process. If the watch dog is not in use then connection timeouts can be delayed but will execute when load settles down enough. Because of the load related issues Object::Remote disables log forwarding by default. See C for information on log forwarding. =back =head1 SUPPORT IRC: #web-simple on irc.perl.org =head1 AUTHOR mst - Matt S. Trout (cpan:MSTROUT) =head1 CONTRIBUTORS bfwg - Colin Newell (cpan:NEWELLC) phaylon - Robert Sedlacek (cpan:PHAYLON) triddle - Tyler Riddle (cpan:TRIDDLE) =head1 SPONSORS Parts of this code were paid for by Socialflow L Shadowcat Systems L =head1 COPYRIGHT Copyright (c) 2012 the Object::Remote L, L and L as listed above. =head1 LICENSE This library is free software and may be distributed under the same terms as perl itself. =cut Object-Remote-0.003006/lib/Object/Remote/0000755000372100001440000000000012644534072017373 5ustar matthewtusersObject-Remote-0.003006/lib/Object/Remote/FromData.pm0000644000372100001440000000206712414033615021423 0ustar matthewtuserspackage Object::Remote::FromData; use strictures 1; use Object::Remote; use Object::Remote::Logging qw ( :log ); our %Modules; our %Not_Loaded_Yet; our %Seen; sub import { my $target = caller; log_trace { "import has been invoked by '$target' on " . __PACKAGE__ }; return if $Seen{$target}; log_debug { "'$target' has not yet loaded " . __PACKAGE__ }; $Seen{$target} = $Not_Loaded_Yet{$target} = 1; } sub flush_loaded { log_debug { "flushing the loaded classes" }; foreach my $key (keys %Not_Loaded_Yet) { log_trace { "flushing '$key'" }; my $data_fh = do { no strict 'refs'; *{"${key}::DATA"} }; my $data = do { local $/; <$data_fh> }; my %modules = reverse( $data =~ m/(^package ([^;]+);\n.*?(?:(?=^package)|\Z))/msg ); $_ .= "\n1;\n" for values %modules; @Modules{keys %modules} = values %modules; delete $Not_Loaded_Yet{$key}; } log_trace { "done flushing loaded classes" }; } sub find_module { flush_loaded; my ($module) = @_; $module =~ s/\//::/g; $module =~ s/\.pm$//; return $Modules{$module}; } 1; Object-Remote-0.003006/lib/Object/Remote/Connector/0000755000372100001440000000000012644534072021325 5ustar matthewtusersObject-Remote-0.003006/lib/Object/Remote/Connector/Local.pm0000644000372100001440000000042312414033615022704 0ustar matthewtuserspackage Object::Remote::Connector::Local; use Moo; with 'Object::Remote::Role::Connector::PerlInterpreter'; no warnings 'once'; BEGIN { } push @Object::Remote::Connection::Guess, sub { if (($_[0]||'') eq '-') { shift(@_); __PACKAGE__->new(@_); } }; 1; Object-Remote-0.003006/lib/Object/Remote/Connector/STDIO.pm0000644000372100001440000000155712414033615022545 0ustar matthewtuserspackage Object::Remote::Connector::STDIO; use File::Spec; use IO::Handle; use Object::Remote::Connection; use Object::Remote::ReadChannel; use Moo; sub connect { open my $stdin, '<&', \*STDIN or die "Duping stdin: $!"; open my $stdout, '>&', \*STDOUT or die "Duping stdout: $!"; $stdout->autoflush(1); # if we don't re-open them then 0 and 1 get re-used - which is not # only potentially bloody confusing but results in warnings like: # "Filehandle STDOUT reopened as STDIN only for input" close STDIN or die "Closing stdin: $!"; open STDIN, '<', File::Spec->devnull or die "Re-opening stdin: $!"; close STDOUT or die "Closing stdout: $!"; open STDOUT, '>', File::Spec->devnull or die "Re-opening stdout: $!"; return Object::Remote::Connection->new( send_to_fh => $stdout, read_channel => Object::Remote::ReadChannel->new(fh => $stdin) ); } 1; Object-Remote-0.003006/lib/Object/Remote/Connector/SSH.pm0000644000372100001440000000177012414033615022315 0ustar matthewtuserspackage Object::Remote::Connector::SSH; use Object::Remote::ModuleSender; use Object::Remote::Handle; use String::ShellQuote; use Moo; with 'Object::Remote::Role::Connector::PerlInterpreter'; has ssh_to => (is => 'ro', required => 1); has ssh_perl_command => (is => 'lazy'); has ssh_options => (is => 'ro', default => sub { [ '-A' ] }); has ssh_command => (is => 'ro', default => sub { 'ssh' }); sub _build_ssh_perl_command { my ($self) = @_; my $perl_command = $self->perl_command; return [ do { my $c = $self->ssh_command; ref($c) ? @$c : $c }, @{$self->ssh_options}, $self->ssh_to, shell_quote(@$perl_command), ]; } sub final_perl_command { shift->ssh_perl_command } no warnings 'once'; push @Object::Remote::Connection::Guess, sub { for ($_[0]) { # 0-9 a-z _ - first char, those or . subsequent - hostnamish if (defined and !ref and /^(?:.*?\@)?[\w\-][\w\-\.]/) { my $host = shift(@_); return __PACKAGE__->new(@_, ssh_to => $host); } } return; }; 1; Object-Remote-0.003006/lib/Object/Remote/Connector/LocalSudo.pm0000644000372100001440000000575312414033615023552 0ustar matthewtuserspackage Object::Remote::Connector::LocalSudo; use Object::Remote::Logging qw (:log :dlog); use Symbol qw(gensym); use Module::Runtime qw(use_module); use IPC::Open3; use Moo; extends 'Object::Remote::Connector::Local'; has target_user => (is => 'ro', required => 1); has password_callback => (is => 'lazy'); sub _build_password_callback { my ($self) = @_; my $pw_prompt = use_module('Object::Remote::Prompt')->can('prompt_pw'); my $user = $self->target_user; return sub { $pw_prompt->("sudo password for ${user}", undef, { cache => 1 }) } } has sudo_perl_command => (is => 'lazy'); sub _build_sudo_perl_command { my ($self) = @_; return 'sudo', '-S', '-u', $self->target_user, '-p', "[sudo] password please\n", 'perl', '-MPOSIX=dup2', '-e', 'print STDERR "GO\n"; exec(@ARGV);', $self->perl_command; } sub _start_perl { my $self = shift; my $sudo_stderr = gensym; my $pid = open3( my $foreign_stdin, my $foreign_stdout, $sudo_stderr, @{$self->sudo_perl_command} ) or die "open3 failed: $!"; chomp(my $line = <$sudo_stderr>); if ($line eq "GO") { # started already, we're good } elsif ($line =~ /\[sudo\]/) { my $cb = $self->password_callback; die "sudo sent ${line} but we have no password callback" unless $cb; print $foreign_stdin $cb->($line, @_), "\n"; chomp($line = <$sudo_stderr>); if ($line and $line ne 'GO') { die "sent password and expected newline from sudo, got ${line}"; } elsif (not $line) { chomp($line = <$sudo_stderr>); die "sent password but next line was ${line}" unless $line eq "GO"; } } else { die "Got inexplicable line ${line} trying to sudo"; }; Object::Remote->current_loop ->watch_io( handle => $sudo_stderr, on_read_ready => sub { Dlog_debug { "LocalSudo: Preparing to read data from $_" } $sudo_stderr; if (sysread($sudo_stderr, my $buf, 32768) > 0) { log_trace { "LocalSudo: successfully read data, printing it to STDERR" }; print STDERR $buf; log_trace { "LocalSudo: print() to STDERR is done" }; } else { log_debug { "LocalSudo: received EOF or error on file handle, unwatching it" }; Object::Remote->current_loop ->unwatch_io( handle => $sudo_stderr, on_read_ready => 1 ); } } ); return ($foreign_stdin, $foreign_stdout, $pid); }; no warnings 'once'; push @Object::Remote::Connection::Guess, sub { for ($_[0]) { # username followed by @ if (defined and !ref and /^ ([^\@]*?) \@ $/x) { shift(@_); return __PACKAGE__->new(@_, target_user => $1); } } return; }; 1; Object-Remote-0.003006/lib/Object/Remote/Connector/UNIX.pm0000644000372100001440000000112512414033615022435 0ustar matthewtuserspackage Object::Remote::Connector::UNIX; use IO::Socket::UNIX; use Moo; with 'Object::Remote::Role::Connector'; has socket_path => (is => 'ro', required => 1); sub _open2_for { my ($self) = @_; my $path = $self->socket_path; my $sock = IO::Socket::UNIX->new($path) or die "Couldn't open socket ${path}: $!"; ($sock, $sock, undef); } no warnings 'once'; push @Object::Remote::Connection::Guess, sub { for ($_[0]) { if (defined and !ref and /^(?:\.\/|\/)/) { my $socket = shift(@_); return __PACKAGE__->new(@_, socket_path => $socket); } } return; }; 1; Object-Remote-0.003006/lib/Object/Remote/ModuleSender.pm0000644000372100001440000000227212644532633022323 0ustar matthewtuserspackage Object::Remote::ModuleSender; use Object::Remote::Logging qw( :log :dlog ); use Config; use File::Spec; use List::Util qw(first); use Moo; has dir_list => (is => 'lazy'); sub _build_dir_list { my %core = map +($_ => 1), grep $_, @Config{ qw(privlibexp archlibexp vendorarchexp sitearchexp) }; DlogS_trace { "dir list built in ModuleSender: $_" } [ grep !$core{$_}, @INC ]; } sub source_for { my ($self, $module) = @_; log_debug { "locating source for module '$module'" }; if (my $find = Object::Remote::FromData->can('find_module')) { if (my $source = $find->($module)) { Dlog_trace { "source of '$module' was found by Object::Remote::FromData" }; return $source; } } log_trace { "Searching for module in library directories" }; my ($found) = first { -f $_ } map File::Spec->catfile($_, $module), @{$self->dir_list}; die "Can't locate ${module} in \@INC. (on remote host) dir_list contains:\n" .join("\n", @{$self->dir_list}) unless $found; log_debug { "found '$module' at '$found'" }; open my $fh, '<', $found or die "Couldn't open ${found} for ${module}: $!"; return do { local $/; <$fh> }; } 1; Object-Remote-0.003006/lib/Object/Remote/Logging.pm0000644000372100001440000002475012414033615021317 0ustar matthewtuserspackage Object::Remote::Logging; use Moo; use Object::Remote::Logging::Logger; use Exporter::Declare; extends 'Log::Contextual'; exports(qw( ____ router arg_levels )); sub router { our $Router_Instance ||= do { require Object::Remote::Logging::Router; Object::Remote::Logging::Router->new; } } #log level descriptions #info - standard log level - normal program output for the end user #warn - output for program that is executing quietly #error - output for program that is running more quietly #fatal - it is not possible to continue execution; this level is as quiet as is possible #verbose - output for program executing verbosely (-v) #debug - output for program running more verbosely (-v -v) #trace - output for program running extremely verbosely (-v -v -v) sub arg_levels { #the order of the log levels is significant with the #most verbose level being first in the list and the #most quiet as the last item return [qw( trace debug verbose info warn error fatal )]; } sub before_import { my ($class, $importer, $spec) = @_; my $router = $class->router; our $DID_INIT; unless($DID_INIT) { $DID_INIT = 1; init_logging(); } $class->SUPER::before_import($importer, $spec); } sub _parse_selections { my ($selections_string) = @_; my %log_ok; #example string: #" * -Object::Remote::Logging Foo::Bar::Baz " foreach(split(/\s+/, $selections_string)) { next if $_ eq ''; if ($_ eq '*') { $log_ok{$_} = 1; } elsif (s/^-//) { $log_ok{$_} = 0; } else { $log_ok{$_} = 1; } } return %log_ok; } #this is invoked on all nodes sub init_logging { my $level = $ENV{OBJECT_REMOTE_LOG_LEVEL}; my $format = $ENV{OBJECT_REMOTE_LOG_FORMAT}; my $selections = $ENV{OBJECT_REMOTE_LOG_SELECTIONS}; my $test_logging = $ENV{OBJECT_REMOTE_TEST_LOGGER}; my %controller_should_log; unless (defined $ENV{OBJECT_REMOTE_LOG_FORWARDING} && $ENV{OBJECT_REMOTE_LOG_FORWARDING} ne '') { $ENV{OBJECT_REMOTE_LOG_FORWARDING} = 0; } if ($test_logging) { require Object::Remote::Logging::TestLogger; router->connect(Object::Remote::Logging::TestLogger->new( min_level => 'trace', max_level => 'error', level_names => Object::Remote::Logging->arg_levels(), )); } { no warnings 'once'; if (defined $Object::Remote::FatNode::REMOTE_NODE) { #the connection id for the remote node comes in later #as the controlling node inits remote logging router()->_remote_metadata({ connection_id => undef }); } } return unless defined $level && $level ne ''; $format = "[%l %r] %s" unless defined $format; $selections = __PACKAGE__ unless defined $selections; %controller_should_log = _parse_selections($selections); my $logger = Object::Remote::Logging::Logger->new( min_level => lc($level), format => $format, level_names => Object::Remote::Logging::arg_levels(), ); router()->connect(sub { my $controller = $_[1]->{exporter}; my $will_log = $controller_should_log{$controller}; my $remote_info = $_[1]->{object_remote}; $will_log = $controller_should_log{'*'} unless defined $will_log; return unless $will_log; #skip things from remote hosts because they log to STDERR #when OBJECT_REMOTE_LOG_LEVEL is in effect return if $remote_info->{forwarded}; return $logger; }); } #this is invoked by the controlling node #on the remote nodes sub init_remote_logging { my ($self, %controller_info) = @_; router()->_remote_metadata(\%controller_info); router()->_forward_destination($controller_info{router}) if $ENV{OBJECT_REMOTE_LOG_FORWARDING}; } 1; =head1 NAME Object::Remote::Logging - Logging subsystem for Object::Remote =head1 SYNOPSIS use Object::Remote::Logging qw( :log :dlog arg_levels router ); $levels = [qw( trace debug verbose info warn error fatal )]; $levels = arg_levels(); #same result $ENV{OBJECT_REMOTE_LOG_LEVEL} = 'trace'; #or other level name $ENV{OBJECT_REMOTE_LOG_FORMAT} = '%l %t: %p::%m %s'; #and more #Output logs from two specific logging pacakges $ENV{OBJECT_REMOTE_LOG_SELECTIONS} = 'Object::Remote::Logging Some::Other::Package'; #Output all log messages except those generated by Object::Remote $ENV{OBJECT_REMOTE_LOG_SELECTIONS} = '* -Object::Remote::Logging'; $ENV{OBJECT_REMOTE_LOG_FORWARDING} = 1; #default 0 log_info { 'Trace log event' }; Dlog_verbose { "Debug event with Data::Dumper::Concise: $_" } { foo => 'bar' }; =head1 DESCRIPTION This is the logging framework for Object::Remote implemented as an extension of L with a slightly incompatible API. This system allows developers using Object::Remote and end users of that software to control Object::Remote logging so operation can be tracked if needed. This is also the API used to generate log messages inside the Object::Remote source code. The rest of the logging system comes from L which implements log rendering and output and Object::Remote::Logging::Router which delivers log events to the loggers. =head1 USAGE Object::Remote logging output is not enabled by default. If you need to immediately start debugging set the OBJECT_REMOTE_LOG_LEVEL environment variable to either 'trace' or 'debug'. This will enable logging to STDERR on the local and all remote Perl interpreters. By default STDERR for all remote interpreters is passed through unmodified so this is sufficient to receive logs generated anywhere Object::Remote is running. Every time the local interpreter creates a new Object::Remote::Connection the connection is given an id that is unique to that connection on the local interpreter. The connection id and other metadata is available in the log output via a log format string that can be set via the OBJECT_REMOTE_LOG_FORMAT environment variable. The format string and available metadata is documented in L. Setting this environment variable on the local interpreter will cause it to be propagated to the remote interpreter so all logs will be formated the same way. This system is designed so any module can create their own logging packages using it. With out any additional configuration the consumers of this logging system will automatically be enabled via OBJECT_REMOTE_LOG_LEVEL and formated with OBJECT_REMOTE_LOG_FORMAT but those additional log messages are not sent to STDERR. By setting the OBJECT_REMOTE_LOG_SELECTIONS environment variable to a list of logging package names seperated by spaces then logs generated using those packages will be sent to STDERR. If the asterisk character (*) is used in the place of a package name then all package names will be selected by default instead of ignored. An individual package name can be turned off by prefixing the name with a hypen character (-). This is also a configuration item that is forwarded to the remote interpreters so all logging is consistent. Regardless of OBJECT_REMOTE_LOG_LEVEL the logging system is still active and loggers can access the stream of log messages to format and output them. Internally OBJECT_REMOTE_LOG_LEVEL causes an L to be built and connected to the Object::Remote::Logging::Router instance. It is also possible to manually build a logger instance and connect it to the router. See the Object::Remote::Logging documentation for more information. The logging system also supports a method of forwarding log messages from remote interpreters to the local interpreter. Forwarded log messages are generated in the remote interpreter and the logger for the message is invoked in the local interpreter. Packages using or extending Object::Remote::Logging will have log messages forwarded automatically. Loggers receive forwarded log messages exactly the same way as non-forwarded messages except a forwarded message includes extra metadata about the remote connection. Log forwarding is disabled by default because it comes with a performance hit; to enable it set the OBJECT_REMOTE_LOG_FORWARDING environment variable to 1. =head1 EXPORTABLE SUBROUTINES =over 4 =item arg_levels Returns an array reference that contains the ordered list of level names with the lowest log level first and the highest log level last. =item router Returns the instance of L that is in use. The router instance is used in combination with L objects to select then render and output log messages. =item log_ and Dlog_ These methods come direct from L; see that documentation for a complete reference. For each of the log level names there are subroutines with the log_ and Dlog_ prefix that will generate the log message. The first argument is a code block that returns the log message contents and the optional further arguments are both passed to the block as the argument list and returned from the log method as a list. log_trace { "A fine log message $_[0] " } 'if I do say so myself'; %hash = Dlog_trace { "Very handy: $_" } ( foo => 'bar' ); =item logS_ and DlogS_ Works just like log_ and Dlog_ except returns only the first argument as a scalar value. my $beverage = logS_info { "Customer ordered $_[0]" } 'Coffee'; =back =head1 LEVEL NAMES Object::Remote uses an ordered list of log level names with the lowest level first and the highest level last. The list of level names can be accessed via the arg_levels method which is exportable to the consumer of this class. The log level names are: =over 4 =item trace As much information about operation as possible including multiple line dumps of large content. Tripple verbose operation (-v -v -v). =item debug Messages about operations that could hang as well as internal state changes, results from method invocations, and information useful when looking for faults. Double verbose operation (-v -v). =item verbose Additional optional messages to the user that can be enabled at their will. Single verbose operation (-v). =item info Messages from normal operation that are intended to be displayed to the end user if quiet operation is not indicated and more verbose operation is not in effect. =item warn Something wasn't supposed to happen but did. Operation was not impacted but otherwise the event is noteworthy. Single quiet operation (-q). =item error Something went wrong. Operation of the system may continue but some operation has most definitely failed. Double quiet operation (-q -q). =item fatal Something went wrong and recovery is not possible. The system should stop operating as soon as possible. Tripple quiet operation (-q -q -q). =back Object-Remote-0.003006/lib/Object/Remote/ConnectionServer.pm0000644000372100001440000000527212414033615023215 0ustar matthewtuserspackage Object::Remote::ConnectionServer; use Scalar::Util qw(blessed weaken); use Module::Runtime qw(use_module); use Object::Remote; use Object::Remote::Logging qw( :log :dlog ); use Future; use IO::Socket::UNIX; use Moo; has listen_on => ( is => 'ro', coerce => sub { return $_[0] if blessed($_[0]); unlink($_[0]); IO::Socket::UNIX->new( Local => $_[0], Listen => 1 ) or die "Couldn't liten to $_[0]: $!"; }, trigger => sub { my ($self, $fh) = @_; log_debug { "adding connection server to run loop because the trigger has executed" }; weaken($self); Object::Remote->current_loop ->watch_io( handle => $fh, on_read_ready => sub { $self->_listen_ready($fh) } ); }, ); has connection_args => ( is => 'ro', default => sub { [] } ); has connection_callback => ( is => 'ro', default => sub { sub { shift } } ); sub BUILD { log_debug { "A connection server has been built; calling want_run on run loop" }; Object::Remote->current_loop->want_run; } sub run { log_debug { "Connection server is calling run_while_wanted on the run loop" }; Object::Remote->current_loop->run_while_wanted; } sub _listen_ready { my ($self, $fh) = @_; log_debug { "Got a connection, calling accept on the file handle" }; my $new = $fh->accept or die "Couldn't accept: $!"; log_trace { "Setting file handle non-blocking" }; $new->blocking(0); my $f = Future->new; log_trace { "Creating a new connection with the remote node" }; my $c = use_module('Object::Remote::Connection')->new( receive_from_fh => $new, send_to_fh => $new, on_close => $f, # and so will die $c @{$self->connection_args} )->${\$self->connection_callback}; $f->on_ready(sub { undef($c) }); log_trace { "marking the future as done" }; $c->ready_future->done; Dlog_trace { "Sending 'Shere' to socket $_" } $new; print $new "Shere\n" or die "Couldn't send to new socket: $!"; log_debug { "Connection has been fully handled" }; return $c; } sub DEMOLISH { my ($self, $gd) = @_; log_debug { "A connection server is being destroyed; global destruction: '$gd'" }; return if $gd; log_trace { "Removing the connection server IO watcher from run loop" }; Object::Remote->current_loop ->unwatch_io( handle => $self->listen_on, on_read_ready => 1 ); if ($self->listen_on->can('hostpath')) { log_debug { my $p = $self->listen_on->hostpath; "Removing '$p' from the filesystem" }; unlink($self->listen_on->hostpath); } log_trace { "calling want_stop on the run loop" }; Object::Remote->current_loop->want_stop; } 1; Object-Remote-0.003006/lib/Object/Remote/CodeContainer.pm0000644000372100001440000000022512414033615022435 0ustar matthewtuserspackage Object::Remote::CodeContainer; use Moo; has code => (is => 'ro', required => 1); sub call { my $self = shift; $self->code->(@_) } 1; Object-Remote-0.003006/lib/Object/Remote/GlobProxy.pm0000644000372100001440000000120012414033615021637 0ustar matthewtusersuse strictures 1; package Object::Remote::GlobProxy; require Tie::Handle; our @ISA = qw( Tie::Handle ); sub TIEHANDLE { my ($class, $glob_container) = @_; return bless { container => $glob_container }, $class; } my @_delegate = ( [READLINE => sub { wantarray ? $_[0]->getlines : $_[0]->getline }], (map { [uc($_), lc($_)] } qw( write print printf read getc close open binmode eof tell seek )), ); for my $delegation (@_delegate) { my ($from, $to) = @$delegation; no strict 'refs'; *{join '::', __PACKAGE__, $from} = sub { $_[0]->{container}->$to(@_[1 .. $#_]); }; } 1; Object-Remote-0.003006/lib/Object/Remote/Connection.pm0000644000372100001440000003435412414033615022031 0ustar matthewtuserspackage Object::Remote::Connection; use Object::Remote::Logging qw (:log :dlog router); use Object::Remote::Future; use Object::Remote::Null; use Object::Remote::Handle; use Object::Remote::CodeContainer; use Object::Remote::GlobProxy; use Object::Remote::GlobContainer; use Object::Remote::Tied; use Object::Remote; use Symbol; use IO::Handle; use POSIX ":sys_wait_h"; use Module::Runtime qw(use_module); use Scalar::Util qw(weaken blessed refaddr openhandle); use JSON::PP qw(encode_json); use Future; use Carp qw(croak); use Moo; BEGIN { router()->exclude_forwarding } END { our %child_pids; log_trace { "END handler is being invoked in " . __PACKAGE__ }; foreach(keys(%child_pids)) { log_debug { "Killing child process '$_'" }; kill('TERM', $_); } } has _id => ( is => 'ro', required => 1, default => sub { our $NEXT_CONNECTION_ID++ } ); has send_to_fh => ( is => 'ro', required => 1, trigger => sub { my $self = $_[0]; $_[1]->autoflush(1); Dlog_trace { my $id = $self->_id; "connection had send_to_fh set to $_" } $_[1]; }, ); has read_channel => ( is => 'ro', required => 1, trigger => sub { my ($self, $ch) = @_; my $id = $self->_id; Dlog_trace { "trigger for read_channel has been invoked for connection $id; file handle is $_" } $ch->fh; weaken($self); $ch->on_line_call(sub { $self->_receive(@_) }); $ch->on_close_call(sub { log_trace { "invoking 'done' on on_close handler for connection id '$id'" }; $self->on_close->done(@_); }); }, ); has on_close => ( is => 'rw', default => sub { $_[0]->_install_future_handlers(Future->new) }, trigger => sub { log_trace { "Installing handlers into future via trigger" }; $_[0]->_install_future_handlers($_[1]) }, ); has child_pid => (is => 'ro'); has local_objects_by_id => ( is => 'ro', default => sub { {} }, coerce => sub { +{ %{$_[0]} } }, # shallow clone on the way in ); has remote_objects_by_id => ( is => 'ro', default => sub { {} }, coerce => sub { +{ %{$_[0]} } }, # shallow clone on the way in ); has outstanding_futures => (is => 'ro', default => sub { {} }); has _json => ( is => 'lazy', handles => { _deserialize => 'decode', _encode => 'encode', }, ); after BUILD => sub { my ($self) = @_; my $pid = $self->child_pid; our %child_pids; return unless defined $pid; $child_pids{$pid} = 1; return; }; sub BUILD { } sub is_valid { my ($self) = @_; my $valid = ! $self->on_close->is_ready; log_trace { my $id = $self->_id; my $text; if ($valid) { $text = 'yes'; } else { $text = 'no'; } "Connection '$id' is valid: '$text'" }; return $valid; } sub _fail_outstanding { my ($self, $error) = @_; my $outstanding = $self->outstanding_futures; Dlog_debug { sprintf "Failing %i outstanding futures with '$error'", scalar(keys(%$outstanding)) }; foreach(keys(%$outstanding)) { log_trace { "Failing future for $_" }; my $future = $outstanding->{$_}; $future->fail("$error\n"); } %$outstanding = (); return; } sub _install_future_handlers { my ($self, $f) = @_; our %child_pids; Dlog_trace { "Installing handlers into future for connection $_" } $self->_id; weaken($self); $f->on_done(sub { my $pid = $self->child_pid; Dlog_trace { "Executing on_done handler in future for connection $_" } $self->_id; $self->_fail_outstanding("Object::Remote connection lost: " . ($f->get)[0]); return unless defined $pid; log_debug { "Waiting for child '$pid' to exit" }; my $ret = waitpid($pid, 0); if ($ret != $pid) { log_debug { "Waited for pid $pid but waitpid() returned $ret" }; return; } elsif ($? & 127) { log_warn { "Remote interpreter did not exit cleanly" }; } else { log_verbose { my $exit_value = $? >> 8; "Remote Perl interpreter exited with value '$exit_value'" }; } delete $child_pids{$pid}; }); return $f; }; sub _id_to_remote_object { my ($self, $id) = @_; Dlog_trace { "fetching proxy for remote object with id '$id' for connection $_" } $self->_id; return bless({}, 'Object::Remote::Null') if $id eq 'NULL'; ( $self->remote_objects_by_id->{$id} or Object::Remote::Handle->new(connection => $self, id => $id) )->proxy; } sub _build__json { weaken(my $self = shift); JSON::PP->new->filter_json_single_key_object( __remote_object__ => sub { $self->_id_to_remote_object(@_); } )->filter_json_single_key_object( __remote_code__ => sub { my $code_container = $self->_id_to_remote_object(@_); sub { $code_container->call(@_) }; } )->filter_json_single_key_object( __scalar_ref__ => sub { my $value = shift; return \$value; } )->filter_json_single_key_object( __glob_ref__ => sub { my $glob_container = $self->_id_to_remote_object(@_); my $handle = Symbol::gensym; tie *$handle, 'Object::Remote::GlobProxy', $glob_container; return $handle; } )->filter_json_single_key_object( __local_object__ => sub { $self->local_objects_by_id->{$_[0]} } )->filter_json_single_key_object( __remote_tied_hash__ => sub { my %tied_hash; tie %tied_hash, 'Object::Remote::Tied', $self->_id_to_remote_object(@_); return \%tied_hash; } )->filter_json_single_key_object( __remote_tied_array__ => sub { my @tied_array; tie @tied_array, 'Object::Remote::Tied', $self->_id_to_remote_object(@_); return \@tied_array; } ); } sub _load_if_possible { my ($class) = @_; use_module($class); if ($@) { log_debug { "Attempt at loading '$class' failed with '$@'" }; } } BEGIN { unshift our @Guess, sub { blessed($_[0]) ? $_[0] : undef }; map _load_if_possible($_), qw( Object::Remote::Connector::Local Object::Remote::Connector::LocalSudo Object::Remote::Connector::SSH Object::Remote::Connector::UNIX ); } sub conn_from_spec { my ($class, $spec, @args) = @_; foreach my $poss (do { our @Guess }) { if (my $conn = $poss->($spec, @args)) { return $conn; } } return undef; } sub new_from_spec { my ($class, $spec, @args) = @_; return $spec if blessed $spec; my $conn = $class->conn_from_spec($spec, @args); die "Couldn't figure out what to do with ${spec}" unless defined $conn; return $conn->maybe::start::connect; } sub remote_object { my ($self, @args) = @_; Object::Remote::Handle->new( connection => $self, @args )->proxy; } sub connect { my ($self, $to) = @_; Dlog_debug { "Creating connection to remote node '$to' for connection $_" } $self->_id; return await_future( $self->send_class_call(0, 'Object::Remote', connect => $to) ); } sub remote_sub { my ($self, $sub) = @_; my ($pkg, $name) = $sub =~ m/^(.*)::([^:]+)$/; Dlog_debug { "Invoking remote sub '$sub' for connection '$_'" } $self->_id; return await_future($self->send_class_call(0, $pkg, can => $name)); } sub send_class_call { my ($self, $ctx, @call) = @_; Dlog_trace { "Sending a class call for connection $_" } $self->_id; $self->send(call => class_call_handler => $ctx => call => @call); } sub register_class_call_handler { my ($self) = @_; $self->local_objects_by_id->{'class_call_handler'} ||= do { my $o = $self->new_class_call_handler; $self->_local_object_to_id($o); $o; }; } sub new_class_call_handler { Object::Remote::CodeContainer->new( code => sub { my ($class, $method) = (shift, shift); use_module($class)->$method(@_); } ); } sub register_remote { my ($self, $remote) = @_; Dlog_trace { my $i = $remote->id; "Registered a remote object with id of '$i' for connection $_" } $self->_id; weaken($self->remote_objects_by_id->{$remote->id} = $remote); return $remote; } sub send_free { my ($self, $id) = @_; Dlog_trace { "sending request to free object '$id' for connection $_" } $self->_id; #TODO this shows up some times when a remote side dies in the middle of a remote #method invocation - possibly only when the object is being constructed? #(in cleanup) Use of uninitialized value $id in delete at ../Object-Remote/lib/Object/Remote/Connection. delete $self->remote_objects_by_id->{$id}; $self->_send([ free => $id ]); } sub send { my ($self, $type, @call) = @_; my $future = Future->new; my $remote = $self->remote_objects_by_id->{$call[0]}; unshift @call, $type => $self->_local_object_to_id($future); my $outstanding = $self->outstanding_futures; $outstanding->{$future} = $future; $future->on_ready(sub { undef($remote); delete $outstanding->{$future} }); $self->_send(\@call); return $future; } sub send_discard { my ($self, $type, @call) = @_; unshift @call, $type => 'NULL'; $self->_send(\@call); } sub _send { my ($self, $to_send) = @_; my $fh = $self->send_to_fh; unless ($self->is_valid) { croak "Attempt to invoke _send on a connection that is not valid"; } Dlog_trace { "Starting to serialize data in argument to _send for connection $_" } $self->_id; my $serialized = $self->_serialize($to_send)."\n"; Dlog_trace { my $l = length($serialized); "serialization is completed; sending '$l' characters of serialized data to $_" } $fh; my $ret; eval { #TODO this should be converted over to a non-blocking ::WriteChannel class die "filehandle is not open" unless openhandle($fh); log_trace { "file handle has passed openhandle() test; printing to it" }; $ret = print $fh $serialized; die "print was not successful: $!" unless defined $ret }; if ($@) { Dlog_debug { "exception encountered when trying to write to file handle $_: $@" } $fh; my $error = $@; chomp($error); $self->on_close->done("could not write to file handle: $error") unless $self->on_close->is_ready; return; } return $ret; } sub _serialize { my ($self, $data) = @_; local our @New_Ids = (-1); return eval { my $flat = $self->_encode($self->_deobjectify($data)); $flat; } || do { my $err = $@; # won't get here if the eval doesn't die # don't keep refs to new things delete @{$self->local_objects_by_id}{@New_Ids}; die "Error serializing: $err"; }; } sub _local_object_to_id { my ($self, $object) = @_; my $id = refaddr($object); $self->local_objects_by_id->{$id} ||= do { push our(@New_Ids), $id if @New_Ids; $object; }; return $id; } sub _deobjectify { my ($self, $data) = @_; if (blessed($data)) { if ( $data->isa('Object::Remote::Proxy') and $data->{remote}->connection == $self ) { return +{ __local_object__ => $data->{remote}->id }; } else { return +{ __remote_object__ => $self->_local_object_to_id($data) }; } } elsif (my $ref = ref($data)) { if ($ref eq 'HASH') { my $tied_to = tied(%$data); if(defined($tied_to)) { return +{__remote_tied_hash__ => $self->_local_object_to_id($tied_to)}; } else { return +{ map +($_ => $self->_deobjectify($data->{$_})), keys %$data }; } } elsif ($ref eq 'ARRAY') { my $tied_to = tied(@$data); if (defined($tied_to)) { return +{__remote_tied_array__ => $self->_local_object_to_id($tied_to)}; } else { return [ map $self->_deobjectify($_), @$data ]; } } elsif ($ref eq 'CODE') { my $id = $self->_local_object_to_id( Object::Remote::CodeContainer->new(code => $data) ); return +{ __remote_code__ => $id }; } elsif ($ref eq 'SCALAR') { return +{ __scalar_ref__ => $$data }; } elsif ($ref eq 'GLOB') { return +{ __glob_ref__ => $self->_local_object_to_id( Object::Remote::GlobContainer->new(handle => $data) ) }; } else { die "Can't collapse reftype $ref"; } } return $data; # plain scalar } sub _receive { my ($self, $flat) = @_; Dlog_trace { my $l = length($flat); "Starting to deserialize $l characters of data for connection $_" } $self->_id; my ($type, @rest) = eval { @{$self->_deserialize($flat)} } or do { warn "Deserialize failed for ${flat}: $@"; return }; Dlog_trace { "deserialization complete for connection $_" } $self->_id; eval { $self->${\"receive_${type}"}(@rest); 1 } or do { warn "Receive failed for ${flat}: $@"; return }; return; } sub receive_free { my ($self, $id) = @_; Dlog_trace { "got a receive_free for object '$id' for connection $_" } $self->_id; delete $self->local_objects_by_id->{$id} or warn "Free: no such object $id"; return; } sub receive_call { my ($self, $future_id, $id, @rest) = @_; Dlog_trace { "got a receive_call for object '$id' for connection $_" } $self->_id; my $future = $self->_id_to_remote_object($future_id); $future->{method} = 'call_discard_free'; my $local = $self->local_objects_by_id->{$id} or do { $future->fail("No such object $id"); return }; $self->_invoke($future, $local, @rest); } sub receive_call_free { my ($self, $future, $id, @rest) = @_; Dlog_trace { "got a receive_call_free for object '$id' for connection $_" } $self->_id; $self->receive_call($future, $id, undef, @rest); $self->receive_free($id); } sub _invoke { my ($self, $future, $local, $ctx, $method, @args) = @_; Dlog_trace { "got _invoke for a method named '$method' for connection $_" } $self->_id; if ($method =~ /^start::/) { my $f = $local->$method(@args); $f->on_done(sub { undef($f); $future->done(@_) }); return unless $f; $f->on_fail(sub { undef($f); $future->fail(@_) }); return; } my $do = sub { $local->$method(@args) }; eval { $future->done( defined($ctx) ? ($ctx ? $do->() : scalar($do->())) : do { $do->(); () } ); 1; } or do { $future->fail($@); return; }; return; } 1; =head1 NAME Object::Remote::Connection - An underlying connection for L use Object::Remote; my $local = Object::Remote->connect('-'); my $remote = Object::Remote->connect('myserver'); my $remote_user = Object::Remote->connect('user@myserver'); my $local_sudo = Object::Remote->connect('user@'); #$remote can be any other connection object my $hostname = Sys::Hostname->can::on($remote, 'hostname'); =head1 DESCRIPTION This is the class that supports connections to remote objects. =head1 SEE ALSO =over 4 =item C =item C =back =cut Object-Remote-0.003006/lib/Object/Remote/GlobContainer.pm0000644000372100001440000000045712414033615022455 0ustar matthewtuserspackage Object::Remote::GlobContainer; use Moo; use FileHandle; has _handle => (is => 'ro', required => 1, init_arg => 'handle'); sub AUTOLOAD { my ($self, @args) = @_; (my $method) = our $AUTOLOAD =~ m{::([^:]+)$}; return if $method eq 'DESTROY'; return $self->_handle->$method(@args); } 1; Object-Remote-0.003006/lib/Object/Remote/Handle.pm0000644000372100001440000000530412414033615021116 0ustar matthewtuserspackage Object::Remote::Handle; use Object::Remote::Proxy; use Scalar::Util qw(weaken blessed); use Object::Remote::Logging qw ( :log :dlog router ); use Object::Remote::Future; use Module::Runtime qw(use_module); use Moo; BEGIN { router()->exclude_forwarding } has connection => ( is => 'ro', required => 1, handles => ['is_valid'], coerce => sub { blessed($_[0]) ? $_[0] : use_module('Object::Remote::Connection')->new_from_spec($_[0]) }, ); has id => (is => 'rwp'); has disarmed_free => (is => 'rwp'); sub disarm_free { $_[0]->_set_disarmed_free(1); $_[0] } sub proxy { bless({ remote => $_[0], method => 'call' }, 'Object::Remote::Proxy'); } sub BUILD { my ($self, $args) = @_; log_trace { "constructing remote handle" }; if ($self->id) { log_trace { "disarming free for this handle" }; $self->disarm_free; } else { die "No id supplied and no class either" unless $args->{class}; ref($_) eq 'HASH' and $_ = [ %$_ ] for $args->{args}; log_trace { "fetching id for handle and disarming free on remote side" }; $self->_set_id( await_future( $self->connection->send_class_call( 0, $args->{class}, $args->{constructor}||'new', @{$args->{args}||[]} ) )->{remote}->disarm_free->id ); } Dlog_trace { "finished constructing remote handle; id is $_" } $self->id; $self->connection->register_remote($self); } sub call { my ($self, $method, @args) = @_; my $w = wantarray; my $id = $self->id; $method = "start::${method}" if (caller(0)||'') eq 'start'; log_trace { "call('$method') has been invoked on remote handle '$id'; creating future" }; future { log_debug { "Invoking send on connection for handle '$id' method '$method'" }; $self->connection->send(call => $id, $w, $method, @args) }; } sub call_discard { my ($self, $method, @args) = @_; log_trace { "invoking send_discard() with 'call' for method '$method' on connection for remote handle" }; $self->connection->send_discard(call => $self->id, $method, @args); } sub call_discard_free { my ($self, $method, @args) = @_; $self->disarm_free; log_trace { "invoking send_discard() with 'call_free' for method '$method' on connection for remote handle" }; $self->connection->send_discard(call_free => $self->id, $method, @args); } sub DEMOLISH { my ($self, $gd) = @_; Dlog_trace { "Demolishing remote handle $_" } $self->id; return if $gd or $self->disarmed_free; #this could happen after the connection has gone away eval { $self->connection->send_free($self->id) }; if ($@ && $@ !~ m/^Attempt to invoke _send on a connection that is not valid/) { die "Could not invoke send_free on connection for handle " . $self->id; } } 1; Object-Remote-0.003006/lib/Object/Remote/Role/0000755000372100001440000000000012644534072020274 5ustar matthewtusersObject-Remote-0.003006/lib/Object/Remote/Role/Connector/0000755000372100001440000000000012644534072022226 5ustar matthewtusersObject-Remote-0.003006/lib/Object/Remote/Role/Connector/PerlInterpreter.pm0000644000372100001440000002631312414033615025707 0ustar matthewtuserspackage Object::Remote::Role::Connector::PerlInterpreter; use IPC::Open3; use IO::Handle; use Symbol; use Object::Remote::Logging qw(:log :dlog router); use Object::Remote::ModuleSender; use Object::Remote::Handle; use Object::Remote::Future; use Scalar::Util qw(blessed weaken); use Moo::Role; with 'Object::Remote::Role::Connector'; has module_sender => (is => 'lazy'); has watchdog_timeout => ( is => 'ro', required => 1, default => sub { undef }); has forward_env => (is => 'ro', required => 1, builder => 1); has perl_command => (is => 'lazy'); has pid => (is => 'rwp'); has connection_id => (is => 'rwp'); #if no child_stderr file handle is specified then stderr #of the child will be connected to stderr of the parent has stderr => ( is => 'rw', default => sub { undef } ); BEGIN { router()->exclude_forwarding; } sub _build_module_sender { my ($hook) = grep {blessed($_) && $_->isa('Object::Remote::ModuleLoader::Hook') } @INC; return $hook ? $hook->sender : Object::Remote::ModuleSender->new; } #By policy object-remote does not invoke a shell sub _build_perl_command { my $perl_bin = 'perl'; if (exists $ENV{OBJECT_REMOTE_PERL_BIN}) { $perl_bin = $ENV{OBJECT_REMOTE_PERL_BIN}; } return [$perl_bin, '-']; } sub _build_forward_env { return [qw( OBJECT_REMOTE_PERL_BIN OBJECT_REMOTE_LOG_LEVEL OBJECT_REMOTE_LOG_FORMAT OBJECT_REMOTE_LOG_SELECTIONS OBJECT_REMOTE_LOG_FORWARDING )]; } around connect => sub { my ($orig, $self) = (shift, shift); my $f = $self->$start::start($orig => @_); return future { $f->on_done(sub { my ($conn) = $f->get; $self->_setup_watchdog_reset($conn); my $sub = $conn->remote_sub('Object::Remote::Logging::init_remote_logging'); $sub->('Object::Remote::Logging', router => router(), connection_id => $conn->_id); Object::Remote::Handle->new( connection => $conn, class => 'Object::Remote::ModuleLoader', args => { module_sender => $self->module_sender } )->disarm_free; require Object::Remote::Prompt; Object::Remote::Prompt::maybe_set_prompt_command_on($conn); }); $f; } 2; }; sub final_perl_command { shift->perl_command } sub _start_perl { my $self = shift; my $given_stderr = $self->stderr; my $foreign_stderr; Dlog_verbose { s/\n/ /g; "invoking connection to perl interpreter using command line: $_" } @{$self->final_perl_command}; if (defined($given_stderr)) { #if the stderr data goes to an existing file handle #an anonymous file handle is required #as the other half of a pipe style file handle pair #so the file handles can go into the run loop $foreign_stderr = gensym(); } else { #if no file handle has been specified #for the child's stderr then connect #the child stderr to the parent stderr $foreign_stderr = ">&STDERR"; } my $pid = open3( my $foreign_stdin, my $foreign_stdout, $foreign_stderr, @{$self->final_perl_command}, ) or die "Failed to run perl at '$_[0]': $!"; $self->_set_pid($pid); if (defined($given_stderr)) { Dlog_debug { "Child process STDERR is being handled via run loop" }; Object::Remote->current_loop ->watch_io( handle => $foreign_stderr, on_read_ready => sub { my $buf = ''; my $len = sysread($foreign_stderr, $buf, 32768); if (!defined($len) or $len == 0) { log_trace { "Got EOF or error on child stderr, removing from watcher" }; $self->stderr(undef); Object::Remote->current_loop->unwatch_io( handle => $foreign_stderr, on_read_ready => 1 ); } else { Dlog_trace { "got $len characters of stderr data for connection" }; print $given_stderr $buf or die "could not send stderr data: $!"; } } ); } return ($foreign_stdin, $foreign_stdout, $pid); } sub _open2_for { my $self = shift; my ($foreign_stdin, $foreign_stdout, $pid) = $self->_start_perl(@_); my $to_send = $self->fatnode_text; log_debug { my $len = length($to_send); "Sending contents of fat node to remote node; size is '$len' characters" }; Object::Remote->current_loop ->watch_io( handle => $foreign_stdin, on_write_ready => sub { my $len = syswrite($foreign_stdin, $to_send, 32768); if (defined $len) { substr($to_send, 0, $len) = ''; } # if the stdin went away, we'll never get Shere # so it's not a big deal to simply give up on !defined if (!defined($len) or 0 == length($to_send)) { log_trace { "Got EOF or error when writing fatnode data to filehandle, unwatching it" }; Object::Remote->current_loop ->unwatch_io( handle => $foreign_stdin, on_write_ready => 1 ); } else { log_trace { "Sent $len bytes of fatnode data to remote side" }; } } ); return ($foreign_stdin, $foreign_stdout, $pid); } sub _setup_watchdog_reset { my ($self, $conn) = @_; my $timer_id; return unless $self->watchdog_timeout; Dlog_trace { "Creating Watchdog management timer for connection id $_" } $conn->_id; weaken($conn); $timer_id = Object::Remote->current_loop->watch_time( every => $self->watchdog_timeout / 3, code => sub { unless(defined($conn)) { log_warn { "Weak reference to connection in Watchdog was lost, terminating update timer $timer_id" }; Object::Remote->current_loop->unwatch_time($timer_id); return; } unless($conn->is_valid) { log_warn { "Watchdog timer found an invalid connection, removing the timer" }; Object::Remote->current_loop->unwatch_time($timer_id); return; } Dlog_trace { "Reseting Watchdog for connection id $_" } $conn->_id; #we do not want to block in the run loop so send the #update off and ignore any result, we don't need it #anyway $conn->send_class_call(0, 'Object::Remote::WatchDog', 'reset'); } ); $conn->on_close->on_ready(sub { log_debug { "Removing watchdog for connection that is now closed" }; Object::Remote->current_loop->unwatch_time($timer_id); }); } sub fatnode_text { my ($self) = @_; my $connection_timeout = $self->timeout; my $watchdog_timeout = $self->watchdog_timeout; my $text = ''; require Object::Remote::FatNode; if (defined($connection_timeout)) { $text .= "alarm($connection_timeout);\n"; } if (defined($watchdog_timeout)) { $text .= "my \$WATCHDOG_TIMEOUT = $watchdog_timeout;\n"; } else { $text .= "my \$WATCHDOG_TIMEOUT = undef;\n"; } $text .= $self->_create_env_forward(@{$self->forward_env}); #Action at a distance but at least it's not spooky - the logging #system needs to know if a node is remote but there is a period #during init where the remote connection information has not been #setup on the remote side yet so this flag allows a graceful #degredation to happen $text .= '$Object::Remote::FatNode::REMOTE_NODE = "1";' . "\n"; $text .= <<'END'; $INC{'Object/Remote/FatNode.pm'} = __FILE__; $Object::Remote::FatNode::DATA = <<'ENDFAT'; END $text .= do { no warnings 'once'; $Object::Remote::FatNode::DATA }; $text .= "ENDFAT\n"; $text .= <<'END'; eval $Object::Remote::FatNode::DATA; die $@ if $@; END $text .= "__END__\n"; return $text; } sub _create_env_forward { my ($self, @env_names) = @_; my $code = ''; foreach my $name (@env_names) { next unless exists $ENV{$name}; my $value = $ENV{$name}; $name =~ s/'/\\'/g; if(defined($value)) { $value =~ s/'/\\'/g; $value = "'$value'"; } else { $value = 'undef'; } $code .= "\$ENV{'$name'} = $value;\n"; } return $code; } 1; =head1 NAME Object::Remote::Role::Connector::PerlInterpreter - Role for connections to a Perl interpreter =head1 SYNOPSIS use Object::Remote; my %opts = ( perl_command => [qw(nice -n 10 perl -)], watchdog_timeout => 120, stderr => \*STDERR, ); my $local_connection = Object::Remote->connect('-', %opts); my $hostname = Sys::Hostname->can::on($remote, 'hostname'); =head1 DESCRIPTION This is the role that supports connections to a Perl interpreter that is executed in a different process. The new Perl interpreter can be either on the local or a remote machine and is configurable via arguments passed to the constructor. =head1 ARGUMENTS =over 4 =item perl_command By default the Perl interpeter will be executed as "perl -" but this can be changed by providing an array reference as the value to the perl_command attribute during construction. =item stderr If this value is defined then it will be used as the file handle that receives the output of STDERR from the Perl interpreter process and I/O will be performed by the run loop in a non-blocking way. If the value is undefined then STDERR of the remote process will be connected directly to STDERR of the local process with out the run loop managing I/O. The default value is undefined. There are a few ways to use this feature. By default the behavior is to form one unified STDERR across all of the Perl interpreters including the local one. For small scale and quick operation this offers a predictable and easy to use way to get at error messages generated anywhere. If the local Perl interpreter crashes then the remote Perl interpreters still have an active STDERR and it is possible to still receive output from them. This is generally a good thing but can cause issues. When using a file handle as the output for STDERR once the local Perl interpreter is no longer running there is no longer a valid STDERR for the remote interpreters to send data to. This means that it is no longer possible to receive error output from the remote interpreters and that the shell will start to kill off the child processes. Passing a reference to STDERR for the local interpreter (as the SYNOPSIS shows) causes the run loop to manage I/O, one unified STDERR for all Perl interpreters that ends as soon as the local interpreter process does, and the shell will start killing children when the local interpreter exits. It is also possible to pass in a file handle that has been opened for writing. This would be useful for logging the output of the remote interpreter directly into a dedicated file. =item watchdog_timeout If this value is defined then it will be used as the number of seconds the watchdog will wait for an update before it terminates the Perl interpreter process. The default value is undefined and will not use the watchdog. See C for more information. =back =head1 SEE ALSO =over 4 =item C =back =cut Object-Remote-0.003006/lib/Object/Remote/Role/LogForwarder.pm0000644000372100001440000000247712414033615023231 0ustar matthewtuserspackage Object::Remote::Role::LogForwarder; use Moo::Role; has enable_forward => ( is => 'rw', default => sub { 1 } ); has _forward_destination => ( is => 'rw' ); #lookup table for package names that should not #be forwarded across Object::Remote connections has _forward_stop => ( is => 'ro', required => 1, default => sub { {} } ); after _deliver_message => sub { # my ($self, $level, $generator, $args, $metadata) = @_; my ($self, %message_info) = @_; my $package = $message_info{caller_package}; my $destination = $self->_forward_destination; our $reentrant; if (defined $message_info{object_remote}) { $message_info{object_remote} = { %{$message_info{object_remote}} }; } $message_info{object_remote}->{forwarded} = 1; return unless $self->enable_forward; return unless defined $destination; return if $self->_forward_stop->{$package}; if (defined $reentrant) { warn "log forwarding went reentrant. bottom: '$reentrant' top: '$package'"; return; } local $reentrant = $package; eval { $destination->_deliver_message(%message_info) }; if ($@ && $@ !~ /^Attempt to use Object::Remote::Proxy backed by an invalid handle/) { die $@; } }; sub exclude_forwarding { my ($self, $package) = @_; $package = caller unless defined $package; $self->_forward_stop->{$package} = 1; } 1; Object-Remote-0.003006/lib/Object/Remote/Role/Connector.pm0000644000372100001440000000433312414033615022557 0ustar matthewtuserspackage Object::Remote::Role::Connector; use Module::Runtime qw(use_module); use Object::Remote::Future; use Object::Remote::Logging qw(:log :dlog router); use Moo::Role; requires '_open2_for'; has timeout => (is => 'ro', default => sub { 10 }); BEGIN { router()->exclude_forwarding; } sub connect { my $self = shift; Dlog_debug { "Preparing to create connection with args of: $_" } @_; my ($send_to_fh, $receive_from_fh, $child_pid) = $self->_open2_for(@_); my $channel = use_module('Object::Remote::ReadChannel')->new( fh => $receive_from_fh ); return future { log_trace { "Initializing connection for child pid '$child_pid'" }; my $f = shift; $channel->on_line_call(sub { if ($_[0] eq "Shere") { log_trace { "Received 'Shere' from child pid '$child_pid'; setting done handler to create connection" }; $f->done( use_module('Object::Remote::Connection')->new( send_to_fh => $send_to_fh, read_channel => $channel, child_pid => $child_pid, ) ); } else { log_warn { "'Shere' was not found in connection data for child pid '$child_pid'" }; $f->fail("Expected Shere from remote but received: $_[0]"); } undef($channel); }); $channel->on_close_call(sub { log_trace { "Connection has been closed" }; $f->fail("Channel closed without seeing Shere: $_[0]"); undef($channel); }); log_trace { "initialized events on channel for child pid '$child_pid'; creating timeout" }; Object::Remote->current_loop ->watch_time( after => $self->timeout, code => sub { Dlog_trace {"Connection timeout timer has fired for child pid '$child_pid'; is_ready: $_" } $f->is_ready; unless($f->is_ready) { log_warn { "Connection with child pid '$child_pid' has timed out" }; $f->fail("Connection timed out") unless $f->is_ready; } undef($channel); } ); log_trace { "connection for child pid '$child_pid' has been initialized" }; $f; } } 1; Object-Remote-0.003006/lib/Object/Remote/Null.pm0000644000372100001440000000010512414033615020627 0ustar matthewtuserspackage Object::Remote::Null; sub AUTOLOAD { } sub DESTROY { } 1; Object-Remote-0.003006/lib/Object/Remote/Prompt.pm0000644000372100001440000000236212414033615021205 0ustar matthewtuserspackage Object::Remote::Prompt; use strictures 1; use IO::Handle; use Exporter; our @EXPORT = qw(prompt prompt_pw); our ($prompt, $prompt_pw); sub _local_prompt { _local_prompt_core(0, @_); } sub _local_prompt_pw { _local_prompt_core(1, @_); } our %Prompt_Cache; sub _local_prompt_core { my ($pw, $message, $default, $opts) = @_; if ($opts->{cache} and my $hit = $Prompt_Cache{$message}) { return $hit; } STDOUT->autoflush(1); system('stty -echo') if $pw; print STDOUT "${message}: "; chomp(my $res = ); print STDOUT "\n" if $pw; system('stty echo') if $pw; $Prompt_Cache{$message} = $res if $opts->{cache}; return $res; } sub prompt { die "User input wanted - $_[0] - but no prompt available" unless $prompt; goto &$prompt; } sub prompt_pw { die "User input wanted - $_[0] - but no password prompt available" unless $prompt_pw; goto &$prompt_pw; } if (-t STDIN) { $prompt = \&_local_prompt; $prompt_pw = \&_local_prompt_pw; } sub set_local_prompt_command { ($prompt, $prompt_pw) = @_; return; } sub maybe_set_prompt_command_on { return unless $prompt; my ($conn) = @_; $conn->remote_sub('Object::Remote::Prompt::set_local_prompt_command') ->($prompt, $prompt_pw); } 1; Object-Remote-0.003006/lib/Object/Remote/FatNode.pm0000644000372100001440000000765112552473243021262 0ustar matthewtuserspackage Object::Remote::FatNode; use strictures 1; use Config; use B qw(perlstring); my @exclude_mods = qw(XSLoader.pm DynaLoader.pm); #used by t/watchdog_fatnode our $INHIBIT_RUN_NODE = 0; sub stripspace { my ($text) = @_; $text =~ /^(\s+)/ && $text =~ s/^$1//mg; $text; } my %maybe_libs = map +($_ => 1), grep defined, (values %Config, '.'); my @extra_libs = grep not(ref($_) or $maybe_libs{$_}), @INC; my $extra_libs = join '', map { my $lib = $_; $lib =~ s{'}{'\\''}g; " -I'$lib'\n"; } @extra_libs; my $command = qq( $^X $extra_libs -mObject::Remote -mObject::Remote::Connector::STDIO -mFuture -mMRO::Compat -mClass::C3 -mClass::C3::next -mAlgorithm::C3 -mObject::Remote::ModuleLoader -mObject::Remote::Node -mMethod::Generate::BuildAll -mMethod::Generate::DemolishAll -mMoo::HandleMoose::_TypeMap -mJSON::PP -e 'print join "\\n", \%INC' ); $command =~ s/\n/ /g; chomp(my @inc = qx($command)); my %exclude = map { $_ => 1 } @exclude_mods; my %file_names = @inc; # only include mods that match the filename, # ie ones that will succeed with a require $module # https://rt.cpan.org/Ticket/Display.html?id=100478 my %mods = map { $file_names{$_} => $_ } grep { $file_names{$_} =~ /\Q$_\E$/ } keys %file_names; foreach(keys(%mods)) { if ($exclude{ $mods{$_} }) { delete($mods{$_}); } } my @non_core_non_arch = ( $file_names{'Devel/GlobalDestruction.pm'} ); push @non_core_non_arch, grep +( not ( #some of the config variables can be empty which will eval as a matching regex $Config{privlibexp} ne '' && /^\Q$Config{privlibexp}/ or $Config{archlibexp} ne '' && /^\Q$Config{archlibexp}/ or $Config{vendorarchexp} ne '' && /^\Q$Config{vendorarchexp}/ or $Config{sitearchexp} ne '' && /^\Q$Config{sitearchexp}/ ) ), grep !/\Q$Config{archname}/, grep !/\Q$Config{myarchname}/, keys %mods; my @core_non_arch = grep +( $Config{privlibexp} ne '' && /^\Q$Config{privlibexp}/ and not($Config{archlibexp} ne '' && /^\Q$Config{archlibexp}/ or /\Q$Config{archname}/ or /\Q$Config{myarchname}/) ), keys %mods; my $start = stripspace <<'END_START'; # This chunk of stuff was generated by Object::Remote::FatNode. To find # the original file's code, look for the end of this BEGIN block or the # string 'FATPACK' BEGIN { my (%fatpacked,%fatpacked_extra); END_START $start .= 'my %exclude = map { $_ => 1 } (\'' . join("','", @exclude_mods) . "');\n"; my $end = stripspace <<'END_END'; s/^ //mg for values %fatpacked, values %fatpacked_extra; sub load_from_hash { if (my $fat = $_[0]->{$_[1]}) { if ($exclude{$_[1]}) { warn "Will not pre-load '$_[1]'"; return undef; } #warn "Handling $_[1]"; open my $fh, '<', \$fat; return $fh; } #Uncomment this to find brokenness #warn "Missing $_[1]"; return; } unshift @INC, sub { load_from_hash(\%fatpacked, $_[1]) }; push @INC, sub { load_from_hash(\%fatpacked_extra, $_[1]) }; } # END OF FATPACK CODE use strictures 1; use Object::Remote::Node; unless ($Object::Remote::FatNode::INHIBIT_RUN_NODE) { Object::Remote::Node->run(watchdog_timeout => $WATCHDOG_TIMEOUT); } END_END my %files = map +($mods{$_} => scalar do { local (@ARGV, $/) = ($_); <> }), @non_core_non_arch, @core_non_arch; sub generate_fatpack_hash { my ($hash_name, $orig) = @_; (my $stub = $orig) =~ s/\.pm$//; my $name = uc join '_', split '/', $stub; my $data = $files{$orig} or die $orig; $data =~ s/^/ /mg; $data .= "\n" unless $data =~ m/\n$/; my $ret = '$'.$hash_name.'{'.perlstring($orig).qq!} = <<'${name}';\n! .qq!${data}${name}\n!; # warn $ret; return $ret; } my @segments = ( map(generate_fatpack_hash('fatpacked', $_), sort map $mods{$_}, @non_core_non_arch), map(generate_fatpack_hash('fatpacked_extra', $_), sort map $mods{$_}, @core_non_arch), ); #print STDERR Dumper(\@segments); our $DATA = join "\n", $start, @segments, $end; 1; Object-Remote-0.003006/lib/Object/Remote/ReadChannel.pm0000644000372100001440000000345412414033615022073 0ustar matthewtuserspackage Object::Remote::ReadChannel; use Scalar::Util qw(weaken openhandle); use Object::Remote::Logging qw(:log :dlog router ); use Moo; BEGIN { router()->exclude_forwarding } has fh => ( is => 'ro', required => 1, trigger => sub { my ($self, $fh) = @_; weaken($self); log_trace { "Watching filehandle via trigger on 'fh' attribute in Object::Remote::ReadChannel" }; Object::Remote->current_loop ->watch_io( handle => $fh, on_read_ready => sub { $self->_receive_data_from($fh) } ); }, ); has on_close_call => ( is => 'rw', default => sub { sub {} }, ); has on_line_call => (is => 'rw'); has _receive_data_buffer => (is => 'ro', default => sub { my $x = ''; \$x }); sub _receive_data_from { my ($self, $fh) = @_; Dlog_trace { "Preparing to read data from $_" } $fh; my $rb = $self->_receive_data_buffer; my $len = sysread($fh, $$rb, 32768, length($$rb)); my $err = defined($len) ? 'eof' : ": $!"; if (defined($len) and $len > 0) { log_trace { "Read $len bytes of data" }; while (my $cb = $self->on_line_call and $$rb =~ s/^(.*)\n//) { $cb->(my $line = $1); } } else { log_trace { "Got EOF or error, this read channel is done" }; Object::Remote->current_loop ->unwatch_io( handle => $self->fh, on_read_ready => 1 ); log_trace { "Invoking on_close_call() for dead read channel" }; $self->on_close_call->($err); } } sub DEMOLISH { my ($self, $gd) = @_; return if $gd; log_trace { "read channel is being demolished" }; Object::Remote->current_loop ->unwatch_io( handle => $self->fh, on_read_ready => 1 ); } 1; Object-Remote-0.003006/lib/Object/Remote/MiniLoop.pm0000644000372100001440000001532412414033615021454 0ustar matthewtuserspackage Object::Remote::MiniLoop; use IO::Select; use Time::HiRes qw(time); use Object::Remote::Logging qw( :log :dlog router ); use Moo; BEGIN { $SIG{PIPE} = sub { log_debug { "Got a PIPE signal" } }; router()->exclude_forwarding } # this is ro because we only actually set it using local in sub run has is_running => (is => 'ro', clearer => 'stop'); #maximum duration that select() will block - undef means indefinite, #0 means no blocking, otherwise maximum time in seconds has block_duration => ( is => 'rw' ); has _read_watches => (is => 'ro', default => sub { {} }); has _read_select => (is => 'ro', default => sub { IO::Select->new }); has _write_watches => (is => 'ro', default => sub { {} }); has _write_select => (is => 'ro', default => sub { IO::Select->new }); has _timers => (is => 'ro', default => sub { [] }); sub pass_watches_to { my ($self, $new_loop) = @_; log_debug { "passing watches to new run loop" }; foreach my $fh ($self->_read_select->handles) { $new_loop->watch_io( handle => $fh, on_read_ready => $self->_read_watches->{$fh} ); } foreach my $fh ($self->_write_select->handles) { $new_loop->watch_io( handle => $fh, on_write_ready => $self->_write_watches->{$fh} ); } } sub watch_io { my ($self, %watch) = @_; my $fh = $watch{handle}; Dlog_debug { "Adding IO watch for $_" } $fh; if (my $cb = $watch{on_read_ready}) { log_trace { "IO watcher is registering with select for reading" }; $self->_read_select->add($fh); $self->_read_watches->{$fh} = $cb; } if (my $cb = $watch{on_write_ready}) { log_trace { "IO watcher is registering with select for writing" }; $self->_write_select->add($fh); $self->_write_watches->{$fh} = $cb; } return; } sub unwatch_io { my ($self, %watch) = @_; my $fh = $watch{handle}; Dlog_debug { "Removing IO watch for $_" } $fh; if ($watch{on_read_ready}) { log_trace { "IO watcher is removing read from select()" }; $self->_read_select->remove($fh); delete $self->_read_watches->{$fh}; } if ($watch{on_write_ready}) { log_trace { "IO watcher is removing write from select()" }; $self->_write_select->remove($fh); delete $self->_write_watches->{$fh}; } return; } sub _sort_timers { my ($self, @new) = @_; my $timers = $self->_timers; log_trace { "Sorting timers" }; @{$timers} = sort { $a->[0] <=> $b->[0] } @{$timers}, @new; return; } sub watch_time { my ($self, %watch) = @_; my $at; Dlog_trace { "watch_time() invoked with $_" } \%watch; if (exists($watch{every})) { $at = time() + $watch{every}; } elsif (exists($watch{after})) { $at = time() + $watch{after}; } elsif (exists($watch{at})) { $at = $watch{at}; } else { die "watch_time requires every, after or at"; } die "watch_time requires code" unless my $code = $watch{code}; my $timers = $self->_timers; my $new = [ $at => $code, $watch{every} ]; $self->_sort_timers($new); log_debug { "Created new timer with id '$new' that expires at '$at'" }; return "$new"; } sub unwatch_time { my ($self, $id) = @_; log_trace { "Removing timer with id of '$id'" }; @$_ = grep !($_ eq $id), @$_ for $self->_timers; return; } sub _next_timer_expires_delay { my ($self) = @_; my $timers = $self->_timers; my $delay_max = $self->block_duration; return $delay_max unless @$timers; my $duration = $timers->[0]->[0] - time; log_trace { "next timer fires in '$duration' seconds" }; if ($duration < 0) { $duration = 0; } elsif (defined $delay_max && $duration > $delay_max) { $duration = $delay_max; } return $duration; } sub loop_once { my ($self) = @_; my $read = $self->_read_watches; my $write = $self->_write_watches; my $read_count = 0; my $write_count = 0; my @c = caller; my $wait_time = $self->_next_timer_expires_delay; log_trace { sprintf("Run loop: loop_once() has been invoked by $c[1]:$c[2] with read:%i write:%i select timeout:%s", scalar(keys(%$read)), scalar(keys(%$write)), defined $wait_time ? $wait_time : 'indefinite' ) }; my ($readable, $writeable) = IO::Select->select( $self->_read_select, $self->_write_select, undef, $wait_time ); log_trace { my $readable_count = defined $readable ? scalar(@$readable) : 0; my $writable_count = defined $writeable ? scalar(@$writeable) : 0; "Run loop: select returned readable:$readable_count writeable:$writable_count"; }; # I would love to trap errors in the select call but IO::Select doesn't # differentiate between an error and a timeout. # -- no, love, mst. log_trace { "Reading from ready filehandles" }; foreach my $fh (@$readable) { next unless $read->{$fh}; $read_count++; $read->{$fh}(); #FIXME this is a rough workaround for race conditions that can cause deadlocks #under load last; } log_trace { "Writing to ready filehandles" }; foreach my $fh (@$writeable) { next unless $write->{$fh}; $write_count++; $write->{$fh}(); #FIXME this is a rough workaround for race conditions that can cause deadlocks #under load last; } #moving the timers above the read() section exposes a deadlock log_trace { "Read from $read_count filehandles; wrote to $write_count filehandles" }; my $timers = $self->_timers; my $now = time(); log_trace { "Checking timers" }; while (@$timers and $timers->[0][0] <= $now) { my $active = $timers->[0]; Dlog_trace { "Found timer that needs to be executed: '$active'" }; if (defined($active->[2])) { #handle the case of an 'every' timer $active->[0] = time() + $active->[2]; Dlog_trace { "scheduling timer for repeat execution at $_"} $active->[0]; $self->_sort_timers; } else { #it doesn't repeat again so get rid of it shift(@$timers); } #execute the timer $active->[1]->(); } log_trace { "Run loop: single loop is completed" }; return; } sub want_run { my ($self) = @_; Dlog_debug { "Run loop: Incremeting want_running, is now $_" } ++$self->{want_running}; } sub run_while_wanted { my ($self) = @_; log_debug { my $wr = $self->{want_running}; "Run loop: run_while_wanted() invoked; want_running: $wr" }; $self->loop_once while $self->{want_running}; log_debug { "Run loop: run_while_wanted() completed" }; return; } sub want_stop { my ($self) = @_; if (! $self->{want_running}) { log_debug { "Run loop: want_stop() was called but want_running was not true" }; return; } Dlog_debug { "Run loop: decrimenting want_running, is now $_" } --$self->{want_running}; } sub run { my ($self) = @_; log_trace { "Run loop: run() invoked" }; local $self->{is_running} = 1; while ($self->is_running) { $self->loop_once; } log_trace { "Run loop: run() completed" }; return; } 1; Object-Remote-0.003006/lib/Object/Remote/Proxy.pm0000644000372100001440000000070512414033615021044 0ustar matthewtuserspackage Object::Remote::Proxy; use strictures 1; use Carp qw(croak); sub AUTOLOAD { my $self = shift; (my $method) = (our $AUTOLOAD =~ /([^:]+)$/); my $to_fire = $self->{method}; if ((caller(0)||'') eq 'start') { $to_fire = "start::${to_fire}"; } unless ($self->{remote}->is_valid) { croak "Attempt to use Object::Remote::Proxy backed by an invalid handle"; } $self->{remote}->$to_fire($method => @_); } sub DESTROY { } 1; Object-Remote-0.003006/lib/Object/Remote/ModuleLoader.pm0000644000372100001440000000462612644533204022311 0ustar matthewtuserspackage Object::Remote::ModuleLoader; BEGIN { package Object::Remote::ModuleLoader::Hook; use Moo; use Object::Remote::Logging qw( :log :dlog ); has sender => (is => 'ro', required => 1); # unqualified INC forced into package main sub Object::Remote::ModuleLoader::Hook::INC { my ($self, $module) = @_; log_debug { "Loading $module via " . ref($self) }; my $ret = eval { if (my $code = $self->sender->source_for($module)) { open my $fh, '<', \$code; Dlog_trace { "Module sender successfully sent code for '$module': $code" } $code; return $fh; } log_trace { "Module sender did not return code for '$module'" }; return; }; if ($@) { log_trace { "Module sender blew up - $@" }; if ($@ =~ /Can't locate/) { # Fudge the error messge to make it work with # Module::Runtime use_package_optimistically # Module::Runtime wants - /\ACan't locate \Q$fn\E .+ at \Q@{[__FILE__]}\E line/ # We could probably measure and hard-code this but that could easily # be a forwards compatibility disaster, so do a quick search of caller # with a reasonable range; we're already into a woefully inefficient # situation here so a little defensiveness won't make things much worse foreach my $i (4..20) { my ($package, $file, $line) = caller($i); last unless $package; if ($package eq 'Module::Runtime') { # we want to fill in the error message with the # module runtime module call info. $@ =~ s/(in \@INC.)/$1 at $file line $line/; last; } } } die $@; } return $ret; } } use Moo; use Object::Remote::Logging qw( :log ); has module_sender => (is => 'ro', required => 1); has inc_hook => (is => 'lazy'); sub _build_inc_hook { my ($self) = @_; log_debug { "Constructing module builder hook" }; my $hook = Object::Remote::ModuleLoader::Hook->new(sender => $self->module_sender); log_trace { "Done constructing module builder hook" }; return $hook; } sub BUILD { shift->enable } sub enable { log_debug { "enabling module loader hook" }; push @INC, shift->inc_hook; return; } sub disable { my ($self) = @_; log_debug { "disabling module loader hook" }; my $hook = $self->inc_hook; @INC = grep $_ ne $hook, @INC; return; } sub DEMOLISH { $_[0]->disable unless $_[1] } 1; Object-Remote-0.003006/lib/Object/Remote/Future.pm0000644000372100001440000000506412414033615021200 0ustar matthewtuserspackage Object::Remote::Future; use strict; use warnings; use base qw(Exporter); use Object::Remote::Logging qw( :log router ); BEGIN { router()->exclude_forwarding } use Future; our @EXPORT = qw(future await_future await_all); sub future (&;$) { my $f = $_[0]->(Future->new); return $f if ((caller(1+($_[1]||0))||'') eq 'start'); await_future($f); } our @await; sub await_future { my $f = shift; log_trace { my $ir = $f->is_ready; "await_future() invoked; is_ready: $ir" }; return $f if $f->is_ready; require Object::Remote; my $loop = Object::Remote->current_loop; { local @await = (@await, $f); $f->on_ready(sub { log_trace { my $l = @await; "future has become ready, length of \@await: '$l'" }; if ($f == $await[-1]) { log_trace { "This future is not waiting on anything so calling stop on the run loop" }; $loop->stop; } }); log_trace { "Starting run loop for newly created future" }; $loop->run; } if (@await and $await[-1]->is_ready) { log_trace { "Last future in await list was ready, stopping run loop" }; $loop->stop; } log_trace { "await_future() returning" }; return wantarray ? $f->get : ($f->get)[0]; } sub await_all { log_trace { my $l = @_; "await_all() invoked with '$l' futures to wait on" }; await_future(Future->wait_all(@_)); map $_->get, @_; } package start; our $start = sub { my ($obj, $call) = (shift, shift); $obj->$call(@_); }; sub AUTOLOAD { my $invocant = shift; my ($method) = our $AUTOLOAD =~ /^start::(.+)$/; my $res; unless (eval { $res = $invocant->$method(@_); 1 }) { my $f = Future->new; $f->fail($@); return $f; } unless (Scalar::Util::blessed($res) and $res->isa('Future')) { my $f = Future->new; $f->done($res); return $f; } return $res; } package maybe; sub start { my ($obj, $call) = (shift, shift); if ((caller(1)||'') eq 'start') { $obj->$start::start($call => @_); } else { $obj->$call(@_); } } package maybe::start; sub AUTOLOAD { my $invocant = shift; my ($method) = our $AUTOLOAD =~ /^maybe::start::(.+)$/; $method = "start::${method}" if ((caller(1)||'') eq 'start'); $invocant->$method(@_); } package then; sub AUTOLOAD { my $invocant = shift; my ($method) = our $AUTOLOAD =~ /^then::(.+)$/; my @args = @_; return $invocant->then(sub { my ($obj) = @_; return $obj->${\"start::${method}"}(@args); }); } 1; =head1 NAME Object::Remote::Future - Asynchronous calling for L =head1 LAME Shipping prioritised over writing this part up. Blame mst. =cut Object-Remote-0.003006/lib/Object/Remote/Node.pm0000644000372100001440000000231712414033615020611 0ustar matthewtuserspackage Object::Remote::Node; use strictures 1; use Object::Remote::Connector::STDIO; use Object::Remote::Logging qw(:log :dlog); use Object::Remote::WatchDog; use Object::Remote; sub run { my ($class, %args) = @_; log_trace { "run() has been invoked on remote node" }; my $c = Object::Remote::Connector::STDIO->new->connect; $c->register_class_call_handler; my $loop = Object::Remote->current_loop; $c->on_close->on_ready(sub { log_debug { "Node connection with call handler has closed" }; $loop->want_stop }); Dlog_trace { "Node is sending 'Shere' to $_" } $c->send_to_fh; print { $c->send_to_fh } "Shere\n"; log_debug { "Node is going to start the run loop" }; #TODO the alarm should be reset after the run loop starts #at a minimum - the remote side node should probably send #a command that clears the alarm in all instances - even #if the Object::Remote::Watchdog is not being used if ($args{watchdog_timeout}) { Object::Remote::WatchDog->instance(timeout => $args{watchdog_timeout}); } else { #reset connection watchdog from the fatnode alarm(0); } $loop->want_run; $loop->run_while_wanted; log_debug { "Run loop invocation in node has completed" }; } 1; Object-Remote-0.003006/lib/Object/Remote/WatchDog.pm0000644000372100001440000000255512414033615021430 0ustar matthewtuserspackage Object::Remote::WatchDog; use Object::Remote::MiniLoop; use Object::Remote::Logging qw (:log :dlog router); use Moo; has timeout => ( is => 'ro', required => 1 ); BEGIN { router()->exclude_forwarding; } sub instance { my ($class, @args) = @_; return our $WATCHDOG ||= do { log_trace { "Constructing new instance of global watchdog" }; $class->new(@args); }; }; #start the watchdog sub BUILD { my ($self) = @_; $SIG{ALRM} = sub { #if the Watchdog is killing the process we don't want any chance of the #process not actually exiting and die could be caught by an eval which #doesn't do us any good log_fatal { "Watchdog has expired, terminating the process" }; exit(1); }; Dlog_debug { "Initializing watchdog with timeout of $_ seconds" } $self->timeout; alarm($self->timeout); } #invoke at least once per timeout to stop #the watchdog from killing the process sub reset { die "Attempt to reset the watchdog before it was constructed" unless defined our $WATCHDOG; log_debug { "Watchdog has been reset" }; alarm($WATCHDOG->timeout); } #must explicitly call this method to stop the #watchdog from killing the process - if the #watchdog is lost because it goes out of scope #it makes sense to still terminate the process sub shutdown { my ($self) = @_; log_debug { "Watchdog is shutting down" }; alarm(0); } 1; Object-Remote-0.003006/lib/Object/Remote/Logging/0000755000372100001440000000000012644534072020761 5ustar matthewtusersObject-Remote-0.003006/lib/Object/Remote/Logging/LogAnyInjector.pm0000644000372100001440000000303112414033615024173 0ustar matthewtuserspackage Object::Remote::Logging::LogAnyInjector; #Experimental object that can be used to receive Log::Any #generated log messages and inject them into the log router use Moo; use Object::Remote::Logging qw( router ); use Carp qw(croak); BEGIN { our %LEVEL_NAME_MAP = ( #key is Log::Any log level name or alias and value is Object::Remote::Logging #log level name trace => 'trace', debug => 'debug', info => 'info', notice => 'verbose', warning => 'warn', error => 'error', fatal => 'fatal', critical => 'error', alert => 'error', 'emergency' => 'error', inform => 'info', warn => 'warn', err => 'error', crit => 'error', ); } sub AUTOLOAD { my ($self, @content) = @_; (my $log_level) = (our $AUTOLOAD =~ /([^:]+)$/); my $generator; my $log_contextual_level; our %LEVEL_NAME_MAP; #just a proof of concept - support for the is_ methods can #be done but requires modifications to the router return 1 if $log_level =~ m/^is_/; #skip DESTROY and friends return if $log_level =~ m/^[A-Z]+$/; if ($log_contextual_level = $LEVEL_NAME_MAP{$log_level}) { $generator = sub { @content }; } elsif(($log_level =~ s/f$//) && ($log_contextual_level = $LEVEL_NAME_MAP{$log_level})) { my $format = shift(@content); $generator = sub { sprintf($format, @content) }; } else { croak "invalid log level: $log_level"; } router->handle_log_request({ controller => 'Log::Any', package => scalar(caller), caller_level => 1, level => $log_contextual_level, }, $generator); return; } 1; Object-Remote-0.003006/lib/Object/Remote/Logging/Router.pm0000644000372100001440000000651612414033615022577 0ustar matthewtuserspackage Object::Remote::Logging::Router; use Moo; use Scalar::Util qw(weaken); use Sys::Hostname; with 'Log::Contextual::Role::Router'; with 'Object::Remote::Role::LogForwarder'; has _connections => ( is => 'ro', required => 1, default => sub { [] } ); has _remote_metadata => ( is => 'rw' ); sub before_import { } sub after_import { } sub _get_loggers { my ($self, %metadata) = @_; my $package = $metadata{caller_package}; my $level = $metadata{message_level}; my $is_level = "is_$level"; my $need_clean = 0; my @loggers; foreach my $selector (@{$self->_connections}) { unless(defined $selector) { $need_clean = 1; next; } foreach my $logger ($selector->($package, { %metadata })) { next unless defined $logger; next unless $logger->$is_level; push(@loggers, $logger); } } $self->_clean_connections if $need_clean; return @loggers; } #overloadable so a router can invoke a logger #in a different way sub _invoke_logger { my ($self, $logger, $level_name, $content, $metadata) = @_; #Invoking the logger like this gets all available data to the #logging object with out losing any information from the datastructure. #This is not a backwards compatible way to invoke the loggers #but it enables a lot of flexibility in the logger. #The l-c router could have this method invoke the logger in #a backwards compatible way and router sub classes invoke #it in non-backwards compatible ways if desired $logger->$level_name($content, $metadata); } #overloadable so forwarding can have the updated #metadata but does not have to wrap get_loggers #which has too many drawbacks sub _deliver_message { my ($self, %message_info) = @_; my @loggers = $self->_get_loggers(%message_info); my $generator = $message_info{message_sub}; my $args = $message_info{message_args}; my $level = $message_info{message_level}; return unless @loggers > 0; #this is the point where the user provided log message code block is executed my @content = $generator->(@$args); foreach my $logger (@loggers) { $self->_invoke_logger($logger, $level, \@content, \%message_info); } } sub handle_log_request { my ($self, %message_info) = @_; my $level = $message_info{message_level}; my $package = $message_info{caller_package}; my $need_clean = 0; #caller_level is useless when log forwarding is in place #so we won't tempt people with using it my $caller_level = delete $message_info{caller_level}; $message_info{object_remote} = $self->_remote_metadata; $message_info{timestamp} = time; $message_info{pid} = $$; $message_info{hostname} = hostname; my @caller_info = caller($caller_level); $message_info{filename} = $caller_info[1]; $message_info{line} = $caller_info[2]; @caller_info = caller($caller_level + 1); $message_info{method} = $caller_info[3]; $message_info{method} =~ s/^${package}::// if defined $message_info{method}; $self->_deliver_message(%message_info); } sub connect { my ($self, $destination, $is_weak) = @_; my $wrapped; if (ref($destination) ne 'CODE') { $wrapped = sub { $destination }; } else { $wrapped = $destination; } push(@{$self->_connections}, $wrapped); weaken($self->_connections->[-1]) if $is_weak; } sub _clean_connections { my ($self) = @_; @{$self->{_connections}} = grep { defined } @{$self->{_connections}}; } 1; Object-Remote-0.003006/lib/Object/Remote/Logging/Logger.pm0000644000372100001440000002037712414033615022537 0ustar matthewtuserspackage Object::Remote::Logging::Logger; use Moo; use Carp qw(croak); #TODO sigh invoking a logger with a log level name the same #as an attribute could happen - restrict attributes to _ prefix #and restrict log levels to not start with out that prefix? has format => ( is => 'ro', required => 1, default => sub { '%l: %s' } ); has level_names => ( is => 'ro', required => 1 ); has min_level => ( is => 'ro', required => 1, default => sub { 'info' } ); has max_level => ( is => 'lazy', required => 1 ); has _level_active => ( is => 'lazy' ); #just a stub so it doesn't get to AUTOLOAD sub BUILD { } sub DESTROY { } sub AUTOLOAD { my $self = shift; (my $method) = (our $AUTOLOAD =~ /([^:]+)$/); no strict 'refs'; if ($method =~ m/^_/) { croak "invalid method name $method for " . ref($self); } if ($method =~ m/^is_(.+)/) { my $level_name = $1; my $is_method = "is_$level_name"; *{$is_method} = sub { shift(@_)->_level_active->{$level_name} }; return $self->$is_method; } my $level_name = $method; *{$level_name} = sub { my $self = shift; unless(exists($self->_level_active->{$level_name})) { croak "$level_name is not a valid log level name"; } $self->_log($level_name, @_); }; return $self->$level_name(@_); } sub _build_max_level { my ($self) = @_; return $self->level_names->[-1]; } sub _build__level_active { my ($self) = @_; my $should_log = 0; my $min_level = $self->min_level; my $max_level = $self->max_level; my %active; foreach my $level (@{$self->level_names}) { if($level eq $min_level) { $should_log = 1; } $active{$level} = $should_log; if (defined $max_level && $level eq $max_level) { $should_log = 0; } } return \%active; } sub _log { my ($self, $level, $content, $metadata_in) = @_; my %metadata = %$metadata_in; my $rendered = $self->_render($level, \%metadata, @$content); $self->_output($rendered); } sub _create_format_lookup { my ($self, $level, $metadata, $content) = @_; my $method = $metadata->{method}; $method = '(none)' unless defined $method; return { '%' => '%', 'n' => "\n", t => $self->_render_time($metadata->{timestamp}), r => $self->_render_remote($metadata->{object_remote}), s => $self->_render_log(@$content), l => $level, c => $metadata->{exporter}, p => $metadata->{caller_package}, m => $method, f => $metadata->{filename}, i => $metadata->{line}, h => $metadata->{hostname}, P => $metadata->{pid}, }; } sub _get_format_var_value { my ($self, $name, $data) = @_; my $val = $data->{$name}; return $val if defined $val; return '(undefined)'; } sub _render_time { my ($self, $time) = @_; return scalar(localtime($time)); } sub _render_remote { my ($self, $remote) = @_; return 'local' unless defined $remote; my $conn_id = $remote->{connection_id}; $conn_id = '(uninit)' unless defined $conn_id; return "remote #$conn_id"; } sub _render_log { my ($self, @content) = @_; return join('', @content); } sub _render { my ($self, $level, $metadata, @content) = @_; my $var_table = $self->_create_format_lookup($level, $metadata, [@content]); my $template = $self->format; $template =~ s/%([\w%])/$self->_get_format_var_value($1, $var_table)/ge; chomp($template); $template =~ s/\n/\n /g; $template .= "\n"; return $template; } sub _output { my ($self, $content) = @_; print STDERR $content; } 1; __END__ =head1 NAME Object::Remote::Logging::Logger - Format and output a log message =head1 SYNOPSIS use Object::Remote::Logging::Logger; use Object::Remote::Logging qw( router arg_levels ); my $app_output = Object::Remote::Logging::Logger->new( level_names => arg_levels, format => '%t %s', min_level => 'verbose', max_level => 'info', ); #Selector method can return 0 or more logger #objects that will receive the messages my $selector = sub { my ($generating_package, $metadata) = @_; return unless $metadata->{exporter} eq 'App::Logging::Subclass'; return $app_output; }; #true value as second argument causes the selector #to be stored with a weak reference router->connect($selector, 1); #disconnect the selector from the router undef($selector); #router will hold this logger forever #and send it all log messages router->connect(Object::Remote::Logging::Logger->new( level_names => arg_levels, format => '%s at %f line %i, log level: %l' min_level => 'warn', max_level => 'error', )); =head1 DESCRIPTION This class receives log messages from an instance of L, formats them according to configuration, and then outputs them to STDERR. In between the router and the logger is a selector method which inspects the log message metadata and can return 0 or more loggers that should receive the log message. =head1 USAGE A logger object receives the log messages that are generated and converts them to formatted log entries then displays them to the end user. Each logger has a set of active log levels and will only output a log entry if the log message is at an active log level. To gain access to the stream of log messages a connection is made to the log router. A logger can directly connect to the router and receive an unfiltered stream of log messages or a selector closure can be used instead. The selector will be executed for each log message with the message metadata and returns a list of 0 or more loggers that should receive the log message. When the selector is executed the first argument is the name of the package that generated the log message and the second argument is a hash reference containing the message metadata. =head1 METADATA The message metadata is a hash reference with the following keys: =over 4 =item message_level Name of the log level of the message. =item exporter Package name of the logging API that was used to generate the log message. =item caller_package Name of the package that generated the log message. =item method Name of the method the message was generated inside of. =item timestamp Unix time of the message generation. =item pid Process id of the Perl interpreter the message was generated in. =item hostname Hostname of the system where the message was generated. =item filename Name of the file the message was generated in. =item line Line of the source file the message was generated at. =item object_remote This is a reference to another hash that contains the Object::Remote specific information. The keys are =over 4 =item connection_id If the log message was generated on a remote Perl interpreter then the Object::Remote::Connection id of that interpreter will be available here. =back =back =head1 ATTRIBUTES =over 4 =item level_names This is a required attribute. Must be an array ref with the list of log level names in it. The list must be ordered with the lowest level as element 0 and the highest level as the last element. There is no default value. =item min_level The lowest log level that will be output by the logger. There is no default value. =item max_level The highest log level that will be output by the logger. The default value is the highest level present in level_names. =item format The printf style format string to use when rendering the log message. The following sequences are significant: =over 4 =item %l Level name that the log message was generated at. =item %s Log message rendered into a string with a leading space before any additional lines in a multiple line message. =item %t Time the log message was generated rendered into a string. The time value is taken from the Perl interpreter that generated the log message; it is not the time that the logger received the log message on the local interpreter if the log message was forwarded. =item %r Object::Remote connection information rendered into a string. =item %c Package name of the logging API that was used to generate the log message. =item %p Name of the package that generated the log message. =item %m Method name that generated the log message. =item %f Filename that the log message was generated in. =item %i Line number the log message was generated at. =item %h Hostname the log message was generated on. =item %P Process id of the Perl interpreter that generated the log message. =item %% A literal %. =item %n A newline. =back =back Object-Remote-0.003006/lib/Object/Remote/Logging/TestLogger.pm0000644000372100001440000000054112414033615023366 0ustar matthewtusers#During testing of Object::Remote this logger is connected #to the router and runs at trace level but does not output anything. #This lets the logging codeblocks get executed and included #in the testing. package Object::Remote::Logging::TestLogger; use base qw ( Object::Remote::Logging::Logger ); #don't need to output anything sub _output { } 1; Object-Remote-0.003006/lib/Object/Remote/Tied.pm0000644000372100001440000000047612414033615020615 0ustar matthewtuserspackage Object::Remote::Tied; use strictures 1; #a proxied tied object just ties to the #proxy object that exists on the remote #side of the actual tied variable - when #creating the remote tied variable the proxy #is passed to the constructor sub TIEHASH { return $_[1]; } sub TIEARRAY { return $_[1]; } 1; Object-Remote-0.003006/xt/0000755000372100001440000000000012644534072014617 5ustar matthewtusersObject-Remote-0.003006/xt/lib/0000755000372100001440000000000012644534072015365 5ustar matthewtusersObject-Remote-0.003006/xt/lib/TestBridge.pm0000644000372100001440000000027312414033615017751 0ustar matthewtuserspackage TestBridge; use Moo; use TestClass; use Object::Remote; has object => (is => 'lazy'); sub _build_object { TestClass->new::on('-') } sub result { (shift)->object->result } 1; Object-Remote-0.003006/xt/lib/TestClass.pm0000644000372100001440000000006312414033615017617 0ustar matthewtuserspackage TestClass; use Moo; sub result { 23 } 1; Object-Remote-0.003006/xt/lib/TestFindUser.pm0000644000372100001440000000013412414033615020270 0ustar matthewtuserspackage TestFindUser; use Moo; sub user { $< } sub send_err { print STDERR "Foo\n"; } 1; Object-Remote-0.003006/xt/lib/TestIOAsync.pm0000644000372100001440000000130212023175434020056 0ustar matthewtuserspackage TestIOAsync; use Moo; use Object::Remote; use Object::Remote::Future; use IO::Async::Loop; use IO::Async::Process; use IO::Async::LineStream; Object::Remote->current_loop(our $Loop = IO::Async::Loop->new); sub run { my ($self, $coderef) = @_; return future { my $f = shift; my $process = IO::Async::Process->new( command => [ 'ls' ], on_finish => sub { $Loop->remove($_[0]); $f->done; undef($f); }, ); my $line_stream = IO::Async::LineStream->new( on_read_line => sub { $coderef->($_[1]) }, transport => $process->stdout, ); $process->add_child($line_stream); # request cleanup $Loop->add($process); return $f; } } 1; Object-Remote-0.003006/xt/local-sudo.t0000644000372100001440000000100312644532615017041 0ustar matthewtusersuse IO::Prompter; # dies, utterly, if loaded after strictures, no idea why use strictures 1; use Test::More; use lib 'xt/lib'; use Object::Remote; my $user = $ENV{TEST_SUDOUSER} or plan skip_all => q{Requires TEST_SUDOUSER to be set}; my $conn = Object::Remote->connect('-')->connect("${user}\@"); my $remote = TestFindUser->new::on($conn); my $remote_user = $remote->user; like $remote_user, qr/^\d+$/, 'returned an int'; isnt $remote_user, $<, 'ran as different user'; $remote->send_err; done_testing; Object-Remote-0.003006/xt/bridged-remote.t0000644000372100001440000000041712414033615017667 0ustar matthewtusersuse strictures 1; use Test::More; use Test::Fatal; use FindBin; use lib "$FindBin::Bin/lib"; use TestClass; use Object::Remote; is exception { my $bridge = TestBridge->new::on('-'); is $bridge->result, 23; }, undef, 'no error during bridge access'; done_testing; Object-Remote-0.003006/xt/load_optional.t0000644000372100001440000000312712644532633017634 0ustar matthewtusersuse strictures 1; use Test::More; use Test::Fatal; use Sys::Hostname qw(hostname); $ENV{OBJECT_REMOTE_TEST_LOGGER} = 1; use Object::Remote::FromData; my $connection = Object::Remote->connect('-'); is exception { my $remote = My::Data::TestClassLoad->new::on($connection); is($remote->counter, 0, 'Counter at 0'); is($remote->increment, 1, 'Increment to 1'); is($remote->has_missing_module, 0, 'Shouldn\'t have loaded module'); }, undef, 'Checking Class::Load load_optional_class works correctly.'; is exception { my $remote = My::Data::TestModuleRuntime->new::on($connection); is($remote->counter, 0, 'Counter at 0'); is($remote->increment, 1, 'Increment to 1'); like exception { my $o = $remote->create_object; }, qr/Can't locate Not\/Found.pm in \@INC/, 'Should fail to load Not::Found'; }, undef, 'Checking Module::Runtime use_package_optimistically works correctly.'; done_testing; __DATA__ package My::Data::TestClassLoad; use Moo; use Class::Load 'load_optional_class'; use constant HAS_MISSING_MODULE => load_optional_class('Not::Found'); has counter => (is => 'rwp', default => sub { 0 }); sub increment { $_[0]->_set_counter($_[0]->counter + 1); } sub has_missing_module { HAS_MISSING_MODULE }; package My::Data::TestModuleRuntime; use Moo; use Module::Runtime 'use_package_optimistically'; use constant HAS_MISSING_MODULE => use_package_optimistically('Not::Found'); has counter => (is => 'rwp', default => sub { 0 }); sub increment { $_[0]->_set_counter($_[0]->counter + 1); } sub create_object { use_package_optimistically('Not::Found')->new() }; Object-Remote-0.003006/META.yml0000644000372100001440000000127512644534072015442 0ustar matthewtusers--- abstract: 'Call methods on objects in other processes or on other hosts' author: - 'mst - Matt S. Trout (cpan:MSTROUT) ' build_requires: ExtUtils::MakeMaker: '0' configure_requires: ExtUtils::MakeMaker: '0' dynamic_config: 1 generated_by: 'ExtUtils::MakeMaker version 7.04, CPAN::Meta::Converter version 2.150001' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: '1.4' name: Object-Remote no_index: directory: - t - inc requires: Class::C3: '0' Future: '0.29' JSON::PP: '0' Log::Contextual: '0.005' MRO::Compat: '0' Module::Runtime: '0' Moo: '1.006' String::ShellQuote: '0' version: '0.003006' Object-Remote-0.003006/META.json0000644000372100001440000000223112644534072015603 0ustar matthewtusers{ "abstract" : "Call methods on objects in other processes or on other hosts", "author" : [ "mst - Matt S. Trout (cpan:MSTROUT) " ], "dynamic_config" : 1, "generated_by" : "ExtUtils::MakeMaker version 7.04, CPAN::Meta::Converter version 2.150001", "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "Object-Remote", "no_index" : { "directory" : [ "t", "inc" ] }, "prereqs" : { "build" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "configure" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "runtime" : { "requires" : { "Class::C3" : "0", "Future" : "0.29", "JSON::PP" : "0", "Log::Contextual" : "0.005", "MRO::Compat" : "0", "Module::Runtime" : "0", "Moo" : "1.006", "String::ShellQuote" : "0" } } }, "release_status" : "stable", "version" : "0.003006" } Object-Remote-0.003006/Makefile.PL0000644000372100001440000000120112414033614016117 0ustar matthewtusersuse strict; use warnings FATAL => 'all'; use ExtUtils::MakeMaker; (do 'maint/Makefile.PL.include' or die $@) unless -f 'META.yml'; WriteMakefile( NAME => 'Object::Remote', VERSION_FROM => 'lib/Object/Remote.pm', PREREQ_PM => { Moo => 1.006, 'Module::Runtime' => 0, 'JSON::PP' => 0, 'Future' => 0.29, 'MRO::Compat' => 0, # required to fatpack Moo 'Class::C3' => 0, # required to fatpack Moo 'String::ShellQuote' => 0, # required for ssh argument manipulation 'Log::Contextual' => 0.005000 }, EXE_FILES => [ 'bin/object-remote-node', 'bin/object-remote-slave', 'bin/remoterepl', ], ); Object-Remote-0.003006/bin/0000755000372100001440000000000012644534072014734 5ustar matthewtusersObject-Remote-0.003006/bin/remoterepl0000755000372100001440000000125412414033615017032 0ustar matthewtusers#!/usr/bin/env perl use strictures 1; use Object::Remote; use Eval::WithLexicals; use Term::ReadLine; use Data::Dumper; $SIG{INT} = sub { warn "SIGINT\n" }; { package Data::Dumper; no strict 'vars'; $Terse = $Indent = $Useqq = $Deparse = $Sortkeys = 1; $Quotekeys = 0; } #{ no warnings 'once'; $Object::Remote::Connection::DEBUG = 1; } my $eval = Eval::WithLexicals->new::on($ARGV[0]||'-'); my $read = Term::ReadLine->new('Perl REPL'); while (1) { my $line = $read->readline('re.pl$ '); exit unless defined $line; my @ret; eval { local $SIG{INT} = sub { die "Caught SIGINT" }; @ret = $eval->eval($line); 1; } or @ret = ("Error!", $@); print Dumper @ret; } Object-Remote-0.003006/bin/object-remote-node0000755000372100001440000000013512414033615020333 0ustar matthewtusers#!/usr/bin/env perl use strictures 1; use Object::Remote::Node; Object::Remote::Node->run; Object-Remote-0.003006/bin/object-remote-slave0000644000372100001440000000043712414033615020522 0ustar matthewtusers#!/usr/bin/env perl use strictures 1; use Object::Remote::Connector::UNIX; use Object::Remote; my $c = Object::Remote::Connector::UNIX->new->connect($ARGV[0]); $c->register_class_class_handler; $c->remote_object(id => 'master')->register_slave( pid => $$, argv => \@ARGV )->run; Object-Remote-0.003006/README0000644000372100001440000002027212644534072015047 0ustar matthewtusersNAME Object::Remote - Call methods on objects in other processes or on other hosts SYNOPSIS Creating a connection: use Object::Remote; my $conn = Object::Remote->connect('myserver'); # invokes ssh Calling a subroutine: my $capture = IPC::System::Simple->can::on($conn, 'capture'); warn $capture->('uptime'); Using an object: my $eval = Eval::WithLexicals->new::on($conn); $eval->eval(q{my $x = `uptime`}); warn $eval->eval(q{$x}); Importantly: 'myserver' only requires perl 5.8+ - no non-core modules need to be installed on the far side, Object::Remote takes care of it for you! DESCRIPTION Object::Remote allows you to create an object in another process - usually one running on another machine you can connect to via ssh, although there are other connection mechanisms available. The idea here is that in many cases one wants to be able to run a piece of code on another machine, or perhaps many other machines - but without having to install anything on the far side. COMPONENTS Object::Remote The "main" API, which provides the "connect" method to create a connection to a remote process/host, "new::on" to create an object on a connection, and "can::on" to retrieve a subref over a connection. Object::Remote::Connection The object representing a connection, which provides the "remote_object" in Object::Remote::Connection and "remote_sub" in Object::Remote::Connection methods that are used by "new::on" and "can::on" to return proxies for objects and subroutines on the far side. Object::Remote::Future Code for dealing with asynchronous operations, which provides the "start::method" in Object::Remote::Future syntax for calling a possibly asynchronous method without blocking, and "await_future" in Object::Remote::Future and "await_all" in Object::Remote::Future to block until an asynchronous call completes or fails. METHODS connect my $conn = Object::Remote->connect('-'); # fork()ed connection my $conn = Object::Remote->connect('myserver'); # connection over ssh my $conn = Object::Remote->connect('user@myserver'); # connection over ssh my $conn = Object::Remote->connect('root@'); # connection over sudo new::on my $eval = Eval::WithLexicals->new::on($conn); my $eval = Eval::WithLexicals->new::on('myserver'); # implicit connect my $obj = Some::Class->new::on($conn, %args); # with constructor arguments can::on my $hostname = Sys::Hostname->can::on($conn, 'hostname'); my $hostname = Sys::Hostname->can::on('myserver', 'hostname'); ENVIRONMENT OBJECT_REMOTE_PERL_BIN When starting a new Perl interpreter the contents of this environment variable will be used as the path to the executable. If the variable is not set the path is 'perl' OBJECT_REMOTE_LOG_LEVEL Setting this environment variable will enable logging and send all log messages at the specfied level or higher to STDERR. Valid level names are: trace debug verbose info warn error fatal OBJECT_REMOTE_LOG_FORMAT The format of the logging output is configurable. By setting this environment variable the format can be controlled via printf style position variables. See Object::Remote::Logging::Logger. OBJECT_REMOTE_LOG_FORWARDING Forward log events from remote connections to the local Perl interpreter. Set to 1 to enable this feature which is disabled by default. See Object::Remote::Logging. OBJECT_REMOTE_LOG_SELECTIONS Space seperated list of class names to display logs for if logging output is enabled. Default value is "Object::Remote::Logging" which selects all logs generated by Object::Remote. See Object::Remote::Logging. KNOWN ISSUES Large data structures Object::Remote communication is encapsalated with JSON and values passed to remote objects will be serialized with it. When sending large data structures or data structures with a lot of deep complexity (hashes in arrays in hashes in arrays) the processor time and memory requirements for serialization and deserialization can be either painful or unworkable. During times of serialization the local or remote nodes will be blocked potentially causing all remote interpreters to block as well under worse case conditions. To help deal with this issue it is possible to configure resource ulimits for a Perl interpreter that is executed by Object::Remote. See "Object::Remote::Role::Connector::PerlInterpreter" for details on the perl_command attribute. User can starve run loop of execution opportunities The Object::Remote run loop is responsible for performing I/O and managing timers in a cooperative multitasing way but it can only do these tasks when the user has given control to Object::Remote. There are times when Object::Remote must wait for the user to return control to the run loop and during these times no I/O can be performed and no timers can be executed. As an end user of Object::Remote if you depend on connection timeouts, the watch dog or timely results from remote objects then be sure to hand control back to Object::Remote as soon as you can. Run loop favors certain filehandles/connections High levels of load can starve timers of execution opportunities These are issues that only become a problem at large scales. The end result of these two issues is quite similiar: some remote objects may block while the local run loop is either busy servicing a different connection or is not executing because control has not yet been returned to it. For the same reasons timers may not get an opportunity to execute in a timely way. Internally Object::Remote uses timers managed by the run loop for control tasks. Under high load the timers can be preempted by servicing I/O on the filehandles and execution can be severely delayed. This can lead to connection watchdogs not being updated or connection timeouts taking longer than configured. Deadlocks Deadlocks can happen quite easily because of flaws in programs that use Object::Remote or Object::Remote itself so the "Object::Remote::WatchDog" is available. When used the run loop will periodically update the watch dog object on the remote Perl interpreter. If the watch dog goes longer than the configured interval with out being updated then it will terminate the Perl process. The watch dog will terminate the process even if a deadlock condition has occured. Log forwarding at scale can starve timers of execution opportunities Currently log forwarding can be problematic at large scales. When there is a large amount of log events the load produced by log forwarding can be high enough that it starves the timers and the remote object watch dogs (if in use) don't get updated in timely way causing them to erroneously terminate the Perl process. If the watch dog is not in use then connection timeouts can be delayed but will execute when load settles down enough. Because of the load related issues Object::Remote disables log forwarding by default. See "Object::Remote::Logging" for information on log forwarding. SUPPORT IRC: #web-simple on irc.perl.org AUTHOR mst - Matt S. Trout (cpan:MSTROUT) CONTRIBUTORS bfwg - Colin Newell (cpan:NEWELLC) phaylon - Robert Sedlacek (cpan:PHAYLON) triddle - Tyler Riddle (cpan:TRIDDLE) SPONSORS Parts of this code were paid for by Socialflow L Shadowcat Systems L COPYRIGHT Copyright (c) 2012 the Object::Remote "AUTHOR", "CONTRIBUTORS" and "SPONSORS" as listed above. LICENSE This library is free software and may be distributed under the same terms as perl itself. Object-Remote-0.003006/maint/0000755000372100001440000000000012644534072015274 5ustar matthewtusersObject-Remote-0.003006/maint/Makefile.PL.include0000644000372100001440000000042712414033615020663 0ustar matthewtusersBEGIN { -e 'Distar' or system("git clone git://git.shadowcat.co.uk/p5sagit/Distar.git") } use lib 'Distar/lib'; use Distar; author 'mst - Matt S. Trout (cpan:MSTROUT) '; manifest_include( bin => qr/.*/ ); manifest_include( 't/data' => qr/.*/ ); Object-Remote-0.003006/MANIFEST0000644000372100001440000000377412644534072015330 0ustar matthewtusersbin/object-remote-node bin/object-remote-slave bin/remoterepl Changes lib/Object/Remote.pm lib/Object/Remote/CodeContainer.pm lib/Object/Remote/Connection.pm lib/Object/Remote/ConnectionServer.pm lib/Object/Remote/Connector/Local.pm lib/Object/Remote/Connector/LocalSudo.pm lib/Object/Remote/Connector/SSH.pm lib/Object/Remote/Connector/STDIO.pm lib/Object/Remote/Connector/UNIX.pm lib/Object/Remote/FatNode.pm lib/Object/Remote/FromData.pm lib/Object/Remote/Future.pm lib/Object/Remote/GlobContainer.pm lib/Object/Remote/GlobProxy.pm lib/Object/Remote/Handle.pm lib/Object/Remote/Logging.pm lib/Object/Remote/Logging/LogAnyInjector.pm lib/Object/Remote/Logging/Logger.pm lib/Object/Remote/Logging/Router.pm lib/Object/Remote/Logging/TestLogger.pm lib/Object/Remote/MiniLoop.pm lib/Object/Remote/ModuleLoader.pm lib/Object/Remote/ModuleSender.pm lib/Object/Remote/Node.pm lib/Object/Remote/Null.pm lib/Object/Remote/Prompt.pm lib/Object/Remote/Proxy.pm lib/Object/Remote/ReadChannel.pm lib/Object/Remote/Role/Connector.pm lib/Object/Remote/Role/Connector/PerlInterpreter.pm lib/Object/Remote/Role/LogForwarder.pm lib/Object/Remote/Tied.pm lib/Object/Remote/WatchDog.pm maint/Makefile.PL.include Makefile.PL MANIFEST This list of files t/await.t t/basic.t t/basic_data.t t/bridged.t t/chained.t t/data/numbers.txt t/fatnode.t t/lib/ORFeedbackLogger.pm t/lib/ORTestBridge.pm t/lib/ORTestClass.pm t/lib/ORTestGlobs.pm t/lib/ORTestObjects.pm t/lib/ORTestTiedRemote.pm t/lib/ORTestTransfer.pm t/logger.t t/logging.t t/logrouter.t t/not_found.t t/objects.t t/perl_execute.t t/sender.t t/start_core.t t/tied.t t/timeout.t t/transfer.t t/watchdog.t t/watchdog_fatnode.t xt/bridged-remote.t xt/lib/TestBridge.pm xt/lib/TestClass.pm xt/lib/TestFindUser.pm xt/lib/TestIOAsync.pm xt/load_optional.t xt/local-sudo.t META.yml Module YAML meta-data (added by MakeMaker) META.json Module JSON meta-data (added by MakeMaker) README README file (added by Distar) Object-Remote-0.003006/t/0000755000372100001440000000000012644534072014427 5ustar matthewtusersObject-Remote-0.003006/t/await.t0000644000372100001440000000265312414033615015717 0ustar matthewtusersuse strictures 1; use Test::More; use Test::Fatal; use FindBin; use lib "$FindBin::Bin/lib"; $ENV{OBJECT_REMOTE_TEST_LOGGER} = 1; use Object::Remote; use Object::Remote::Future qw( await_all await_future ); use ORTestClass; my $state = []; my $_make_future_keep_proxy = sub { # note: do not store the remote proxy somewhere my $proxy = ORTestClass->new::on('-'); my $future = $proxy->start::call_callback(23, sub { sleep 1 }); push @$state, $proxy; return $future; }; my $_make_future = sub { # note: do not store the remote proxy somewhere my $future = ORTestClass ->new::on('-') ->start::call_callback(23, sub { sleep 1 }); }; my @tests = ( ['proxy kept', $_make_future_keep_proxy], ['proxy thrown away', $_make_future], ); for my $test (@tests) { my ($title, $make) = @$test; subtest $title, sub { do { my $future = $make->(); local $SIG{ALRM} = sub { die "future timed out" }; alarm 10; is exception { my $result = await_future $future; is $result, 23, 'correct value'; alarm 0; }, undef, 'no errors for await_future'; }; do { my $future = $make->(); local $SIG{ALRM} = sub { die "future timed out" }; alarm 10; is exception { my @result = await_all $future; is $result[0], 23, 'correct value'; alarm 0; }, undef, 'no errors for await_all'; }; done_testing; }; } done_testing; Object-Remote-0.003006/t/lib/0000755000372100001440000000000012644534072015175 5ustar matthewtusersObject-Remote-0.003006/t/lib/ORTestObjects.pm0000644000372100001440000000056512414033615020223 0ustar matthewtuserspackage ORTestObjects; use Moo; has name => (is => 'rwp', default => sub { 'Fred' }); sub same_name { my ($self, $other) = @_; return $self->name eq $other->name; } sub give_back { my ($self) = @_; return $self; } sub takes_object { my ($self, $object) = @_; if($object->isa('ORTestObjects')) { return 1; } return 0; } 1; Object-Remote-0.003006/t/lib/ORTestTiedRemote.pm0000644000372100001440000000114412414033615020665 0ustar matthewtuserspackage ORTestTiedRemote; use Moo; use Tie::Array; use Tie::Hash; has hash => ( is => 'ro', builder => 1 ); has array => ( is => 'ro', builder => 1 ); sub _build_hash { tie(my %hash, 'Tie::StdHash'); %hash = ( akey => 'a value'); return \%hash; } sub _build_array { tie(my @array, 'Tie::StdArray'); @array = ('another value'); return \@array; } sub sum_array { my ($self) = @_; my $sum = 0; foreach(@{$self->array}) { $sum += $_; } return $sum; } sub sum_hash { my ($self) = @_; my $sum = 0; foreach(values(%{$self->hash})) { $sum += $_; } return $sum; } 1; Object-Remote-0.003006/t/lib/ORTestClass.pm0000644000372100001440000000036712414033615017677 0ustar matthewtuserspackage ORTestClass; use Moo; has counter => (is => 'rwp', default => sub { 0 }); sub increment { $_[0]->_set_counter($_[0]->counter + 1); } sub pid { $$ } sub call_callback { my ($self, $value, $cb) = @_; $cb->(); return $value; } 1; Object-Remote-0.003006/t/lib/ORFeedbackLogger.pm0000644000372100001440000000104512414033615020610 0ustar matthewtuserspackage ORFeedbackLogger; use Test::More; use Moo; extends 'Object::Remote::Logging::Logger'; has feedback_output => (is => 'rw' ); has feedback_input => ( is => 'rw' ); sub reset { my ($self) = @_; $self->feedback_output(undef); $self->feedback_input(undef); ok(! defined $self->feedback_output && ! defined $self->feedback_input, 'Reset successful'); } sub _log { my $self = shift; $self->feedback_input([@_]); $self->SUPER::_log(@_); } sub _output { my ($self, $rendered) = @_; $self->feedback_output($rendered); } 1; Object-Remote-0.003006/t/lib/ORTestBridge.pm0000644000372100001440000000034112414033615020016 0ustar matthewtuserspackage ORTestBridge; use Moo; use Object::Remote; has object => (is => 'lazy'); sub _build_object { ORTestClass->new::on('-') } sub call { my ($self, $method, @args) = @_; return $self->object->$method(@args); } 1; Object-Remote-0.003006/t/lib/ORTestTransfer.pm0000644000372100001440000000010112414033615020400 0ustar matthewtuserspackage ORTestTransfer; use Moo; has value => (is => 'rw'); 1; Object-Remote-0.003006/t/lib/ORTestGlobs.pm0000644000372100001440000000073612414033615017700 0ustar matthewtuserspackage ORTestGlobs; use Moo; has handle => (is => 'rw'); has valueref => (is => 'ro', default => sub { my $body = ''; return \$body; }); sub write { my $self = shift; print { $self->handle } @_ } sub getvalue { ${ $_[0]->valueref } } sub gethandle { open my $fh, '>', $_[0]->valueref or die "Unable to open in-memory file: $!\n"; return $fh; } sub getreadhandle { open my $fh, '<', $_[1] or die "Unable to open in-memory file: $!\n"; return $fh; } 1; Object-Remote-0.003006/t/sender.t0000644000372100001440000000135612414033615016071 0ustar matthewtusersuse strictures 1; use Test::More; $ENV{OBJECT_REMOTE_TEST_LOGGER} = 1; use Object::Remote::Connector::Local; use Object::Remote; use Object::Remote::ModuleSender; $ENV{PERL5LIB} = join( ':', ($ENV{PERL5LIB} ? $ENV{PERL5LIB} : ()), qw(lib) ); my $ms = Object::Remote::ModuleSender->new( dir_list => [ 't/lib' ] ); my $connection = Object::Remote::Connector::Local->new( module_sender => $ms, )->connect; my $counter = Object::Remote->new( connection => $connection, class => 'ORTestClass' ); isnt($$, $counter->pid, 'Different pid on the other side'); is($counter->counter, 0, 'Counter at 0'); is($counter->increment, 1, 'Increment to 1'); is($counter->counter, 1, 'Counter at 1'); done_testing; Object-Remote-0.003006/t/fatnode.t0000644000372100001440000000043012552473243016231 0ustar matthewtusersuse strict; use warnings; use strictures 1; use Test::More; plan tests => 1; require Object::Remote::FatNode; my $data = do { no warnings 'once'; $Object::Remote::FatNode::DATA; }; ok $data !~ m|MODULELOADER_HOOK|mx,'MODULELOADER_HOOK should not be in the fatpack.'; Object-Remote-0.003006/t/start_core.t0000644000372100001440000000274512414033615016761 0ustar matthewtusersuse strictures 1; use Test::More; use Object::Remote; use File::Spec; $ENV{OBJECT_REMOTE_TEST_LOGGER} = 1; { package S1S; use Moo; sub get_s2 { S2S->new } } { package S1F; use Object::Remote::Future; use Moo; our $C; sub get_s2 { shift->maybe::start::_real_get_s2; } sub _real_get_s2 { future { my $f = shift; $C = sub { $f->done(S2F->new); undef($f); undef($C); }; $f; } } } { package S2S; use Moo; sub get_s3 { 'S3' } } { package S2F; use Object::Remote::Future; use Moo; our $C; sub get_s3 { future { my $f = shift; $C = sub { $f->done('S3'); undef($f); undef($C); }; $f; } } } my $res; my @keep; push @keep, S1S->start::get_s2->then::get_s3->on_ready(sub { ($res) = $_[0]->get }); is($res, 'S3', 'Synchronous code ok'); undef($res); push @keep, S1F->start::get_s2->then::get_s3->on_ready(sub { ($res) = $_[0]->get }); ok(!$S2F::C, 'Second future not yet constructed'); $S1F::C->(); ok($S2F::C, 'Second future constructed after first future completed'); ok(!$res, 'Nothing happened yet'); $S2F::C->(); is($res, 'S3', 'Asynchronous code ok'); is(S1S->get_s2->get_s3, 'S3', 'Sync without start'); Object::Remote->current_loop->watch_time( after => 0.1, code => sub { $S1F::C->(); Object::Remote->current_loop->watch_time( after => 0.1, code => sub { $S2F::C->() } ); } ); is(S1F->get_s2->get_s3, 'S3', 'Async without start'); done_testing; Object-Remote-0.003006/t/logger.t0000644000372100001440000000447012414033615016070 0ustar matthewtusersuse strictures 1; use Test::More; use Sys::Hostname; $ENV{OBJECT_REMOTE_TEST_LOGGER} = 1; use Object::Remote::Logging qw(:log router arg_levels); use Object::Remote::Logging::Logger; require 't/lib/ORFeedbackLogger.pm'; my $level_names = [qw(test1 test2 test3 test4 test5)]; my $logger = Object::Remote::Logging::Logger->new( level_names => $level_names, min_level => 'test1' ); isa_ok($logger, 'Object::Remote::Logging::Logger'); is($logger->max_level, 'test5', 'Logger sets max_level correctly'); is($logger->format, '%l: %s', 'Default format is correct'); foreach(@$level_names) { is($logger->_level_active->{$_}, 1, "Level $_ is active"); } $logger = Object::Remote::Logging::Logger->new( level_names => $level_names, min_level => 'test3' ); foreach(qw(test1 test2)) { is($logger->_level_active->{$_}, 0, "Level $_ is inactive"); } foreach(qw(test3 test4 test5)) { is($logger->_level_active->{$_}, 1, "Level $_ is active"); } is(render_log("%%")->[0], "%\n", "Percent renders correctly"); is(render_log("%n")->[0], "\n", "New line renders correctly"); is(render_log("%p")->[0], "main\n", "Package renders correctly"); ok(defined render_log("%t")->[0], "There was a time value"); is(render_log("%r")->[0], "local\n", "Remote info renders correctly"); is(render_log("%s")->[0], "Test message\n", "Log message renders correctly"); is(render_log("%l")->[0], "info\n", "Log level renders correctly"); is(render_log("%c")->[0], "Object::Remote::Logging\n", "Log controller renders correctly"); is(render_log("%p")->[0], "main\n", "Log generating package renders correctly"); is(render_log("%m")->[0], "render_log\n", "Log generating method renders correctly"); is(render_log("%f")->[0], __FILE__ . "\n", "Log generating filename renders correctly"); my $ret = render_log("%i"); is($ret->[0], $ret->[1] . "\n", "Log generating line number renders correctly"); is(render_log("%h")->[0], hostname() . "\n", "Log generating hostname renders correctly"); is(render_log("%P")->[0], "$$\n", "Log generating process id renders correctly"); done_testing; sub render_log { my ($format)= @_; $logger = ORFeedbackLogger->new( format => $format, level_names => arg_levels(), min_level => 'info'); my $selector= sub { $logger }; router->connect($selector, 1); log_info { "Test message" }; return [$logger->feedback_output, __LINE__ - 1]; } Object-Remote-0.003006/t/chained.t0000644000372100001440000000156512414033615016206 0ustar matthewtusersuse strictures 1; use Test::More; $ENV{OBJECT_REMOTE_TEST_LOGGER} = 1; use Object::Remote; use Object::Remote::FromData; my $conn1 = Reconnector->new::on('-'); my $conn2 = $conn1->connect; isa_ok($conn1, 'Object::Remote::Proxy'); isa_ok($conn2, 'Object::Remote::Proxy'); my $root_pid = $$; my $conn1_pid = $conn1->pid; my $conn2_pid = $conn2->pid; ok($root_pid != $conn1_pid, "Root and conn1 are not the same interpreter instance"); ok($root_pid != $conn2_pid, "Root and conn2 are not the same interpreter instance"); ok($conn1_pid != $conn2_pid, "conn1 and conn2 are not the same interpreter instance"); ok($conn1->ping eq "pong", "Ping success on conn1"); ok($conn2->ping eq "pong", "Ping success on conn2"); done_testing; __DATA__ package Reconnector; use Moo; sub connect { return Reconnector->new::on('-'); } sub pid { return $$; } sub ping { return 'pong'; } Object-Remote-0.003006/t/objects.t0000644000372100001440000000137112414033615016237 0ustar matthewtusersuse strictures 1; use Test::More; use Sys::Hostname qw(hostname); use overload (); use Object::Remote; $ENV{PERL5LIB} = join( ':', ($ENV{PERL5LIB} ? $ENV{PERL5LIB} : ()), qw(lib t/lib) ); my $connection = Object::Remote->connect('-'); my $ortestobj_j = ORTestObjects->new::on($connection, { name => 'John' }); my $ortestobj_k = ORTestObjects->new::on($connection, { name => 'Ken' }); is($ortestobj_k->takes_object($ortestobj_j), 1, 'Passed correct object back over the wire'); my $george = ORTestObjects->new::on($connection, { name => 'George'}); my $george_again = $george->give_back; is($george->{remote}, $george_again->{remote}, 'objects appear to be the same'); is($george->name, $george_again->name, 'objects have the same name'); done_testing; Object-Remote-0.003006/t/not_found.t0000644000372100001440000000066612644532633016620 0ustar matthewtusersuse strictures 1; use Test::More; use Test::Fatal; use Sys::Hostname qw(hostname); $ENV{OBJECT_REMOTE_TEST_LOGGER} = 1; use Object::Remote::FromData; my $connection = Object::Remote->connect('-'); like exception { my $remote = My::Data::TestClass->new::on($connection); }, qr/Can't locate Not\/Found.pm in \@INC/, 'Should fail to load Not::Found'; done_testing; __DATA__ package My::Data::TestClass; use Moo; use Not::Found; Object-Remote-0.003006/t/basic.t0000644000372100001440000000140712414033615015667 0ustar matthewtusersuse strictures 1; use Test::More; use Sys::Hostname qw(hostname); $ENV{OBJECT_REMOTE_TEST_LOGGER} = 1; use Object::Remote; $ENV{PERL5LIB} = join( ':', ($ENV{PERL5LIB} ? $ENV{PERL5LIB} : ()), qw(lib t/lib) ); my $connection = Object::Remote->connect('-'); #$Object::Remote::Connection::DEBUG = 1; my $remote = ORTestClass->new::on($connection); isnt($$, $remote->pid, 'Different pid on the other side'); is($remote->counter, 0, 'Counter at 0'); is($remote->increment, 1, 'Increment to 1'); is($remote->counter, 1, 'Counter at 1'); my $x = 0; is($remote->call_callback(27, sub { $x++ }), 27, "Callback ok"); is($x, 1, "Callback called callback"); is( Sys::Hostname->can::on($connection, 'hostname')->(), hostname(), 'Remote sub call ok' ); done_testing; Object-Remote-0.003006/t/logging.t0000644000372100001440000000271712414033615016241 0ustar matthewtusersuse strictures 1; use Test::More; $ENV{OBJECT_REMOTE_TEST_LOGGER} = 1; BEGIN { use Object::Remote::Logging qw( :log :dlog router arg_levels ); is($Object::Remote::Logging::DID_INIT, 1, 'using logging class initializes it'); } my $router = router(); isa_ok($router, 'Object::Remote::Logging::Router'); is($router, router(), 'Router object is a singleton'); my $levels = arg_levels(); is(ref($levels), 'ARRAY', 'arg_levels returns array reference'); is_deeply( $levels, [qw( trace debug verbose info warn error fatal )], 'arg_levels has correct names' ); #adds some noise into the string that's not significant just to be more thorough my $selections_string = "Acme::Matt::Daemon \t *\t\t-Acme::POE::Knee"; my %parsed_selections = Object::Remote::Logging::_parse_selections($selections_string); my $selections_match = { '*' => 1, 'Acme::Matt::Daemon' => 1, 'Acme::POE::Knee' => 0 }; is_deeply(\%parsed_selections, $selections_match, 'Selections parsed successfully' ); require 't/lib/ORFeedbackLogger.pm'; my $logger = ORFeedbackLogger->new(level_names => $levels, min_level => 'trace'); isa_ok($logger, 'ORFeedbackLogger'); $router->connect($logger); $logger->reset; log_info { "The quick brown fox jumped" }; is($logger->feedback_output, "info: The quick brown fox jumped\n", 'log_info works'); $logger->reset; Dlog_verbose { "over the lazy dog's $_" } 'back'; is($logger->feedback_output, "verbose: over the lazy dog's \"back\"\n", 'Dlog_verbose works'); done_testing;Object-Remote-0.003006/t/logrouter.t0000644000372100001440000000460412414033615016632 0ustar matthewtusersuse strictures 1; use Test::More; use Sys::Hostname; $ENV{OBJECT_REMOTE_TEST_LOGGER} = 1; use Object::Remote::Logging::Router; my $controller_name = 'Test::Log::Controller'; my $generator = sub { "Generator output" }; my %metadata = ( exporter => $controller_name, caller_package => __PACKAGE__, caller_level => 0, message_level => 'test1', message_sub => $generator, message_args => [], ); my $router = Object::Remote::Logging::Router->new; $router->_remote_metadata({ router => undef, connection_id => 'TestConnectionId' }); isa_ok($router, 'Object::Remote::Logging::Router'); ok($router->does('Log::Contextual::Role::Router'), 'Router does router role'); require 't/lib/ORFeedbackLogger.pm'; my $logger = ORFeedbackLogger->new(level_names => [qw( test1 test2 )], min_level => 'test1'); my $selector = sub { $logger }; $router->connect($selector, 1); ok($router->_connections->[0] eq $selector, 'Selector is stored in connections'); ok(scalar(@{$router->_connections} == 1), 'There is a single connection'); $logger->reset; my $linenum = __LINE__ + 1; $router->handle_log_request(%metadata); is($logger->feedback_output, "test1: Generator output\n", 'Rendered log message is correct'); ok($logger->feedback_input->[2]->{timestamp} > 0, 'Timestamp value is present'); delete $logger->feedback_input->[2]->{timestamp}; is(ref $logger->feedback_input->[2]->{message_sub}, 'CODE', 'message sub did exist'); delete $logger->feedback_input->[2]->{message_sub}; is_deeply($logger->feedback_input, [ 'test1', [ 'Generator output' ], { exporter => 'Test::Log::Controller', message_level => 'test1', hostname => hostname(), pid => $$, caller_package => __PACKAGE__, line => $linenum, method => undef, filename => __FILE__, message_args => [], object_remote => { connection_id => 'TestConnectionId', router => undef, }, }, ], 'Input to logger was correct'); $logger->reset; undef($selector); $router->handle_log_request(%metadata); ok(scalar(@{$router->_connections}) == 0, 'Selector has been disconnected'); ok(! defined $logger->feedback_output, 'Logger has no output feedback'); ok(! defined $logger->feedback_input, 'Logger has no input feedback'); $router->connect($logger); ok(scalar(@{$router->_connections} == 1), 'There is a single connection'); undef($logger); $router->handle_log_request(%metadata); ok(scalar(@{$router->_connections} == 1), 'Connection is still active'); done_testing; Object-Remote-0.003006/t/tied.t0000644000372100001440000000225312414033615015533 0ustar matthewtusersuse strictures 1; use Test::More; use lib 't/lib'; use Tie::Array; use Tie::Hash; $ENV{OBJECT_REMOTE_TEST_LOGGER} = 1; use Object::Remote; use ORTestTiedRemote; my @test_data = qw(1 5 10 30 80); my $test_sum; map { $test_sum += $_ } @test_data; my $conn = Object::Remote->connect('-'); my $remote = ORTestTiedRemote->new::on($conn); isa_ok($remote, 'Object::Remote::Proxy'); my $remote_array = $remote->array; my $remote_hash = $remote->hash; is(ref($remote_array), 'ARRAY', 'Array ref is array ref'); is(ref(tied(@$remote_array)), 'Object::Remote::Proxy', 'Array is tied to proxy object'); is_deeply($remote_array, ['another value'], 'Array is initialized properly'); @$remote_array = @test_data; is($remote->sum_array, $test_sum, 'Sum of array data matches sum of test data'); is(ref($remote_hash), 'HASH', 'Hash ref is hash ref'); is(ref(tied(%$remote_hash)), 'Object::Remote::Proxy', 'Hash is tied to proxy object'); is_deeply($remote_hash, { akey => 'a value' }, 'Hash is initialized properly'); %$remote_hash = (); do { my $i = 0; map { $remote_hash->{++$i} = $_ } @test_data }; is($remote->sum_hash, $test_sum, 'Sum of hash values matches sum of test data'); done_testing; Object-Remote-0.003006/t/bridged.t0000644000372100001440000000057712414033615016215 0ustar matthewtusersuse strictures 1; use Test::More; use Test::Fatal; use FindBin; use lib "$FindBin::Bin/lib"; $ENV{OBJECT_REMOTE_TEST_LOGGER} = 1; use Object::Remote; is exception { my $bridge = ORTestBridge->new::on('-'); #'localhost'); is $bridge->call('counter'), 0; $bridge->call('increment'); is $bridge->call('counter'), 1; }, undef, 'no error during bridge access'; done_testing; Object-Remote-0.003006/t/timeout.t0000644000372100001440000000060712414033615016275 0ustar matthewtusersuse strictures 1; use Test::More; $ENV{OBJECT_REMOTE_TEST_LOGGER} = 1; use Object::Remote; use Object::Remote::Connector::Local; my $connector = Object::Remote::Connector::Local->new( timeout => 0.1, perl_command => [ 'perl', '-e', 'sleep 3' ], ); ok(!eval { $connector->connect; 1 }, 'Connection failed'); like($@, qr{timed out}, 'Connection failed with time out'); done_testing; Object-Remote-0.003006/t/perl_execute.t0000644000372100001440000000176612414033615017302 0ustar matthewtusersuse strictures 1; use Test::More; $ENV{OBJECT_REMOTE_TEST_LOGGER} = 1; use Object::Remote::Connector::Local; use Object::Remote::Connector::SSH; my $defaults = Object::Remote::Connector::Local->new; my $normal = $defaults->final_perl_command; my $ssh = Object::Remote::Connector::SSH->new(ssh_to => 'testhost')->final_perl_command; my $with_env = do { local $ENV{OBJECT_REMOTE_PERL_BIN} = 'perl_bin_test_value'; Object::Remote::Connector::Local->new->final_perl_command; }; is($defaults->timeout, 10, 'Default connection timeout value is correct'); is($defaults->watchdog_timeout, undef, 'Watchdog is not enabled by default'); is($defaults->stderr, undef, 'Child process STDERR is clone of parent process STDERR by default'); is_deeply($normal, ['perl', '-'], 'Default Perl interpreter arguments correct'); is_deeply($ssh, [qw(ssh -A testhost), "perl -"], "Arguments using ssh are correct"); is_deeply($with_env, ['perl_bin_test_value', '-'], "Respects OBJECT_REMOTE_PERL_BIN env value"); done_testing; Object-Remote-0.003006/t/data/0000755000372100001440000000000012644534072015340 5ustar matthewtusersObject-Remote-0.003006/t/data/numbers.txt0000644000372100001440000000001212414033615017535 0ustar matthewtusers1 2 3 4 5 Object-Remote-0.003006/t/watchdog.t0000644000372100001440000000126712414033615016412 0ustar matthewtusersuse strictures 1; use Test::More; $ENV{OBJECT_REMOTE_TEST_LOGGER} = 1; use Object::Remote::Connection; use Object::Remote::FromData; $SIG{ALRM} = sub { fail("Watchdog killed remote process in time"); die "test failed" }; my $conn = Object::Remote->connect("-", watchdog_timeout => 1); my $remote = HangClass->new::on($conn); isa_ok($remote, 'Object::Remote::Proxy'); is($remote->alive, 1, "Hanging test object is running"); alarm(3); eval { $remote->hang }; like($@, qr/^Object::Remote connection lost: (?:eof|.*Broken pipe)/, "Correct error message"); done_testing; __DATA__ package HangClass; use Moo; sub alive { return 1; } sub hang { while(1) { sleep(1); } } Object-Remote-0.003006/t/transfer.t0000644000372100001440000000337212414033615016435 0ustar matthewtusersuse strictures 1; use Test::More; use Test::Fatal; use FindBin; $ENV{OBJECT_REMOTE_TEST_LOGGER} = 1; $ENV{PERL5LIB} = join( ':', ($ENV{PERL5LIB} ? $ENV{PERL5LIB} : ()), qw(lib t/lib) ); use Object::Remote; my $strA = 'foo'; my $strB = 'bar'; is exception { my $proxy = ORTestTransfer->new::on('-', value => \$strA); is_deeply $proxy->value, \$strA, 'correct value after construction'; }, undef, 'scalar refs - no errors during construction'; is exception { my $proxy = ORTestTransfer->new::on('-'); $proxy->value(\$strB); is_deeply $proxy->value, \$strB, 'correct value after construction'; }, undef, 'scalar refs - no errors during attribute set'; my $data_file = "$FindBin::Bin/data/numbers.txt"; is exception { my $out = ''; open my $fh, '>', \$out or die "Unable to open in-memory file: $!\n"; my $proxy = ORTestGlobs->new::on('-', handle => $fh); ok $proxy->handle, 'filehandle was set'; ok $proxy->write('foo'), 'write was successful'; is $out, 'foo', 'write reached target'; }, undef, 'filehandles - no error during construction'; is exception { my $proxy = ORTestGlobs->new::on('-'); my $handle = $proxy->gethandle; print $handle 'foo'; is $proxy->getvalue, 'foo', 'correct value written'; $handle->autoflush(1); }, undef, 'filehandles - no error during remote handle'; is exception { my $proxy = ORTestGlobs->new::on('-'); my $rhandle = $proxy->getreadhandle($data_file); my @lines = <$rhandle>; chomp @lines; is_deeply \@lines, [1 .. 5], 'reading back out of the handle'; }, undef, 'filehandles - no error during remote read'; is exception { my $proxy = ORTestGlobs->new::on('-'); my $rhandle = $proxy->getreadhandle($data_file); binmode $rhandle; }, undef, 'filehandles - no errors during binmode'; done_testing; Object-Remote-0.003006/t/basic_data.t0000644000372100001440000000130312414033615016653 0ustar matthewtusersuse strictures 1; use Test::More; use Sys::Hostname qw(hostname); $ENV{OBJECT_REMOTE_TEST_LOGGER} = 1; use Object::Remote::FromData; my $connection = Object::Remote->connect('-'); my $remote = My::Data::TestClass->new::on($connection); is($remote->counter, 0, 'Counter at 0'); is($remote->increment, 1, 'Increment to 1'); is($remote->counter, 1, 'Counter at 1'); is( My::Data::TestPackage->can::on($connection, 'hostname')->(), hostname(), 'Remote sub call ok' ); done_testing; __DATA__ package My::Data::TestClass; use Moo; has counter => (is => 'rwp', default => sub { 0 }); sub increment { $_[0]->_set_counter($_[0]->counter + 1); } package My::Data::TestPackage; use Sys::Hostname; Object-Remote-0.003006/t/watchdog_fatnode.t0000644000372100001440000000127712414033615020113 0ustar matthewtusersuse strictures 1; use Test::More; $ENV{OBJECT_REMOTE_TEST_LOGGER} = 1; use Object::Remote::Connector::Local; $SIG{ALRM} = sub { die "alarm signal\n" }; my $fatnode_text = Object::Remote::Connector::Local->new(timeout => 1)->fatnode_text; #this simulates a node that has hung before it reaches #the watchdog initialization - it's an edge case that #could cause remote processes to not get cleaned up #if it's not handled right eval { no warnings 'once'; $Object::Remote::FatNode::INHIBIT_RUN_NODE = 1; eval $fatnode_text; if ($@) { die "could not eval fatnode text: $@"; } while(1) { sleep(1); } }; is($@, "alarm signal\n", "Alarm handler was invoked"); done_testing; Object-Remote-0.003006/Changes0000644000372100001440000000350612644534030015455 0ustar matthewtusers0.003006 - 2016-01-10 - Produce an error message comprehensible by Class::Load and Module::Runtime 0.003005 - 2015-07-18 - Skip non-primary modules in a file to ensure we generate a sane fatpack 0.003004 - 2014-10-04 - Explicitly load Moo::HandleMoose::_TypeMap since it isn't loaded sans ithreads but we don't know if the foreign perl requires it 0.003003 - 2014-08-11 - Make watchdog test handle death-by-send as well as death-by-receive - Use newer Future API, fix broken test 0.003002 - 2013-03-19 - Switch from CPS::Future to Future.pm 0.003001_01 - 2013-02-11 - Allow STDERR of remote interpreters to be sent to a connection specific filehandle - Proxy dies() when a method is invoked and the handle is not valid - Introduced the Watchdog class - Added support for local object, tied hashes, and tied arrays in the Connection class - White listed Devel::GlobalDestruction and black listed XSLoader and DynaLoader in FatNode - Dead locks found and partially worked around - Logging system introduced - Propagate errors from FatNode code - Fall back to core non-arch modules in FatNode - Fix module name in Makefile.PL 0.002003 - 2012-07-25 - Exclude vendorarch and sitearch from FatNode and ModuleSender - Increase default timeout to 10 seconds - Add Class::C3 as a dependency since it's required for 5.8 remote nodes - SSH options as a separate argument for the SSH connector 0.002002 - 2012-07-23 - timeouts for connection setup - support Object::Remote->start::connect - timer support in MiniLoop 0.002001 - 2012-07-18 - start::, maybe::start:: and next:: - automatic prompting for sudo passwords - allow transfer of glob references - allow loading of classes and packages from __DATA__ - allow transfer of scalar references 0.001001 - 2012-07-12 - initial release