Object-Remote
view release on metacpan or search on metacpan
Revision history for Object-Remote
0.004004 - 2024-05-23
- fix Future::PP not being available when needed on remote side
- fix tests to work without . in @INC
0.004003 - 2024-05-21
- update git repository in metadata
0.004002 - 2024-05-21
- fix compatibility with Log::Contextual 0.009000+
- fix developer tests
0.004001 - 2019-11-27
- fix working with Moo 2.003005 and newer
- Fix LocalSudo
0.004000 - 2016-08-26
- Add INET connector
- Make strictures dep explicit
0.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
Terms of the Perl programming language system itself
a) the GNU General Public License as published by the Free
Software Foundation; either version 1, or (at your option) any
later version, or
b) the "Artistic License"
--- The GNU General Public License, Version 1, February 1989 ---
This software is Copyright (c) 2024 by mst - Matt S. Trout (cpan:MSTROUT) <mst@shadowcat.co.uk>.
This is free software, licensed under:
The GNU General Public License, Version 1, February 1989
GNU GENERAL PUBLIC LICENSE
Version 1, February 1989
Copyright (C) 1989 Free Software Foundation, Inc.
51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
Everyone is permitted to copy and distribute verbatim copies
of this license document, but changing it is not allowed.
Preamble
The license agreements of most software companies try to keep users
at the mercy of those companies. By contrast, our General Public
License is intended to guarantee your freedom to share and change free
software--to make sure the software is free for all its users. The
General Public License applies to the Free Software Foundation's
software and to any other program whose authors commit to using it.
You can use it for your programs, too.
When we speak of free software, we are referring to freedom, not
price. Specifically, the General Public License is designed to make
sure that you have the freedom to give away or sell copies of free
software, that you receive source code or can get it if you want it,
that you can change the software or use pieces of it in new free
programs; and that you know you can do these things.
To protect your rights, we need to make restrictions that forbid
anyone to deny you these rights or to ask you to surrender the rights.
These restrictions translate to certain responsibilities for you if you
distribute copies of the software, or if you modify it.
For example, if you distribute copies of a such a program, whether
gratis or for a fee, you must give the recipients all the rights that
you have. You must make sure that they, too, receive or can get the
source code. And you must tell them their rights.
We protect your rights with two steps: (1) copyright the software, and
(2) offer you this license which gives you legal permission to copy,
distribute and/or modify the software.
Also, for each author's protection and ours, we want to make certain
that everyone understands that there is no warranty for this free
software. If the software is modified by someone else and passed on, we
want its recipients to know that what they have is not the original, so
that any problems introduced by others will not reflect on the original
authors' reputations.
The precise terms and conditions for copying, distribution and
modification follow.
GNU GENERAL PUBLIC LICENSE
TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION
0. This License Agreement applies to any program or other work which
contains a notice placed by the copyright holder saying it may be
distributed under the terms of this General Public License. The
"Program", below, refers to any such program or work, and a "work based
on the Program" means either the Program or any work containing the
Program or a portion of it, either verbatim or with modifications. Each
licensee is addressed as "you".
1. You may copy and distribute verbatim copies of the Program's source
code as you receive it, in any medium, provided that you conspicuously and
appropriately publish on each copy an appropriate copyright notice and
disclaimer of warranty; keep intact all the notices that refer to this
General Public License and to the absence of any warranty; and give any
other recipients of the Program a copy of this General Public License
along with the Program. You may charge a fee for the physical act of
transferring a copy.
2. You may modify your copy or copies of the Program or any portion of
it, and copy and distribute such modifications under the terms of Paragraph
1 above, provided that you also do the following:
a) cause the modified files to carry prominent notices stating that
you changed the files and the date of any change; and
b) cause the whole of any work that you distribute or publish, that
in whole or in part contains the Program or any part thereof, either
with or without modifications, to be licensed at no charge to all
third parties under the terms of this General Public License (except
that you may choose to grant warranty protection to some or all
third parties, at your option).
c) If the modified program normally reads commands interactively when
run, you must cause it, when started running for such interactive use
in the simplest and most usual way, to print or display an
announcement including an appropriate copyright notice and a notice
that there is no warranty (or else, saying that you provide a
warranty) and that users may redistribute the program under these
conditions, and telling the user how to view a copy of this General
Public License.
d) You may charge a fee for the physical act of transferring a
copy, and you may at your option offer warranty protection in
exchange for a fee.
Mere aggregation of another independent work with the Program (or its
derivative) on a volume of a storage or distribution medium does not bring
the other work under the scope of these terms.
3. You may copy and distribute the Program (or a portion or derivative of
it, under Paragraph 2) in object code or executable form under the terms of
Paragraphs 1 and 2 above provided that you also do one of the following:
a) accompany it with the complete corresponding machine-readable
source code, which must be distributed under the terms of
Paragraphs 1 and 2 above; or,
b) accompany it with a written offer, valid for at least three
years, to give any third party free (except for a nominal charge
for the cost of distribution) a complete machine-readable copy of the
corresponding source code, to be distributed under the terms of
Paragraphs 1 and 2 above; or,
c) accompany it with the information you received as to where the
corresponding source code may be obtained. (This alternative is
allowed only for noncommercial distribution and only if you
received the program in object code or executable form alone.)
Source code for a work means the preferred form of the work for making
modifications to it. For an executable file, complete source code means
all the source code for all modules it contains; but, as a special
exception, it need not include source code for modules which are standard
libraries that accompany the operating system on which the executable
file runs, or for standard header files or definitions files that
accompany that operating system.
4. You may not copy, modify, sublicense, distribute or transfer the
Program except as expressly provided under this General Public License.
Any attempt otherwise to copy, modify, sublicense, distribute or transfer
the Program is void, and will automatically terminate your rights to use
the Program under this License. However, parties who have received
copies, or rights to use copies, from you under this General Public
License will not have their licenses terminated so long as such parties
remain in full compliance.
5. By copying, distributing or modifying the Program (or any work based
on the Program) you indicate your acceptance of this license to do so,
and all its terms and conditions.
6. Each time you redistribute the Program (or any work based on the
Program), the recipient automatically receives a license from the original
licensor to copy, distribute or modify the Program subject to these
terms and conditions. You may not impose any further restrictions on the
recipients' exercise of the rights granted herein.
7. The Free Software Foundation may publish revised and/or new versions
of the General Public License from time to time. Such new versions will
be similar in spirit to the present version, but may differ in detail to
address new problems or concerns.
Each version is given a distinguishing version number. If the Program
specifies a version number of the license which applies to it and "any
later version", you have the option of following the terms and conditions
either of that version or of any later version published by the Free
Software Foundation. If the Program does not specify a version number of
the license, you may choose any version ever published by the Free Software
Foundation.
8. If you wish to incorporate parts of the Program into other free
programs whose distribution conditions are different, write to the author
to ask for permission. For software which is copyrighted by the Free
Software Foundation, write to the Free Software Foundation; we sometimes
make exceptions for this. Our decision will be guided by the two goals
of preserving the free status of all derivatives of our free software and
of promoting the sharing and reuse of software generally.
NO WARRANTY
9. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY
FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN
OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES
PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED
OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS
TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE
PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING,
REPAIR OR CORRECTION.
10. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING
WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR
REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES,
INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING
OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED
TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY
YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER
PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE
POSSIBILITY OF SUCH DAMAGES.
END OF TERMS AND CONDITIONS
Appendix: How to Apply These Terms to Your New Programs
If you develop a new program, and you want it to be of the greatest
possible use to humanity, the best way to achieve this is to make it
free software which everyone can redistribute and change under these
terms.
To do so, attach the following notices to the program. It is safest to
attach them to the start of each source file to most effectively convey
the exclusion of warranty; and each file should have at least the
"copyright" line and a pointer to where the full notice is found.
<one line to give the program's name and a brief idea of what it does.>
Copyright (C) 19yy <name of author>
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 1, or (at your option)
any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston MA 02110-1301 USA
Also add information on how to contact you by electronic and paper mail.
If the program is interactive, make it output a short notice like this
when it starts in an interactive mode:
Gnomovision version 69, Copyright (C) 19xx name of author
Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'.
This is free software, and you are welcome to redistribute it
under certain conditions; type `show c' for details.
The hypothetical commands `show w' and `show c' should show the
appropriate parts of the General Public License. Of course, the
commands you use may be called something other than `show w' and `show
c'; they could even be mouse-clicks or menu items--whatever suits your
program.
You should also get your employer (if you work as a programmer) or your
school, if any, to sign a "copyright disclaimer" for the program, if
necessary. Here a sample; alter the names:
Yoyodyne, Inc., hereby disclaims all copyright interest in the
program `Gnomovision' (a program to direct compilers to make passes
at assemblers) written by James Hacker.
<signature of Ty Coon>, 1 April 1989
Ty Coon, President of Vice
That's all there is to it!
--- The Perl Artistic License 1.0 ---
This software is Copyright (c) 2024 by mst - Matt S. Trout (cpan:MSTROUT) <mst@shadowcat.co.uk>.
This is free software, licensed under:
The Perl Artistic License 1.0
The "Artistic License"
Preamble
The intent of this document is to state the conditions under which a
Package may be copied, such that the Copyright Holder maintains some
semblance of artistic control over the development of the package,
while giving the users of the package the right to use and distribute
the Package in a more-or-less customary fashion, plus the right to make
reasonable modifications.
Definitions:
"Package" refers to the collection of files distributed by the
Copyright Holder, and derivatives of that collection of files
created through textual modification.
"Standard Version" refers to such a Package if it has not been
modified, or has been modified in accordance with the wishes
of the Copyright Holder as specified below.
"Copyright Holder" is whoever is named in the copyright or
copyrights for the package.
"You" is you, if you're thinking about copying or distributing
this Package.
"Reasonable copying fee" is whatever you can justify on the
basis of media cost, duplication charges, time of people involved,
and so on. (You will not be required to justify it to the
Copyright Holder, but only to the computing community at large
as a market that must bear the fee.)
"Freely Available" means that no fee is charged for the item
itself, though there may be fees involved in handling the item.
It also means that recipients of the item may redistribute it
under the same conditions they received it.
1. You may make and give away verbatim copies of the source form of the
Standard Version of this Package without restriction, provided that you
duplicate all of the original copyright notices and associated disclaimers.
2. You may apply bug fixes, portability fixes and other modifications
derived from the Public Domain or from the Copyright Holder. A Package
modified in such a way shall still be considered the Standard Version.
3. You may otherwise modify your copy of this Package in any way, provided
that you insert a prominent notice in each changed file stating how and
when you changed that file, and provided that you do at least ONE of the
following:
a) place your modifications in the Public Domain or otherwise make them
Freely Available, such as by posting said modifications to Usenet or
an equivalent medium, or placing the modifications on a major archive
site such as uunet.uu.net, or by allowing the Copyright Holder to include
your modifications in the Standard Version of the Package.
b) use the modified Package only within your corporation or organization.
c) rename any non-standard executables so the names do not conflict
with standard executables, which must also be provided, and provide
a separate manual page for each non-standard executable that clearly
documents how it differs from the Standard Version.
d) make other distribution arrangements with the Copyright Holder.
4. You may distribute the programs of this Package in object code or
executable form, provided that you do at least ONE of the following:
a) distribute a Standard Version of the executables and library files,
together with instructions (in the manual page or equivalent) on where
to get the Standard Version.
b) accompany the distribution with the machine-readable source of
the Package with your modifications.
c) give non-standard executables non-standard names, and clearly
document the differences in manual pages (or equivalent), together
with instructions on where to get the Standard Version.
d) make other distribution arrangements with the Copyright Holder.
5. You may charge a reasonable copying fee for any distribution of this
Package. You may charge any fee you choose for support of this
Package. You may not charge a fee for this Package itself. However,
you may distribute this Package in aggregate with other (possibly
commercial) programs as part of a larger (possibly commercial) software
distribution provided that you do not advertise this Package as a
product of your own. You may embed this Package's interpreter within
an executable of yours (by linking); this shall be construed as a mere
form of aggregation, provided that the complete Standard Version of the
interpreter is so embedded.
6. The scripts and library files supplied as input to or produced as
output from the programs of this Package do not automatically fall
under the copyright of this Package, but belong to whoever generated
them, and may be sold commercially, and may be aggregated with this
Package. If such scripts or library files are aggregated with this
Package via the so-called "undump" or "unexec" methods of producing a
binary executable image, then distribution of such an image shall
neither be construed as a distribution of this Package nor shall it
fall under the restrictions of Paragraphs 3 and 4, provided that you do
not represent such an executable image as a Standard Version of this
Package.
7. C subroutines (or comparably compiled subroutines in other
languages) supplied by you and linked into this Package in order to
emulate subroutines and variables of the language defined by this
Package shall not be considered part of this Package, but are the
equivalent of input as in Paragraph 6, provided these subroutines do
not change the language in any way that would cause it to fail the
regression tests for the language.
8. Aggregation of this Package with a commercial distribution is always
permitted provided that the use of this Package is embedded; that is,
when no overt attempt is made to make this Package's interfaces visible
to the end user of the commercial distribution. Such use shall not be
construed as a distribution of this Package.
9. The name of the Copyright Holder may not be used to endorse or promote
products derived from this software without specific prior written permission.
10. THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR
IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED
WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE.
The End
bin/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/INET.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/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)
LICENSE LICENSE file (added by Distar)
{
"abstract" : "Call methods on objects in other processes or on other hosts",
"author" : [
"mst - Matt S. Trout (cpan:MSTROUT) <mst@shadowcat.co.uk>"
],
"dynamic_config" : 1,
"generated_by" : "ExtUtils::MakeMaker version 7.70, CPAN::Meta::Converter version 2.150010",
"license" : [
"perl_5"
],
"meta-spec" : {
"url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec",
"version" : 2
},
"name" : "Object-Remote",
"no_index" : {
"directory" : [
"t",
"xt"
]
},
"prereqs" : {
"build" : {
"requires" : {}
},
"configure" : {
"requires" : {
"ExtUtils::MakeMaker" : "0"
}
},
"develop" : {
"requires" : {
"Class::Load" : "0"
}
},
"runtime" : {
"requires" : {
"Class::C3" : "0",
"Devel::GlobalDestruction" : "0",
"Future" : "0.49",
"JSON::PP" : "0",
"Log::Contextual" : "0.005",
"MRO::Compat" : "0",
"Module::Runtime" : "0",
"Moo" : "1.006",
"String::ShellQuote" : "0",
"strictures" : "2"
}
},
"test" : {
"requires" : {
"Test::More" : "0.96"
}
}
},
"release_status" : "stable",
"resources" : {
"bugtracker" : {
"mailto" : "bug-Object-Remote@rt.cpan.org",
"web" : "https://rt.cpan.org/Public/Dist/Display.html?Name=Object-Remote"
},
"license" : [
"http://dev.perl.org/licenses/"
],
"repository" : {
"type" : "git",
"url" : "https://github.com/p5sagit/Object-Remote.git",
"web" : "https://github.com/p5sagit/Object-Remote"
}
},
"version" : "0.004004",
"x_authority" : "cpan:MSTROUT",
"x_serialization_backend" : "JSON::PP version 4.16"
}
---
abstract: 'Call methods on objects in other processes or on other hosts'
author:
- 'mst - Matt S. Trout (cpan:MSTROUT) <mst@shadowcat.co.uk>'
build_requires:
Test::More: '0.96'
configure_requires:
ExtUtils::MakeMaker: '0'
dynamic_config: 1
generated_by: 'ExtUtils::MakeMaker version 7.70, CPAN::Meta::Converter version 2.150010'
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
- xt
requires:
Class::C3: '0'
Devel::GlobalDestruction: '0'
Future: '0.49'
JSON::PP: '0'
Log::Contextual: '0.005'
MRO::Compat: '0'
Module::Runtime: '0'
Moo: '1.006'
String::ShellQuote: '0'
strictures: '2'
resources:
bugtracker: https://rt.cpan.org/Public/Dist/Display.html?Name=Object-Remote
license: http://dev.perl.org/licenses/
repository: https://github.com/p5sagit/Object-Remote.git
version: '0.004004'
x_authority: cpan:MSTROUT
x_serialization_backend: 'CPAN::Meta::YAML version 0.018'
Makefile.PL view on Meta::CPAN
use strict;
use warnings FATAL => 'all';
use 5.008;
my %META = (
name => 'Object-Remote',
license => 'perl_5',
prereqs => {
configure => { requires => {
'ExtUtils::MakeMaker' => 0,
} },
build => { requires => {
} },
test => {
requires => {
'Test::More' => '0.96',
},
},
runtime => {
requires => {
'Moo' => 1.006,
'Module::Runtime' => 0,
'JSON::PP' => 0,
'Future' => 0.49,
'MRO::Compat' => 0, # required to fatpack Moo
'Class::C3' => 0, # required to fatpack Moo
'Devel::GlobalDestruction' => 0, # required to fatpack Moo
'String::ShellQuote' => 0, # required for ssh argument manipulation
'Log::Contextual' => 0.005000,
'strictures' => 2,
},
},
develop => {
requires => {
'Class::Load' => 0,
},
},
},
resources => {
repository => {
url => 'https://github.com/p5sagit/Object-Remote.git',
web => 'https://github.com/p5sagit/Object-Remote',
type => 'git',
},
bugtracker => {
web => 'https://rt.cpan.org/Public/Dist/Display.html?Name=Object-Remote',
mailto => 'bug-Object-Remote@rt.cpan.org',
},
license => [ 'http://dev.perl.org/licenses/' ],
},
no_index => {
directory => [ 't', 'xt' ]
},
x_authority => 'cpan:MSTROUT',
);
my %MM_ARGS = (
EXE_FILES => [
'bin/object-remote-node',
'bin/object-remote-slave',
'bin/remoterepl',
],
);
## BOILERPLATE ###############################################################
require ExtUtils::MakeMaker;
(do './maint/Makefile.PL.include' or die $@) unless -f 'META.yml';
# have to do this since old EUMM dev releases miss the eval $VERSION line
my $eumm_version = eval $ExtUtils::MakeMaker::VERSION;
my $mymeta = $eumm_version >= 6.57_02;
my $mymeta_broken = $mymeta && $eumm_version < 6.57_07;
($MM_ARGS{NAME} = $META{name}) =~ s/-/::/g;
($MM_ARGS{VERSION_FROM} = "lib/$MM_ARGS{NAME}.pm") =~ s{::}{/}g;
$META{license} = [ $META{license} ]
if $META{license} && !ref $META{license};
$MM_ARGS{LICENSE} = $META{license}[0]
if $META{license} && $eumm_version >= 6.30;
$MM_ARGS{NO_MYMETA} = 1
if $mymeta_broken;
$MM_ARGS{META_ADD} = { 'meta-spec' => { version => 2 }, %META }
unless -f 'META.yml';
$MM_ARGS{PL_FILES} ||= {};
$MM_ARGS{NORECURS} = 1
if not exists $MM_ARGS{NORECURS};
for (qw(configure build test runtime)) {
my $key = $_ eq 'runtime' ? 'PREREQ_PM' : uc $_.'_REQUIRES';
my $r = $MM_ARGS{$key} = {
%{$META{prereqs}{$_}{requires} || {}},
%{delete $MM_ARGS{$key} || {}},
};
defined $r->{$_} or delete $r->{$_} for keys %$r;
}
$MM_ARGS{MIN_PERL_VERSION} = delete $MM_ARGS{PREREQ_PM}{perl} || 0;
delete $MM_ARGS{MIN_PERL_VERSION}
if $eumm_version < 6.47_01;
$MM_ARGS{BUILD_REQUIRES} = {%{$MM_ARGS{BUILD_REQUIRES}}, %{delete $MM_ARGS{TEST_REQUIRES}}}
if $eumm_version < 6.63_03;
$MM_ARGS{PREREQ_PM} = {%{$MM_ARGS{PREREQ_PM}}, %{delete $MM_ARGS{BUILD_REQUIRES}}}
if $eumm_version < 6.55_01;
delete $MM_ARGS{CONFIGURE_REQUIRES}
if $eumm_version < 6.51_03;
ExtUtils::MakeMaker::WriteMakefile(%MM_ARGS);
## END BOILERPLATE ###########################################################
NAME
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) <mst@shadowcat.co.uk>
CONTRIBUTORS
bfwg - Colin Newell (cpan:NEWELLC) <colin.newell@gmail.com>
phaylon - Robert Sedlacek (cpan:PHAYLON) <r.sedlacek@shadowcat.co.uk>
triddle - Tyler Riddle (cpan:TRIDDLE) <t.riddle@shadowcat.co.uk>
SPONSORS
Parts of this code were paid for by
Socialflow L<http://www.socialflow.com>
Shadowcat Systems L<http://www.shadow.cat>
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.
bin/object-remote-node view on Meta::CPAN
#!/usr/bin/env perl
use strictures 1;
use Object::Remote::Node;
Object::Remote::Node->run;
bin/object-remote-slave view on Meta::CPAN
#!/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;
bin/remoterepl view on Meta::CPAN
#!/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;
}
lib/Object/Remote.pm view on Meta::CPAN
package 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.004004'; # v0.4.4
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</connect> method to create a connection
to a remote process/host, L</new::on> to create an object on a connection,
and L</can::on> to retrieve a subref over a connection.
=head2 Object::Remote::Connection
The object representing a connection, which provides the
L<Object::Remote::Connection/remote_object> and
L<Object::Remote::Connection/remote_sub> methods that are used by
L</new::on> and L</can::on> 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<Object::Remote::Future/start::method> syntax for calling a possibly
asynchronous method without blocking, and
L<Object::Remote::Future/await_future> and L<Object::Remote::Future/await_all>
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<Object::Remote::Logging::Logger>.
=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<Object::Remote::Logging>.
=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<Object::Remote::Logging>.
=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<Object::Remote::Role::Connector::PerlInterpreter>
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<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.
=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<Object::Remote::Logging> for information on log forwarding.
=back
=head1 SUPPORT
IRC: #web-simple on irc.perl.org
=head1 AUTHOR
mst - Matt S. Trout (cpan:MSTROUT) <mst@shadowcat.co.uk>
=head1 CONTRIBUTORS
bfwg - Colin Newell (cpan:NEWELLC) <colin.newell@gmail.com>
phaylon - Robert Sedlacek (cpan:PHAYLON) <r.sedlacek@shadowcat.co.uk>
triddle - Tyler Riddle (cpan:TRIDDLE) <t.riddle@shadowcat.co.uk>
=head1 SPONSORS
Parts of this code were paid for by
Socialflow L<http://www.socialflow.com>
Shadowcat Systems L<http://www.shadow.cat>
=head1 COPYRIGHT
Copyright (c) 2012 the Object::Remote L</AUTHOR>, L</CONTRIBUTORS> and
L</SPONSORS> as listed above.
=head1 LICENSE
This library is free software and may be distributed under the same terms
as perl itself.
=cut
lib/Object/Remote/CodeContainer.pm view on Meta::CPAN
package Object::Remote::CodeContainer;
use Moo;
has code => (is => 'ro', required => 1);
sub call {
my $self = shift;
$self->code->(@_)
}
1;
lib/Object/Remote/Connection.pm view on Meta::CPAN
package 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
Object::Remote::Connector::INET
);
}
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<Object::Remote>
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<Object::Remote::Role::Connector::PerlInterpreter>
=item C<Object::Remote>
=back
=cut
lib/Object/Remote/ConnectionServer.pm view on Meta::CPAN
package 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;
lib/Object/Remote/Connector/INET.pm view on Meta::CPAN
package Object::Remote::Connector::INET;
use IO::Socket::INET;
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::INET->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 /^.+:\d+$/) {
my $socket = shift(@_);
return __PACKAGE__->new(@_, socket_path => $socket);
}
}
return;
};
1;
lib/Object/Remote/Connector/Local.pm view on Meta::CPAN
package 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;
lib/Object/Remote/Connector/LocalSudo.pm view on Meta::CPAN
package 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;
lib/Object/Remote/Connector/SSH.pm view on Meta::CPAN
package 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;
lib/Object/Remote/Connector/STDIO.pm view on Meta::CPAN
package 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;
lib/Object/Remote/Connector/UNIX.pm view on Meta::CPAN
package 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;
lib/Object/Remote/FatNode.pm view on Meta::CPAN
package 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
-mFuture::PP
-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
-mDevel::GlobalDestruction
-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;
lib/Object/Remote/FromData.pm view on Meta::CPAN
package 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;
lib/Object/Remote/Future.pm view on Meta::CPAN
package 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<Object::Remote>
=head1 LAME
Shipping prioritised over writing this part up. Blame mst.
=cut
lib/Object/Remote/GlobContainer.pm view on Meta::CPAN
package 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;
lib/Object/Remote/GlobProxy.pm view on Meta::CPAN
use 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;
lib/Object/Remote/Handle.pm view on Meta::CPAN
package 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;
lib/Object/Remote/Logging.pm view on Meta::CPAN
package Object::Remote::Logging;
use Moo;
use Object::Remote::Logging::Logger;
use Exporter ();
extends 'Log::Contextual';
our @EXPORT_OK = qw(router arg_levels);
sub import {
my $class = shift;
my $caller = caller;
my @args = ($class);
our $DID_INIT;
unless($DID_INIT) {
$DID_INIT = 1;
init_logging();
}
for my $arg (@_) {
if (grep $_ eq $arg, @EXPORT_OK) {
no strict 'refs';
*{$caller . '::' . $arg} = \&{$arg};
}
else {
push @args, $arg;
}
}
@_ = @args;
goto &Log::Contextual::import;
}
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 _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<Log::Contextual> 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<Object::Remote::Logging::Logger>
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<Object::Remote::Logging::Logger>. 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<Object::Remote::Logging::Logger> 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<Object::Remote::Logging::Router> that is in use. The router
instance is used in combination with L<Object::Remote::Logging::Logger> objects to
select then render and output log messages.
=item log_<level> and Dlog_<level>
These methods come direct from L<Log::Contextual>; 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_<level> and DlogS_<level>
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
lib/Object/Remote/Logging/LogAnyInjector.pm view on Meta::CPAN
package 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;
lib/Object/Remote/Logging/Logger.pm view on Meta::CPAN
package 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<Object::Remote::Logging::Router>,
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
lib/Object/Remote/Logging/Router.pm view on Meta::CPAN
package 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;
( run in 1.973 second using v1.01-cache-2.11-cpan-efa8479b9fe )