@srcdir@/src/libopensrf/osrfConfig.c
-EXTRA_DIST = $(DOC_FILES) $(EXAMPLES_FILES) $(libosrf_FILES) $(strn_compat_FILES) $(python_FILES) $(java_FILES) @srcdir@/autogen.sh @srcdir@/src/extras @srcdir@/DCO-1.1.txt @srcdir@/LICENSE.txt @srcdir@/src/perlmods @srcdir@/src/javascript
+EXTRA_DIST = $(DOC_FILES) $(EXAMPLES_FILES) $(libosrf_FILES) $(strn_compat_FILES) $(python_FILES) $(java_FILES) @srcdir@/autogen.sh @srcdir@/src/extras @srcdir@/DCO-1.1.txt @srcdir@/LICENSE.txt @srcdir@/src/perl @srcdir@/src/javascript
opensrfincludedir = @includedir@/opensrf
export OPENSRF = opensrf
export BINDIR = @bindir@
export LIBDIR = @libdir@
-perldir = $(LIBDIR)/perl5
jsdir = $(LIBDIR)/javascript
export OSRF_JAVA_DEPSDIR = @OSRF_JAVA_DEPSDIR@
etcdir = $(ETCDIR)
mkdir -p $(LOG)
mkdir -p $(SOCK)
mkdir -p $(jsdir)
- mkdir -p $(perldir)
+ make install-perl
install-exec-hook:
sed -i 's|LOCALSTATEDIR|$(VAR)|g' '$(DESTDIR)@sysconfdir@/opensrf.xml.example'
sed -i 's|LIBDIR|$(LIBDIR)|g' '@abs_top_srcdir@/examples/multisession-test.pl'
sed -i 's|SYSCONFDIR|$(ETCDIR)|g' '@abs_top_srcdir@/doc/dokuwiki-doc-stubber.pl'
cp -r @srcdir@/javascript/* $(jsdir)/
- sed -i 's|LOCALSTATEDIR|$(VAR)|g' '@srcdir@/perlmods/OpenSRF/Utils/Config.pm'
- cp -r @srcdir@/perlmods/* $(perldir)/
+install-perl:
+ cd ./perl && perl Makefile.PL || make -s install-perl-fail
+ make -C perl
+ make -C perl test || make -s install-perl-fail
+ make -C perl install
+
+install-perl-fail:
+ echo
+ echo ">>> Installation of Perl modules has failed. The most likely"
+ echo ">>> possibility is that a dependency is not pre-installed"
+ echo ">>> or that a test has failed."
+ echo ">>> See the messages above this one for more information."
+ echo
+ exit 1
+
uninstall-hook:
rm @includedir@/opensrf/apachetools.h
rm -R $(jsdir)
- rm -R $(perldir)
AM_LDFLAGS = -L$(LIBDIR) -L@top_builddir@/src/libopensrf
install-exec-local:
+ if [ ! "$$(grep mod_placeholder `apxs2 -q SYSCONFDIR`/httpd.conf)" ]; \
+ then echo -e "#\n#LoadModule mod_placeholder /usr/lib/apache2/modules/mod_placeholder.so" \
+ >> `apxs2 -q SYSCONFDIR`/httpd.conf; \
+ fi
$(APXS2) -c $(DEF_LDLIBS) $(AM_CFLAGS) $(AM_LDFLAGS) @srcdir@/osrf_json_gateway.c apachetools.c apachetools.h libopensrf.so
$(APXS2) -c $(DEF_LDLIBS) $(AM_CFLAGS) $(AM_LDFLAGS) @srcdir@/osrf_http_translator.c apachetools.c apachetools.h libopensrf.so
$(APXS2) -i -a @srcdir@/osrf_json_gateway.la
--- /dev/null
+Revision history for OpenSRF
+
+0.9 2006/07
+ First version, released on an unsuspecting world.
+
--- /dev/null
+Changes
+MANIFEST
+Makefile.PL
+README
+lib/OpenSRF.pm
+lib/OpenSRF/Application.pm
+lib/OpenSRF/Application/Client.pm
+lib/OpenSRF/Application/Persist.pm
+lib/OpenSRF/Application/Settings.pm
+lib/OpenSRF/Application/Demo/Math.pm
+lib/OpenSRF/Application/Demo/MathDB.pm
+lib/OpenSRF/AppSession.pm
+lib/OpenSRF/DomainObject/oilsMessage.pm
+lib/OpenSRF/DomainObject/oilsMethod.pm
+lib/OpenSRF/DomainObject/oilsResponse.pm
+lib/OpenSRF/EX.pm
+lib/OpenSRF/MultiSession.pm
+lib/OpenSRF/System.pm
+lib/OpenSRF/Transport.pm
+lib/OpenSRF/Transport/Listener.pm
+lib/OpenSRF/Transport/PeerHandle.pm
+lib/OpenSRF/Transport/SlimJabber.pm
+lib/OpenSRF/Transport/SlimJabber/Client.pm
+lib/OpenSRF/Transport/SlimJabber/Inbound.pm
+lib/OpenSRF/Transport/SlimJabber/MessageWrapper.pm
+lib/OpenSRF/Transport/SlimJabber/PeerConnection.pm
+lib/OpenSRF/Transport/SlimJabber/XMPPMessage.pm
+lib/OpenSRF/Transport/SlimJabber/XMPPReader.pm
+lib/OpenSRF/UnixServer.pm
+lib/OpenSRF/Utils.pm
+lib/OpenSRF/Utils/Cache.pm
+lib/OpenSRF/Utils/Config.pm
+lib/OpenSRF/Utils/JSON.pm
+lib/OpenSRF/Utils/Logger.pm
+lib/OpenSRF/Utils/LogServer.pm
+lib/OpenSRF/Utils/SettingsClient.pm
+lib/OpenSRF/Utils/SettingsParser.pm
+t/00-load.t
+t/pod-coverage.t
+t/pod.t
--- /dev/null
+use inc::Module::Install;
+
+# Define metadata
+name 'OpenSRF';
+all_from 'lib/OpenSRF.pm';
+license 'perl';
+
+# Specific dependencies
+requires 'Cache::Memcached' => 0;
+requires 'Data::Dumper' => 0;
+requires 'DateTime' => 0;
+requires 'DBI' => 0;
+requires 'Digest::MD5' => 0;
+requires 'Errno' => 0;
+requires 'Error' => 0;
+requires 'FreezeThaw' => 0;
+requires 'IO' => 0;
+requires 'JSON' => 0;
+requires 'Net::Domain' => 0;
+requires 'Net::Server' => 0;
+requires 'Time::HiRes' => 0;
+requires 'Time::Local' => 0;
+requires 'UNIVERSAL::require' => 0;
+requires 'XML::LibXML' => 0;
+
+WriteAll;
--- /dev/null
+OpenSRF
+
+OpenSRF (Open OpenSRF (Open Scalable Request Framework) is a core
+subsystem of the Evergreen ILS.
+
+INSTALLATION
+
+To install this module, run the following commands:
+
+ perl Makefile.PL
+ make
+ make test
+ make install
+
+SUPPORT AND DOCUMENTATION
+
+After installing, you can find documentation for this module with the
+perldoc command.
+
+ perldoc OpenSRF
+
+You can also look for information at:
+
+ http://svn.open-ils.org/trac/OpenSRF
+
+
+COPYRIGHT AND LICENCE
+
+Copyright (C) 2008 Equinox Software, Inc.
+
+This program is free software; you can redistribute it and/or modify it
+under the same terms as Perl itself.
+
--- /dev/null
+#line 1
+package Module::Install;
+
+# For any maintainers:
+# The load order for Module::Install is a bit magic.
+# It goes something like this...
+#
+# IF ( host has Module::Install installed, creating author mode ) {
+# 1. Makefile.PL calls "use inc::Module::Install"
+# 2. $INC{inc/Module/Install.pm} set to installed version of inc::Module::Install
+# 3. The installed version of inc::Module::Install loads
+# 4. inc::Module::Install calls "require Module::Install"
+# 5. The ./inc/ version of Module::Install loads
+# } ELSE {
+# 1. Makefile.PL calls "use inc::Module::Install"
+# 2. $INC{inc/Module/Install.pm} set to ./inc/ version of Module::Install
+# 3. The ./inc/ version of Module::Install loads
+# }
+
+BEGIN {
+ require 5.004;
+}
+use strict 'vars';
+
+use vars qw{$VERSION};
+BEGIN {
+ # All Module::Install core packages now require synchronised versions.
+ # This will be used to ensure we don't accidentally load old or
+ # different versions of modules.
+ # This is not enforced yet, but will be some time in the next few
+ # releases once we can make sure it won't clash with custom
+ # Module::Install extensions.
+ $VERSION = '0.76';
+
+ *inc::Module::Install::VERSION = *VERSION;
+ @inc::Module::Install::ISA = __PACKAGE__;
+
+}
+
+
+
+
+
+# Whether or not inc::Module::Install is actually loaded, the
+# $INC{inc/Module/Install.pm} is what will still get set as long as
+# the caller loaded module this in the documented manner.
+# If not set, the caller may NOT have loaded the bundled version, and thus
+# they may not have a MI version that works with the Makefile.PL. This would
+# result in false errors or unexpected behaviour. And we don't want that.
+my $file = join( '/', 'inc', split /::/, __PACKAGE__ ) . '.pm';
+unless ( $INC{$file} ) { die <<"END_DIE" }
+
+Please invoke ${\__PACKAGE__} with:
+
+ use inc::${\__PACKAGE__};
+
+not:
+
+ use ${\__PACKAGE__};
+
+END_DIE
+
+
+
+
+
+# If the script that is loading Module::Install is from the future,
+# then make will detect this and cause it to re-run over and over
+# again. This is bad. Rather than taking action to touch it (which
+# is unreliable on some platforms and requires write permissions)
+# for now we should catch this and refuse to run.
+if ( -f $0 and (stat($0))[9] > time ) { die <<"END_DIE" }
+
+Your installer $0 has a modification time in the future.
+
+This is known to create infinite loops in make.
+
+Please correct this, then run $0 again.
+
+END_DIE
+
+
+
+
+
+# Build.PL was formerly supported, but no longer is due to excessive
+# difficulty in implementing every single feature twice.
+if ( $0 =~ /Build.PL$/i ) { die <<"END_DIE" }
+
+Module::Install no longer supports Build.PL.
+
+It was impossible to maintain duel backends, and has been deprecated.
+
+Please remove all Build.PL files and only use the Makefile.PL installer.
+
+END_DIE
+
+
+
+
+
+# To save some more typing in Module::Install installers, every...
+# use inc::Module::Install
+# ...also acts as an implicit use strict.
+$^H |= strict::bits(qw(refs subs vars));
+
+
+
+
+
+use Cwd ();
+use File::Find ();
+use File::Path ();
+use FindBin;
+
+sub autoload {
+ my $self = shift;
+ my $who = $self->_caller;
+ my $cwd = Cwd::cwd();
+ my $sym = "${who}::AUTOLOAD";
+ $sym->{$cwd} = sub {
+ my $pwd = Cwd::cwd();
+ if ( my $code = $sym->{$pwd} ) {
+ # delegate back to parent dirs
+ goto &$code unless $cwd eq $pwd;
+ }
+ $$sym =~ /([^:]+)$/ or die "Cannot autoload $who - $sym";
+ unshift @_, ( $self, $1 );
+ goto &{$self->can('call')} unless uc($1) eq $1;
+ };
+}
+
+sub import {
+ my $class = shift;
+ my $self = $class->new(@_);
+ my $who = $self->_caller;
+
+ unless ( -f $self->{file} ) {
+ require "$self->{path}/$self->{dispatch}.pm";
+ File::Path::mkpath("$self->{prefix}/$self->{author}");
+ $self->{admin} = "$self->{name}::$self->{dispatch}"->new( _top => $self );
+ $self->{admin}->init;
+ @_ = ($class, _self => $self);
+ goto &{"$self->{name}::import"};
+ }
+
+ *{"${who}::AUTOLOAD"} = $self->autoload;
+ $self->preload;
+
+ # Unregister loader and worker packages so subdirs can use them again
+ delete $INC{"$self->{file}"};
+ delete $INC{"$self->{path}.pm"};
+
+ return 1;
+}
+
+sub preload {
+ my $self = shift;
+ unless ( $self->{extensions} ) {
+ $self->load_extensions(
+ "$self->{prefix}/$self->{path}", $self
+ );
+ }
+
+ my @exts = @{$self->{extensions}};
+ unless ( @exts ) {
+ my $admin = $self->{admin};
+ @exts = $admin->load_all_extensions;
+ }
+
+ my %seen;
+ foreach my $obj ( @exts ) {
+ while (my ($method, $glob) = each %{ref($obj) . '::'}) {
+ next unless $obj->can($method);
+ next if $method =~ /^_/;
+ next if $method eq uc($method);
+ $seen{$method}++;
+ }
+ }
+
+ my $who = $self->_caller;
+ foreach my $name ( sort keys %seen ) {
+ *{"${who}::$name"} = sub {
+ ${"${who}::AUTOLOAD"} = "${who}::$name";
+ goto &{"${who}::AUTOLOAD"};
+ };
+ }
+}
+
+sub new {
+ my ($class, %args) = @_;
+
+ # ignore the prefix on extension modules built from top level.
+ my $base_path = Cwd::abs_path($FindBin::Bin);
+ unless ( Cwd::abs_path(Cwd::cwd()) eq $base_path ) {
+ delete $args{prefix};
+ }
+
+ return $args{_self} if $args{_self};
+
+ $args{dispatch} ||= 'Admin';
+ $args{prefix} ||= 'inc';
+ $args{author} ||= ($^O eq 'VMS' ? '_author' : '.author');
+ $args{bundle} ||= 'inc/BUNDLES';
+ $args{base} ||= $base_path;
+ $class =~ s/^\Q$args{prefix}\E:://;
+ $args{name} ||= $class;
+ $args{version} ||= $class->VERSION;
+ unless ( $args{path} ) {
+ $args{path} = $args{name};
+ $args{path} =~ s!::!/!g;
+ }
+ $args{file} ||= "$args{base}/$args{prefix}/$args{path}.pm";
+ $args{wrote} = 0;
+
+ bless( \%args, $class );
+}
+
+sub call {
+ my ($self, $method) = @_;
+ my $obj = $self->load($method) or return;
+ splice(@_, 0, 2, $obj);
+ goto &{$obj->can($method)};
+}
+
+sub load {
+ my ($self, $method) = @_;
+
+ $self->load_extensions(
+ "$self->{prefix}/$self->{path}", $self
+ ) unless $self->{extensions};
+
+ foreach my $obj (@{$self->{extensions}}) {
+ return $obj if $obj->can($method);
+ }
+
+ my $admin = $self->{admin} or die <<"END_DIE";
+The '$method' method does not exist in the '$self->{prefix}' path!
+Please remove the '$self->{prefix}' directory and run $0 again to load it.
+END_DIE
+
+ my $obj = $admin->load($method, 1);
+ push @{$self->{extensions}}, $obj;
+
+ $obj;
+}
+
+sub load_extensions {
+ my ($self, $path, $top) = @_;
+
+ unless ( grep { lc $_ eq lc $self->{prefix} } @INC ) {
+ unshift @INC, $self->{prefix};
+ }
+
+ foreach my $rv ( $self->find_extensions($path) ) {
+ my ($file, $pkg) = @{$rv};
+ next if $self->{pathnames}{$pkg};
+
+ local $@;
+ my $new = eval { require $file; $pkg->can('new') };
+ unless ( $new ) {
+ warn $@ if $@;
+ next;
+ }
+ $self->{pathnames}{$pkg} = delete $INC{$file};
+ push @{$self->{extensions}}, &{$new}($pkg, _top => $top );
+ }
+
+ $self->{extensions} ||= [];
+}
+
+sub find_extensions {
+ my ($self, $path) = @_;
+
+ my @found;
+ File::Find::find( sub {
+ my $file = $File::Find::name;
+ return unless $file =~ m!^\Q$path\E/(.+)\.pm\Z!is;
+ my $subpath = $1;
+ return if lc($subpath) eq lc($self->{dispatch});
+
+ $file = "$self->{path}/$subpath.pm";
+ my $pkg = "$self->{name}::$subpath";
+ $pkg =~ s!/!::!g;
+
+ # If we have a mixed-case package name, assume case has been preserved
+ # correctly. Otherwise, root through the file to locate the case-preserved
+ # version of the package name.
+ if ( $subpath eq lc($subpath) || $subpath eq uc($subpath) ) {
+ my $content = Module::Install::_read($subpath . '.pm');
+ my $in_pod = 0;
+ foreach ( split //, $content ) {
+ $in_pod = 1 if /^=\w/;
+ $in_pod = 0 if /^=cut/;
+ next if ($in_pod || /^=cut/); # skip pod text
+ next if /^\s*#/; # and comments
+ if ( m/^\s*package\s+($pkg)\s*;/i ) {
+ $pkg = $1;
+ last;
+ }
+ }
+ }
+
+ push @found, [ $file, $pkg ];
+ }, $path ) if -d $path;
+
+ @found;
+}
+
+
+
+
+
+#####################################################################
+# Utility Functions
+
+sub _caller {
+ my $depth = 0;
+ my $call = caller($depth);
+ while ( $call eq __PACKAGE__ ) {
+ $depth++;
+ $call = caller($depth);
+ }
+ return $call;
+}
+
+sub _read {
+ local *FH;
+ open FH, "< $_[0]" or die "open($_[0]): $!";
+ my $str = do { local $/; <FH> };
+ close FH or die "close($_[0]): $!";
+ return $str;
+}
+
+sub _write {
+ local *FH;
+ open FH, "> $_[0]" or die "open($_[0]): $!";
+ foreach ( 1 .. $#_ ) { print FH $_[$_] or die "print($_[0]): $!" }
+ close FH or die "close($_[0]): $!";
+}
+
+sub _version ($) {
+ my $s = shift || 0;
+ $s =~ s/^(\d+)\.?//;
+ my $l = $1 || 0;
+ my @v = map { $_ . '0' x (3 - length $_) } $s =~ /(\d{1,3})\D?/g;
+ $l = $l . '.' . join '', @v if @v;
+ return $l + 0;
+}
+
+# Cloned from Params::Util::_CLASS
+sub _CLASS ($) {
+ (
+ defined $_[0]
+ and
+ ! ref $_[0]
+ and
+ $_[0] =~ m/^[^\W\d]\w*(?:::\w+)*$/s
+ ) ? $_[0] : undef;
+}
+
+1;
+
+# Copyright 2008 Adam Kennedy.
--- /dev/null
+#line 1
+package Module::Install::Base;
+
+$VERSION = '0.76';
+
+# Suspend handler for "redefined" warnings
+BEGIN {
+ my $w = $SIG{__WARN__};
+ $SIG{__WARN__} = sub { $w };
+}
+
+### This is the ONLY module that shouldn't have strict on
+# use strict;
+
+#line 41
+
+sub new {
+ my ($class, %args) = @_;
+
+ foreach my $method ( qw(call load) ) {
+ *{"$class\::$method"} = sub {
+ shift()->_top->$method(@_);
+ } unless defined &{"$class\::$method"};
+ }
+
+ bless( \%args, $class );
+}
+
+#line 61
+
+sub AUTOLOAD {
+ my $self = shift;
+ local $@;
+ my $autoload = eval { $self->_top->autoload } or return;
+ goto &$autoload;
+}
+
+#line 76
+
+sub _top { $_[0]->{_top} }
+
+#line 89
+
+sub admin {
+ $_[0]->_top->{admin} or Module::Install::Base::FakeAdmin->new;
+}
+
+#line 101
+
+sub is_admin {
+ $_[0]->admin->VERSION;
+}
+
+sub DESTROY {}
+
+package Module::Install::Base::FakeAdmin;
+
+my $Fake;
+sub new { $Fake ||= bless(\@_, $_[0]) }
+
+sub AUTOLOAD {}
+
+sub DESTROY {}
+
+# Restore warning handler
+BEGIN {
+ $SIG{__WARN__} = $SIG{__WARN__}->();
+}
+
+1;
+
+#line 146
--- /dev/null
+#line 1
+package Module::Install::Can;
+
+use strict;
+use Module::Install::Base;
+use Config ();
+### This adds a 5.005 Perl version dependency.
+### This is a bug and will be fixed.
+use File::Spec ();
+use ExtUtils::MakeMaker ();
+
+use vars qw{$VERSION $ISCORE @ISA};
+BEGIN {
+ $VERSION = '0.76';
+ $ISCORE = 1;
+ @ISA = qw{Module::Install::Base};
+}
+
+# check if we can load some module
+### Upgrade this to not have to load the module if possible
+sub can_use {
+ my ($self, $mod, $ver) = @_;
+ $mod =~ s{::|\\}{/}g;
+ $mod .= '.pm' unless $mod =~ /\.pm$/i;
+
+ my $pkg = $mod;
+ $pkg =~ s{/}{::}g;
+ $pkg =~ s{\.pm$}{}i;
+
+ local $@;
+ eval { require $mod; $pkg->VERSION($ver || 0); 1 };
+}
+
+# check if we can run some command
+sub can_run {
+ my ($self, $cmd) = @_;
+
+ my $_cmd = $cmd;
+ return $_cmd if (-x $_cmd or $_cmd = MM->maybe_command($_cmd));
+
+ for my $dir ((split /$Config::Config{path_sep}/, $ENV{PATH}), '.') {
+ my $abs = File::Spec->catfile($dir, $_[1]);
+ return $abs if (-x $abs or $abs = MM->maybe_command($abs));
+ }
+
+ return;
+}
+
+# can we locate a (the) C compiler
+sub can_cc {
+ my $self = shift;
+ my @chunks = split(/ /, $Config::Config{cc}) or return;
+
+ # $Config{cc} may contain args; try to find out the program part
+ while (@chunks) {
+ return $self->can_run("@chunks") || (pop(@chunks), next);
+ }
+
+ return;
+}
+
+# Fix Cygwin bug on maybe_command();
+if ( $^O eq 'cygwin' ) {
+ require ExtUtils::MM_Cygwin;
+ require ExtUtils::MM_Win32;
+ if ( ! defined(&ExtUtils::MM_Cygwin::maybe_command) ) {
+ *ExtUtils::MM_Cygwin::maybe_command = sub {
+ my ($self, $file) = @_;
+ if ($file =~ m{^/cygdrive/}i and ExtUtils::MM_Win32->can('maybe_command')) {
+ ExtUtils::MM_Win32->maybe_command($file);
+ } else {
+ ExtUtils::MM_Unix->maybe_command($file);
+ }
+ }
+ }
+}
+
+1;
+
+__END__
+
+#line 157
--- /dev/null
+#line 1
+package Module::Install::Fetch;
+
+use strict;
+use Module::Install::Base;
+
+use vars qw{$VERSION $ISCORE @ISA};
+BEGIN {
+ $VERSION = '0.76';
+ $ISCORE = 1;
+ @ISA = qw{Module::Install::Base};
+}
+
+sub get_file {
+ my ($self, %args) = @_;
+ my ($scheme, $host, $path, $file) =
+ $args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return;
+
+ if ( $scheme eq 'http' and ! eval { require LWP::Simple; 1 } ) {
+ $args{url} = $args{ftp_url}
+ or (warn("LWP support unavailable!\n"), return);
+ ($scheme, $host, $path, $file) =
+ $args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return;
+ }
+
+ $|++;
+ print "Fetching '$file' from $host... ";
+
+ unless (eval { require Socket; Socket::inet_aton($host) }) {
+ warn "'$host' resolve failed!\n";
+ return;
+ }
+
+ return unless $scheme eq 'ftp' or $scheme eq 'http';
+
+ require Cwd;
+ my $dir = Cwd::getcwd();
+ chdir $args{local_dir} or return if exists $args{local_dir};
+
+ if (eval { require LWP::Simple; 1 }) {
+ LWP::Simple::mirror($args{url}, $file);
+ }
+ elsif (eval { require Net::FTP; 1 }) { eval {
+ # use Net::FTP to get past firewall
+ my $ftp = Net::FTP->new($host, Passive => 1, Timeout => 600);
+ $ftp->login("anonymous", 'anonymous@example.com');
+ $ftp->cwd($path);
+ $ftp->binary;
+ $ftp->get($file) or (warn("$!\n"), return);
+ $ftp->quit;
+ } }
+ elsif (my $ftp = $self->can_run('ftp')) { eval {
+ # no Net::FTP, fallback to ftp.exe
+ require FileHandle;
+ my $fh = FileHandle->new;
+
+ local $SIG{CHLD} = 'IGNORE';
+ unless ($fh->open("|$ftp -n")) {
+ warn "Couldn't open ftp: $!\n";
+ chdir $dir; return;
+ }
+
+ my @dialog = split(/\n/, <<"END_FTP");
+open $host
+user anonymous anonymous\@example.com
+cd $path
+binary
+get $file $file
+quit
+END_FTP
+ foreach (@dialog) { $fh->print("$_\n") }
+ $fh->close;
+ } }
+ else {
+ warn "No working 'ftp' program available!\n";
+ chdir $dir; return;
+ }
+
+ unless (-f $file) {
+ warn "Fetching failed: $@\n";
+ chdir $dir; return;
+ }
+
+ return if exists $args{size} and -s $file != $args{size};
+ system($args{run}) if exists $args{run};
+ unlink($file) if $args{remove};
+
+ print(((!exists $args{check_for} or -e $args{check_for})
+ ? "done!" : "failed! ($!)"), "\n");
+ chdir $dir; return !$?;
+}
+
+1;
--- /dev/null
+#line 1
+package Module::Install::Makefile;
+
+use strict 'vars';
+use Module::Install::Base;
+use ExtUtils::MakeMaker ();
+
+use vars qw{$VERSION $ISCORE @ISA};
+BEGIN {
+ $VERSION = '0.76';
+ $ISCORE = 1;
+ @ISA = qw{Module::Install::Base};
+}
+
+sub Makefile { $_[0] }
+
+my %seen = ();
+
+sub prompt {
+ shift;
+
+ # Infinite loop protection
+ my @c = caller();
+ if ( ++$seen{"$c[1]|$c[2]|$_[0]"} > 3 ) {
+ die "Caught an potential prompt infinite loop ($c[1]|$c[2]|$_[0])";
+ }
+
+ # In automated testing, always use defaults
+ if ( $ENV{AUTOMATED_TESTING} and ! $ENV{PERL_MM_USE_DEFAULT} ) {
+ local $ENV{PERL_MM_USE_DEFAULT} = 1;
+ goto &ExtUtils::MakeMaker::prompt;
+ } else {
+ goto &ExtUtils::MakeMaker::prompt;
+ }
+}
+
+sub makemaker_args {
+ my $self = shift;
+ my $args = ( $self->{makemaker_args} ||= {} );
+ %$args = ( %$args, @_ );
+ return $args;
+}
+
+# For mm args that take multiple space-seperated args,
+# append an argument to the current list.
+sub makemaker_append {
+ my $self = sShift;
+ my $name = shift;
+ my $args = $self->makemaker_args;
+ $args->{name} = defined $args->{$name}
+ ? join( ' ', $args->{name}, @_ )
+ : join( ' ', @_ );
+}
+
+sub build_subdirs {
+ my $self = shift;
+ my $subdirs = $self->makemaker_args->{DIR} ||= [];
+ for my $subdir (@_) {
+ push @$subdirs, $subdir;
+ }
+}
+
+sub clean_files {
+ my $self = shift;
+ my $clean = $self->makemaker_args->{clean} ||= {};
+ %$clean = (
+ %$clean,
+ FILES => join ' ', grep { length $_ } ($clean->{FILES} || (), @_),
+ );
+}
+
+sub realclean_files {
+ my $self = shift;
+ my $realclean = $self->makemaker_args->{realclean} ||= {};
+ %$realclean = (
+ %$realclean,
+ FILES => join ' ', grep { length $_ } ($realclean->{FILES} || (), @_),
+ );
+}
+
+sub libs {
+ my $self = shift;
+ my $libs = ref $_[0] ? shift : [ shift ];
+ $self->makemaker_args( LIBS => $libs );
+}
+
+sub inc {
+ my $self = shift;
+ $self->makemaker_args( INC => shift );
+}
+
+my %test_dir = ();
+
+sub _wanted_t {
+ /\.t$/ and -f $_ and $test_dir{$File::Find::dir} = 1;
+}
+
+sub tests_recursive {
+ my $self = shift;
+ if ( $self->tests ) {
+ die "tests_recursive will not work if tests are already defined";
+ }
+ my $dir = shift || 't';
+ unless ( -d $dir ) {
+ die "tests_recursive dir '$dir' does not exist";
+ }
+ %test_dir = ();
+ require File::Find;
+ File::Find::find( \&_wanted_t, $dir );
+ $self->tests( join ' ', map { "$_/*.t" } sort keys %test_dir );
+}
+
+sub write {
+ my $self = shift;
+ die "&Makefile->write() takes no arguments\n" if @_;
+
+ # Make sure we have a new enough
+ require ExtUtils::MakeMaker;
+
+ # MakeMaker can complain about module versions that include
+ # an underscore, even though its own version may contain one!
+ # Hence the funny regexp to get rid of it. See RT #35800
+ # for details.
+
+ $self->configure_requires( 'ExtUtils::MakeMaker' => $ExtUtils::MakeMaker::VERSION =~ /^(\d+\.\d+)/ );
+
+ # Generate the
+ my $args = $self->makemaker_args;
+ $args->{DISTNAME} = $self->name;
+ $args->{NAME} = $self->module_name || $self->name;
+ $args->{VERSION} = $self->version;
+ $args->{NAME} =~ s/-/::/g;
+ if ( $self->tests ) {
+ $args->{test} = { TESTS => $self->tests };
+ }
+ if ($] >= 5.005) {
+ $args->{ABSTRACT} = $self->abstract;
+ $args->{AUTHOR} = $self->author;
+ }
+ if ( eval($ExtUtils::MakeMaker::VERSION) >= 6.10 ) {
+ $args->{NO_META} = 1;
+ }
+ if ( eval($ExtUtils::MakeMaker::VERSION) > 6.17 and $self->sign ) {
+ $args->{SIGN} = 1;
+ }
+ unless ( $self->is_admin ) {
+ delete $args->{SIGN};
+ }
+
+ # merge both kinds of requires into prereq_pm
+ my $prereq = ($args->{PREREQ_PM} ||= {});
+ %$prereq = ( %$prereq,
+ map { @$_ }
+ map { @$_ }
+ grep $_,
+ ($self->configure_requires, $self->build_requires, $self->requires)
+ );
+
+ # Remove any reference to perl, PREREQ_PM doesn't support it
+ delete $args->{PREREQ_PM}->{perl};
+
+ # merge both kinds of requires into prereq_pm
+ my $subdirs = ($args->{DIR} ||= []);
+ if ($self->bundles) {
+ foreach my $bundle (@{ $self->bundles }) {
+ my ($file, $dir) = @$bundle;
+ push @$subdirs, $dir if -d $dir;
+ delete $prereq->{$file};
+ }
+ }
+
+ if ( my $perl_version = $self->perl_version ) {
+ eval "use $perl_version; 1"
+ or die "ERROR: perl: Version $] is installed, "
+ . "but we need version >= $perl_version";
+ }
+
+ $args->{INSTALLDIRS} = $self->installdirs;
+
+ my %args = map { ( $_ => $args->{$_} ) } grep {defined($args->{$_})} keys %$args;
+
+ my $user_preop = delete $args{dist}->{PREOP};
+ if (my $preop = $self->admin->preop($user_preop)) {
+ $args{dist} = $preop;
+ }
+
+ my $mm = ExtUtils::MakeMaker::WriteMakefile(%args);
+ $self->fix_up_makefile($mm->{FIRST_MAKEFILE} || 'Makefile');
+}
+
+sub fix_up_makefile {
+ my $self = shift;
+ my $makefile_name = shift;
+ my $top_class = ref($self->_top) || '';
+ my $top_version = $self->_top->VERSION || '';
+
+ my $preamble = $self->preamble
+ ? "# Preamble by $top_class $top_version\n"
+ . $self->preamble
+ : '';
+ my $postamble = "# Postamble by $top_class $top_version\n"
+ . ($self->postamble || '');
+
+ local *MAKEFILE;
+ open MAKEFILE, "< $makefile_name" or die "fix_up_makefile: Couldn't open $makefile_name: $!";
+ my $makefile = do { local $/; <MAKEFILE> };
+ close MAKEFILE or die $!;
+
+ $makefile =~ s/\b(test_harness\(\$\(TEST_VERBOSE\), )/$1'inc', /;
+ $makefile =~ s/( -I\$\(INST_ARCHLIB\))/ -Iinc$1/g;
+ $makefile =~ s/( "-I\$\(INST_LIB\)")/ "-Iinc"$1/g;
+ $makefile =~ s/^(FULLPERL = .*)/$1 "-Iinc"/m;
+ $makefile =~ s/^(PERL = .*)/$1 "-Iinc"/m;
+
+ # Module::Install will never be used to build the Core Perl
+ # Sometimes PERL_LIB and PERL_ARCHLIB get written anyway, which breaks
+ # PREFIX/PERL5LIB, and thus, install_share. Blank them if they exist
+ $makefile =~ s/^PERL_LIB = .+/PERL_LIB =/m;
+ #$makefile =~ s/^PERL_ARCHLIB = .+/PERL_ARCHLIB =/m;
+
+ # Perl 5.005 mentions PERL_LIB explicitly, so we have to remove that as well.
+ $makefile =~ s/(\"?)-I\$\(PERL_LIB\)\1//g;
+
+ # XXX - This is currently unused; not sure if it breaks other MM-users
+ # $makefile =~ s/^pm_to_blib\s+:\s+/pm_to_blib :: /mg;
+
+ open MAKEFILE, "> $makefile_name" or die "fix_up_makefile: Couldn't open $makefile_name: $!";
+ print MAKEFILE "$preamble$makefile$postamble" or die $!;
+ close MAKEFILE or die $!;
+
+ 1;
+}
+
+sub preamble {
+ my ($self, $text) = @_;
+ $self->{preamble} = $text . $self->{preamble} if defined $text;
+ $self->{preamble};
+}
+
+sub postamble {
+ my ($self, $text) = @_;
+ $self->{postamble} ||= $self->admin->postamble;
+ $self->{postamble} .= $text if defined $text;
+ $self->{postamble}
+}
+
+1;
+
+__END__
+
+#line 377
--- /dev/null
+#line 1
+package Module::Install::Metadata;
+
+use strict 'vars';
+use Module::Install::Base;
+
+use vars qw{$VERSION $ISCORE @ISA};
+BEGIN {
+ $VERSION = '0.76';
+ $ISCORE = 1;
+ @ISA = qw{Module::Install::Base};
+}
+
+my @scalar_keys = qw{
+ name
+ module_name
+ abstract
+ author
+ version
+ distribution_type
+ tests
+ installdirs
+};
+
+my @tuple_keys = qw{
+ configure_requires
+ build_requires
+ requires
+ recommends
+ bundles
+ resources
+};
+
+my @resource_keys = qw{
+ homepage
+ bugtracker
+ repository
+};
+
+sub Meta { shift }
+sub Meta_ScalarKeys { @scalar_keys }
+sub Meta_TupleKeys { @tuple_keys }
+sub Meta_ResourceKeys { @resource_keys }
+
+foreach my $key ( @scalar_keys ) {
+ *$key = sub {
+ my $self = shift;
+ return $self->{values}{$key} if defined wantarray and !@_;
+ $self->{values}{$key} = shift;
+ return $self;
+ };
+}
+
+foreach my $key ( @resource_keys ) {
+ *$key = sub {
+ my $self = shift;
+ unless ( @_ ) {
+ return () unless $self->{values}{resources};
+ return map { $_->[1] }
+ grep { $_->[0] eq $key }
+ @{ $self->{values}{resources} };
+ }
+ return $self->{values}{resources}{$key} unless @_;
+ my $uri = shift or die(
+ "Did not provide a value to $key()"
+ );
+ $self->resources( $key => $uri );
+ return 1;
+ };
+}
+
+sub requires {
+ my $self = shift;
+ while ( @_ ) {
+ my $module = shift or last;
+ my $version = shift || 0;
+ push @{ $self->{values}{requires} }, [ $module, $version ];
+ }
+ $self->{values}{requires};
+}
+
+sub build_requires {
+ my $self = shift;
+ while ( @_ ) {
+ my $module = shift or last;
+ my $version = shift || 0;
+ push @{ $self->{values}{build_requires} }, [ $module, $version ];
+ }
+ $self->{values}{build_requires};
+}
+
+sub configure_requires {
+ my $self = shift;
+ while ( @_ ) {
+ my $module = shift or last;
+ my $version = shift || 0;
+ push @{ $self->{values}{configure_requires} }, [ $module, $version ];
+ }
+ $self->{values}{configure_requires};
+}
+
+sub recommends {
+ my $self = shift;
+ while ( @_ ) {
+ my $module = shift or last;
+ my $version = shift || 0;
+ push @{ $self->{values}{recommends} }, [ $module, $version ];
+ }
+ $self->{values}{recommends};
+}
+
+sub bundles {
+ my $self = shift;
+ while ( @_ ) {
+ my $module = shift or last;
+ my $version = shift || 0;
+ push @{ $self->{values}{bundles} }, [ $module, $version ];
+ }
+ $self->{values}{bundles};
+}
+
+# Resource handling
+my %lc_resource = map { $_ => 1 } qw{
+ homepage
+ license
+ bugtracker
+ repository
+};
+
+sub resources {
+ my $self = shift;
+ while ( @_ ) {
+ my $name = shift or last;
+ my $value = shift or next;
+ if ( $name eq lc $name and ! $lc_resource{$name} ) {
+ die("Unsupported reserved lowercase resource '$name'");
+ }
+ $self->{values}{resources} ||= [];
+ push @{ $self->{values}{resources} }, [ $name, $value ];
+ }
+ $self->{values}{resources};
+}
+
+# Aliases for build_requires that will have alternative
+# meanings in some future version of META.yml.
+sub test_requires { shift->build_requires(@_) }
+sub install_requires { shift->build_requires(@_) }
+
+# Aliases for installdirs options
+sub install_as_core { $_[0]->installdirs('perl') }
+sub install_as_cpan { $_[0]->installdirs('site') }
+sub install_as_site { $_[0]->installdirs('site') }
+sub install_as_vendor { $_[0]->installdirs('vendor') }
+
+sub sign {
+ my $self = shift;
+ return $self->{values}{sign} if defined wantarray and ! @_;
+ $self->{values}{sign} = ( @_ ? $_[0] : 1 );
+ return $self;
+}
+
+sub dynamic_config {
+ my $self = shift;
+ unless ( @_ ) {
+ warn "You MUST provide an explicit true/false value to dynamic_config\n";
+ return $self;
+ }
+ $self->{values}{dynamic_config} = $_[0] ? 1 : 0;
+ return 1;
+}
+
+sub perl_version {
+ my $self = shift;
+ return $self->{values}{perl_version} unless @_;
+ my $version = shift or die(
+ "Did not provide a value to perl_version()"
+ );
+ $version =~ s/_.+$//;
+ $version = $version + 0; # Numify
+ unless ( $version >= 5.005 ) {
+ die "Module::Install only supports 5.005 or newer (use ExtUtils::MakeMaker)\n";
+ }
+ $self->{values}{perl_version} = $version;
+ return 1;
+}
+
+sub license {
+ my $self = shift;
+ return $self->{values}{license} unless @_;
+ my $license = shift or die(
+ 'Did not provide a value to license()'
+ );
+ $self->{values}{license} = $license;
+
+ # Automatically fill in license URLs
+ if ( $license eq 'perl' ) {
+ $self->resources( license => 'http://dev.perl.org/licenses/' );
+ }
+
+ return 1;
+}
+
+sub all_from {
+ my ( $self, $file ) = @_;
+
+ unless ( defined($file) ) {
+ my $name = $self->name or die(
+ "all_from called with no args without setting name() first"
+ );
+ $file = join('/', 'lib', split(/-/, $name)) . '.pm';
+ $file =~ s{.*/}{} unless -e $file;
+ unless ( -e $file ) {
+ die("all_from cannot find $file from $name");
+ }
+ }
+
+ # Some methods pull from POD instead of code.
+ # If there is a matching .pod, use that instead
+ my $pod = $file;
+ $pod =~ s/\.pm$/.pod/i;
+ $pod = $file unless -e $pod;
+
+ # Pull the different values
+ $self->name_from($file) unless $self->name;
+ $self->version_from($file) unless $self->version;
+ $self->perl_version_from($file) unless $self->perl_version;
+ $self->author_from($pod) unless $self->author;
+ $self->license_from($pod) unless $self->license;
+ $self->abstract_from($pod) unless $self->abstract;
+
+ return 1;
+}
+
+sub provides {
+ my $self = shift;
+ my $provides = ( $self->{values}{provides} ||= {} );
+ %$provides = (%$provides, @_) if @_;
+ return $provides;
+}
+
+sub auto_provides {
+ my $self = shift;
+ return $self unless $self->is_admin;
+ unless (-e 'MANIFEST') {
+ warn "Cannot deduce auto_provides without a MANIFEST, skipping\n";
+ return $self;
+ }
+ # Avoid spurious warnings as we are not checking manifest here.
+ local $SIG{__WARN__} = sub {1};
+ require ExtUtils::Manifest;
+ local *ExtUtils::Manifest::manicheck = sub { return };
+
+ require Module::Build;
+ my $build = Module::Build->new(
+ dist_name => $self->name,
+ dist_version => $self->version,
+ license => $self->license,
+ );
+ $self->provides( %{ $build->find_dist_packages || {} } );
+}
+
+sub feature {
+ my $self = shift;
+ my $name = shift;
+ my $features = ( $self->{values}{features} ||= [] );
+ my $mods;
+
+ if ( @_ == 1 and ref( $_[0] ) ) {
+ # The user used ->feature like ->features by passing in the second
+ # argument as a reference. Accomodate for that.
+ $mods = $_[0];
+ } else {
+ $mods = \@_;
+ }
+
+ my $count = 0;
+ push @$features, (
+ $name => [
+ map {
+ ref($_) ? ( ref($_) eq 'HASH' ) ? %$_ : @$_ : $_
+ } @$mods
+ ]
+ );
+
+ return @$features;
+}
+
+sub features {
+ my $self = shift;
+ while ( my ( $name, $mods ) = splice( @_, 0, 2 ) ) {
+ $self->feature( $name, @$mods );
+ }
+ return $self->{values}{features}
+ ? @{ $self->{values}{features} }
+ : ();
+}
+
+sub no_index {
+ my $self = shift;
+ my $type = shift;
+ push @{ $self->{values}{no_index}{$type} }, @_ if $type;
+ return $self->{values}{no_index};
+}
+
+sub read {
+ my $self = shift;
+ $self->include_deps( 'YAML::Tiny', 0 );
+
+ require YAML::Tiny;
+ my $data = YAML::Tiny::LoadFile('META.yml');
+
+ # Call methods explicitly in case user has already set some values.
+ while ( my ( $key, $value ) = each %$data ) {
+ next unless $self->can($key);
+ if ( ref $value eq 'HASH' ) {
+ while ( my ( $module, $version ) = each %$value ) {
+ $self->can($key)->($self, $module => $version );
+ }
+ } else {
+ $self->can($key)->($self, $value);
+ }
+ }
+ return $self;
+}
+
+sub write {
+ my $self = shift;
+ return $self unless $self->is_admin;
+ $self->admin->write_meta;
+ return $self;
+}
+
+sub version_from {
+ require ExtUtils::MM_Unix;
+ my ( $self, $file ) = @_;
+ $self->version( ExtUtils::MM_Unix->parse_version($file) );
+}
+
+sub abstract_from {
+ require ExtUtils::MM_Unix;
+ my ( $self, $file ) = @_;
+ $self->abstract(
+ bless(
+ { DISTNAME => $self->name },
+ 'ExtUtils::MM_Unix'
+ )->parse_abstract($file)
+ );
+}
+
+# Add both distribution and module name
+sub name_from {
+ my ($self, $file) = @_;
+ if (
+ Module::Install::_read($file) =~ m/
+ ^ \s*
+ package \s*
+ ([\w:]+)
+ \s* ;
+ /ixms
+ ) {
+ my ($name, $module_name) = ($1, $1);
+ $name =~ s{::}{-}g;
+ $self->name($name);
+ unless ( $self->module_name ) {
+ $self->module_name($module_name);
+ }
+ } else {
+ die("Cannot determine name from $file\n");
+ }
+}
+
+sub perl_version_from {
+ my $self = shift;
+ if (
+ Module::Install::_read($_[0]) =~ m/
+ ^
+ (?:use|require) \s*
+ v?
+ ([\d_\.]+)
+ \s* ;
+ /ixms
+ ) {
+ my $perl_version = $1;
+ $perl_version =~ s{_}{}g;
+ $self->perl_version($perl_version);
+ } else {
+ warn "Cannot determine perl version info from $_[0]\n";
+ return;
+ }
+}
+
+sub author_from {
+ my $self = shift;
+ my $content = Module::Install::_read($_[0]);
+ if ($content =~ m/
+ =head \d \s+ (?:authors?)\b \s*
+ ([^\n]*)
+ |
+ =head \d \s+ (?:licen[cs]e|licensing|copyright|legal)\b \s*
+ .*? copyright .*? \d\d\d[\d.]+ \s* (?:\bby\b)? \s*
+ ([^\n]*)
+ /ixms) {
+ my $author = $1 || $2;
+ $author =~ s{E<lt>}{<}g;
+ $author =~ s{E<gt>}{>}g;
+ $self->author($author);
+ } else {
+ warn "Cannot determine author info from $_[0]\n";
+ }
+}
+
+sub license_from {
+ my $self = shift;
+ if (
+ Module::Install::_read($_[0]) =~ m/
+ (
+ =head \d \s+
+ (?:licen[cs]e|licensing|copyright|legal)\b
+ .*?
+ )
+ (=head\\d.*|=cut.*|)
+ \z
+ /ixms ) {
+ my $license_text = $1;
+ my @phrases = (
+ 'under the same (?:terms|license) as perl itself' => 'perl', 1,
+ 'GNU public license' => 'gpl', 1,
+ 'GNU lesser public license' => 'lgpl', 1,
+ 'BSD license' => 'bsd', 1,
+ 'Artistic license' => 'artistic', 1,
+ 'GPL' => 'gpl', 1,
+ 'LGPL' => 'lgpl', 1,
+ 'BSD' => 'bsd', 1,
+ 'Artistic' => 'artistic', 1,
+ 'MIT' => 'mit', 1,
+ 'proprietary' => 'proprietary', 0,
+ );
+ while ( my ($pattern, $license, $osi) = splice(@phrases, 0, 3) ) {
+ $pattern =~ s{\s+}{\\s+}g;
+ if ( $license_text =~ /\b$pattern\b/i ) {
+ if ( $osi and $license_text =~ /All rights reserved/i ) {
+ print "WARNING: 'All rights reserved' in copyright may invalidate Open Source license.\n";
+ }
+ $self->license($license);
+ return 1;
+ }
+ }
+ }
+
+ warn "Cannot determine license info from $_[0]\n";
+ return 'unknown';
+}
+
+sub bugtracker_from {
+ my $self = shift;
+ my $content = Module::Install::_read($_[0]);
+ my @links = $content =~ m/L\<(http\:\/\/rt\.cpan\.org\/[^>]+)\>/g;
+ unless ( @links ) {
+ warn "Cannot determine bugtracker info from $_[0]\n";
+ return 0;
+ }
+ if ( @links > 1 ) {
+ warn "Found more than on rt.cpan.org link in $_[0]\n";
+ return 0;
+ }
+
+ # Set the bugtracker
+ bugtracker( $links[0] );
+ return 1;
+}
+
+sub install_script {
+ my $self = shift;
+ my $args = $self->makemaker_args;
+ my $exe = $args->{EXE_FILES} ||= [];
+ foreach ( @_ ) {
+ if ( -f $_ ) {
+ push @$exe, $_;
+ } elsif ( -d 'script' and -f "script/$_" ) {
+ push @$exe, "script/$_";
+ } else {
+ die("Cannot find script '$_'");
+ }
+ }
+}
+
+1;
--- /dev/null
+#line 1
+package Module::Install::Win32;
+
+use strict;
+use Module::Install::Base;
+
+use vars qw{$VERSION @ISA $ISCORE};
+BEGIN {
+ $VERSION = '0.76';
+ @ISA = qw{Module::Install::Base};
+ $ISCORE = 1;
+}
+
+# determine if the user needs nmake, and download it if needed
+sub check_nmake {
+ my $self = shift;
+ $self->load('can_run');
+ $self->load('get_file');
+
+ require Config;
+ return unless (
+ $^O eq 'MSWin32' and
+ $Config::Config{make} and
+ $Config::Config{make} =~ /^nmake\b/i and
+ ! $self->can_run('nmake')
+ );
+
+ print "The required 'nmake' executable not found, fetching it...\n";
+
+ require File::Basename;
+ my $rv = $self->get_file(
+ url => 'http://download.microsoft.com/download/vc15/Patch/1.52/W95/EN-US/Nmake15.exe',
+ ftp_url => 'ftp://ftp.microsoft.com/Softlib/MSLFILES/Nmake15.exe',
+ local_dir => File::Basename::dirname($^X),
+ size => 51928,
+ run => 'Nmake15.exe /o > nul',
+ check_for => 'Nmake.exe',
+ remove => 1,
+ );
+
+ die <<'END_MESSAGE' unless $rv;
+
+-------------------------------------------------------------------------------
+
+Since you are using Microsoft Windows, you will need the 'nmake' utility
+before installation. It's available at:
+
+ http://download.microsoft.com/download/vc15/Patch/1.52/W95/EN-US/Nmake15.exe
+ or
+ ftp://ftp.microsoft.com/Softlib/MSLFILES/Nmake15.exe
+
+Please download the file manually, save it to a directory in %PATH% (e.g.
+C:\WINDOWS\COMMAND\), then launch the MS-DOS command line shell, "cd" to
+that directory, and run "Nmake15.exe" from there; that will create the
+'nmake.exe' file needed by this module.
+
+You may then resume the installation process described in README.
+
+-------------------------------------------------------------------------------
+END_MESSAGE
+
+}
+
+1;
--- /dev/null
+#line 1
+package Module::Install::WriteAll;
+
+use strict;
+use Module::Install::Base;
+
+use vars qw{$VERSION @ISA $ISCORE};
+BEGIN {
+ $VERSION = '0.76';
+ @ISA = qw{Module::Install::Base};
+ $ISCORE = 1;
+}
+
+sub WriteAll {
+ my $self = shift;
+ my %args = (
+ meta => 1,
+ sign => 0,
+ inline => 0,
+ check_nmake => 1,
+ @_,
+ );
+
+ $self->sign(1) if $args{sign};
+ $self->Meta->write if $args{meta};
+ $self->admin->WriteAll(%args) if $self->is_admin;
+
+ $self->check_nmake if $args{check_nmake};
+ unless ( $self->makemaker_args->{PL_FILES} ) {
+ $self->makemaker_args( PL_FILES => {} );
+ }
+
+ if ( $args{inline} ) {
+ $self->Inline->write;
+ } else {
+ $self->Makefile->write;
+ }
+}
+
+1;
--- /dev/null
+package OpenSRF;
+
+use strict;
+use vars qw/$AUTOLOAD/;
+
+use Error;
+require UNIVERSAL::require;
+
+# $Revision$
+
+=head1 NAME
+
+OpenSRF - Top level class for OpenSRF perl modules.
+
+=head1 VERSION
+
+Version 0.9.1
+
+=cut
+
+our $VERSION = 0.9.1;
+
+=head1 METHODS
+
+=head2 AUTOLOAD
+
+Traps methods calls for methods that have not been defined so they
+don't propogate up the class hierarchy.
+
+=cut
+
+sub AUTOLOAD {
+ my $self = shift;
+ my $type = ref($self) || $self;
+ my $name = $AUTOLOAD;
+ my $otype = ref $self;
+
+ my ($package, $filename, $line) = caller;
+ my ($package1, $filename1, $line1) = caller(1);
+ my ($package2, $filename2, $line2) = caller(2);
+ my ($package3, $filename3, $line3) = caller(3);
+ my ($package4, $filename4, $line4) = caller(4);
+ my ($package5, $filename5, $line5) = caller(5);
+ $name =~ s/.*://; # strip fully-qualified portion
+ warn <<" WARN";
+****
+** ${name}() isn't there. Please create me somewhere (like in $type)!
+** Error at $package ($filename), line $line
+** Call Stack (5 deep):
+** $package1 ($filename1), line $line1
+** $package2 ($filename2), line $line2
+** $package3 ($filename3), line $line3
+** $package4 ($filename4), line $line4
+** $package5 ($filename5), line $line5
+** Object type was $otype
+****
+ WARN
+}
+
+
+
+=head2 alert_abstract
+
+This method is called by abstract methods to ensure that the process
+dies when an undefined abstract method is called.
+
+=cut
+
+sub alert_abstract() {
+ my $c = shift;
+ my $class = ref( $c ) || $c;
+ my ($file, $line, $method) = (caller(1))[1..3];
+ die " * Call to abstract method $method at $file, line $line";
+}
+
+=head2 class
+
+Returns the scalar value of its caller.
+
+=cut
+
+sub class { return scalar(caller); }
+
+1;
--- /dev/null
+package OpenSRF::AppSession;
+use OpenSRF::DomainObject::oilsMessage;
+use OpenSRF::DomainObject::oilsMethod;
+use OpenSRF::DomainObject::oilsResponse qw/:status/;
+use OpenSRF::Transport::PeerHandle;
+use OpenSRF::Utils::JSON;
+use OpenSRF::Utils::Logger qw(:level);
+use OpenSRF::Utils::SettingsClient;
+use OpenSRF::Utils::Config;
+use OpenSRF::EX;
+use OpenSRF;
+use Exporter;
+use base qw/Exporter OpenSRF/;
+use Time::HiRes qw( time usleep );
+use warnings;
+use strict;
+
+our @EXPORT_OK = qw/CONNECTING INIT_CONNECTED CONNECTED DISCONNECTED CLIENT SERVER/;
+our %EXPORT_TAGS = ( state => [ qw/CONNECTING INIT_CONNECTED CONNECTED DISCONNECTED/ ],
+ endpoint => [ qw/CLIENT SERVER/ ],
+);
+
+my $logger = "OpenSRF::Utils::Logger";
+my $_last_locale = 'en-US';
+
+our %_CACHE;
+our @_RESEND_QUEUE;
+
+sub CONNECTING { return 3 };
+sub INIT_CONNECTED { return 4 };
+sub CONNECTED { return 1 };
+sub DISCONNECTED { return 2 };
+
+sub CLIENT { return 2 };
+sub SERVER { return 1 };
+
+sub find {
+ return undef unless (defined $_[1]);
+ return $_CACHE{$_[1]} if (exists($_CACHE{$_[1]}));
+}
+
+sub transport_connected {
+ my $self = shift;
+ if( ! exists $self->{peer_handle} || ! $self->{peer_handle} ) {
+ return 0;
+ }
+ return $self->{peer_handle}->tcp_connected();
+}
+
+sub connected {
+ my $self = shift;
+ return $self->state == CONNECTED;
+}
+# ----------------------------------------------------------------------------
+# Clears the transport buffers
+# call this if you are not through with the sesssion, but you want
+# to have a clean slate. You shouldn't have to call this if
+# you are correctly 'recv'ing all of the data from a request.
+# however, if you don't want all of the data, this will
+# slough off any excess
+# * * Note: This will delete data for all sessions using this transport
+# handle. For example, all client sessions use the same handle.
+# ----------------------------------------------------------------------------
+sub buffer_reset {
+
+ my $self = shift;
+ if( ! exists $self->{peer_handle} || ! $self->{peer_handle} ) {
+ return 0;
+ }
+ $self->{peer_handle}->buffer_reset();
+}
+
+
+# when any incoming data is received, this method is called.
+sub server_build {
+ my $class = shift;
+ $class = ref($class) || $class;
+
+ my $sess_id = shift;
+ my $remote_id = shift;
+ my $service = shift;
+
+ warn "Missing args to server_build():\n" .
+ "sess_id: $sess_id, remote_id: $remote_id, service: $service\n"
+ unless ($sess_id and $remote_id and $service);
+
+ return undef unless ($sess_id and $remote_id and $service);
+
+ if ( my $thingy = $class->find($sess_id) ) {
+ $thingy->remote_id( $remote_id );
+ return $thingy;
+ }
+
+ if( $service eq "client" ) {
+ #throw OpenSRF::EX::PANIC ("Attempting to build a client session as a server" .
+ # " Session ID [$sess_id], remote_id [$remote_id]");
+
+ warn "Attempting to build a client session as ".
+ "a server Session ID [$sess_id], remote_id [$remote_id]";
+
+ $logger->debug("Attempting to build a client session as ".
+ "a server Session ID [$sess_id], remote_id [$remote_id]", ERROR );
+
+ return undef;
+ }
+
+ my $config_client = OpenSRF::Utils::SettingsClient->new();
+ my $stateless = $config_client->config_value("apps", $service, "stateless");
+
+ #my $max_requests = $conf->$service->max_requests;
+ my $max_requests = $config_client->config_value("apps",$service,"max_requests");
+ $logger->debug( "Max Requests for $service is $max_requests", INTERNAL ) if (defined $max_requests);
+
+ $logger->transport( "AppSession creating new session: $sess_id", INTERNAL );
+
+ my $self = bless { recv_queue => [],
+ request_queue => [],
+ requests => 0,
+ session_data => {},
+ callbacks => {},
+ endpoint => SERVER,
+ state => CONNECTING,
+ session_id => $sess_id,
+ remote_id => $remote_id,
+ peer_handle => OpenSRF::Transport::PeerHandle->retrieve($service),
+ max_requests => $max_requests,
+ session_threadTrace => 0,
+ service => $service,
+ stateless => $stateless,
+ } => $class;
+
+ return $_CACHE{$sess_id} = $self;
+}
+
+sub session_data {
+ my $self = shift;
+ my ($name, $datum) = @_;
+
+ $self->{session_data}->{$name} = $datum if (defined $datum);
+ return $self->{session_data}->{$name};
+}
+
+sub service { return shift()->{service}; }
+
+sub continue_request {
+ my $self = shift;
+ $self->{'requests'}++;
+ return 1 if (!$self->{'max_requests'});
+ return $self->{'requests'} <= $self->{'max_requests'} ? 1 : 0;
+}
+
+sub last_sent_payload {
+ my( $self, $payload ) = @_;
+ if( $payload ) {
+ return $self->{'last_sent_payload'} = $payload;
+ }
+ return $self->{'last_sent_payload'};
+}
+
+sub session_locale {
+ my( $self, $type ) = @_;
+ if( $type ) {
+ $_last_locale = $type if ($self->endpoint == SERVER);
+ return $self->{'session_locale'} = $type;
+ }
+ return $self->{'session_locale'};
+}
+
+sub last_sent_type {
+ my( $self, $type ) = @_;
+ if( $type ) {
+ return $self->{'last_sent_type'} = $type;
+ }
+ return $self->{'last_sent_type'};
+}
+
+sub get_app_targets {
+ my $app = shift;
+
+ my $conf = OpenSRF::Utils::Config->current;
+ my $router_name = $conf->bootstrap->router_name || 'router';
+ my $domain = $conf->bootstrap->domain;
+ $logger->error("use of <domains/> is deprecated") if $conf->bootstrap->domains;
+
+ unless($router_name and $domain) {
+ throw OpenSRF::EX::Config
+ ("Missing router config information 'router_name' and 'domain'");
+ }
+
+ return ("$router_name\@$domain/$app");
+}
+
+sub stateless {
+ my $self = shift;
+ my $state = shift;
+ $self->{stateless} = $state if (defined $state);
+ return $self->{stateless};
+}
+
+# When we're a client and we want to connect to a remote service
+sub create {
+ my $class = shift;
+ $class = ref($class) || $class;
+
+ my $app = shift;
+ my $api_level = shift;
+ my $quiet = shift;
+ my $locale = shift || $_last_locale;
+
+ $api_level = 1 if (!defined($api_level));
+
+ $logger->debug( "AppSession creating new client session for $app", DEBUG );
+
+ my $stateless = 0;
+ my $c = OpenSRF::Utils::SettingsClient->new();
+ # we can get an infinite loop if we're grabbing the settings and we
+ # need the settings to grab the settings...
+ if($app ne "opensrf.settings" || $c->has_config()) {
+ $stateless = $c->config_value("apps", $app, "stateless");
+ }
+
+ my $sess_id = time . rand( $$ );
+ while ( $class->find($sess_id) ) {
+ $sess_id = time . rand( $$ );
+ }
+
+
+ my ($r_id) = get_app_targets($app);
+
+ my $peer_handle = OpenSRF::Transport::PeerHandle->retrieve("client");
+ if( ! $peer_handle ) {
+ $peer_handle = OpenSRF::Transport::PeerHandle->retrieve("system_client");
+ }
+
+ my $self = bless { app_name => $app,
+ request_queue => [],
+ endpoint => CLIENT,
+ state => DISCONNECTED,#since we're init'ing
+ session_id => $sess_id,
+ remote_id => $r_id,
+ raise_error => $quiet ? 0 : 1,
+ session_locale => $locale,
+ api_level => $api_level,
+ orig_remote_id => $r_id,
+ peer_handle => $peer_handle,
+ session_threadTrace => 0,
+ stateless => $stateless,
+ } => $class;
+
+ $logger->debug( "Created new client session $app : $sess_id" );
+
+ return $_CACHE{$sess_id} = $self;
+}
+
+sub raise_remote_errors {
+ my $self = shift;
+ my $err = shift;
+ $self->{raise_error} = $err if (defined $err);
+ return $self->{raise_error};
+}
+
+sub api_level {
+ return shift()->{api_level};
+}
+
+sub app {
+ return shift()->{app_name};
+}
+
+sub reset {
+ my $self = shift;
+ $self->remote_id($$self{orig_remote_id});
+}
+
+# 'connect' can be used as a constructor if called as a class method,
+# or used to connect a session that has disconnectd if called against
+# an existing session that seems to be disconnected, or was just built
+# using 'create' above.
+
+# connect( $app, username => $user, secret => $passwd );
+# OR
+# connect( $app, sysname => $user, secret => $shared_secret );
+
+# --- Returns undef if the connect attempt times out.
+# --- Returns the OpenSRF::EX object if one is returned by the server
+# --- Returns self if connected
+sub connect {
+ my $self = shift;
+ my $class = ref($self) || $self;
+
+
+ if ( ref( $self ) and $self->state && $self->state == CONNECTED ) {
+ $logger->transport("AppSession already connected", DEBUG );
+ } else {
+ $logger->transport("AppSession not connected, connecting..", DEBUG );
+ }
+ return $self if ( ref( $self ) and $self->state && $self->state == CONNECTED );
+
+
+ my $app = shift;
+ my $api_level = shift;
+ $api_level = 1 unless (defined $api_level);
+
+ $self = $class->create($app, @_) if (!ref($self));
+
+ return undef unless ($self);
+
+ $self->{api_level} = $api_level;
+
+ $self->reset;
+ $self->state(CONNECTING);
+ $self->send('CONNECT', "");
+
+
+ # if we want to connect to settings, we may not have
+ # any data for the settings client to work with...
+ # just using a default for now XXX
+
+ my $time_remaining = 5;
+
+
+# my $client = OpenSRF::Utils::SettingsClient->new();
+# my $trans = $client->config_value("client_connection","transport_host");
+#
+# if(!ref($trans)) {
+# $time_remaining = $trans->{connect_timeout};
+# } else {
+# # XXX for now, just use the first
+# $time_remaining = $trans->[0]->{connect_timeout};
+# }
+
+ while ( $self->state != CONNECTED and $time_remaining > 0 ) {
+ my $starttime = time;
+ $self->queue_wait($time_remaining);
+ my $endtime = time;
+ $time_remaining -= ($endtime - $starttime);
+ }
+
+ return undef unless($self->state == CONNECTED);
+
+ $self->stateless(0);
+
+ return $self;
+}
+
+sub finish {
+ my $self = shift;
+ if( ! $self->session_id ) {
+ return 0;
+ }
+}
+
+sub unregister_callback {
+ my $self = shift;
+ my $type = shift;
+ my $cb = shift;
+ if (exists $self->{callbacks}{$type}) {
+ delete $self->{callbacks}{$type}{$cb};
+ return $cb;
+ }
+ return undef;
+}
+
+sub register_callback {
+ my $self = shift;
+ my $type = shift;
+ my $cb = shift;
+ my $cb_key = "$cb";
+ $self->{callbacks}{$type}{$cb_key} = $cb;
+ return $cb_key;
+}
+
+sub kill_me {
+ my $self = shift;
+ if( ! $self->session_id ) { return 0; }
+
+ # run each 'death' callback;
+ if (exists $self->{callbacks}{death}) {
+ for my $sub (values %{$self->{callbacks}{death}}) {
+ $sub->($self);
+ }
+ }
+
+ $self->disconnect;
+ $logger->transport( "AppSession killing self: " . $self->session_id(), DEBUG );
+ delete $_CACHE{$self->session_id};
+ delete($$self{$_}) for (keys %$self);
+}
+
+sub disconnect {
+ my $self = shift;
+
+ # run each 'disconnect' callback;
+ if (exists $self->{callbacks}{disconnect}) {
+ for my $sub (values %{$self->{callbacks}{disconnect}}) {
+ $sub->($self);
+ }
+ }
+
+ if ( !$self->stateless and $self->state != DISCONNECTED ) {
+ $self->send('DISCONNECT', "") if ($self->endpoint == CLIENT);
+ $self->state( DISCONNECTED );
+ }
+
+ $self->reset;
+}
+
+sub request {
+ my $self = shift;
+ my $meth = shift;
+ return unless $self;
+
+ # tell the logger to create a new xid - the logger will decide if it's really necessary
+ $logger->mk_osrf_xid;
+
+ my $method;
+ if (!ref $meth) {
+ $method = new OpenSRF::DomainObject::oilsMethod ( method => $meth );
+ } else {
+ $method = $meth;
+ }
+
+ $method->params( @_ );
+
+ $self->send('REQUEST',$method);
+}
+
+sub full_request {
+ my $self = shift;
+ my $meth = shift;
+
+ my $method;
+ if (!ref $meth) {
+ $method = new OpenSRF::DomainObject::oilsMethod ( method => $meth );
+ } else {
+ $method = $meth;
+ }
+
+ $method->params( @_ );
+
+ $self->send(CONNECT => '', REQUEST => $method, DISCONNECT => '');
+}
+
+sub send {
+ my $self = shift;
+ my @payload_list = @_; # this is a Domain Object
+
+ return unless ($self and $self->{peer_handle});
+
+ $logger->debug( "In send", INTERNAL );
+
+ my $tT;
+
+ if( @payload_list % 2 ) { $tT = pop @payload_list; }
+
+ if( ! @payload_list ) {
+ $logger->debug( "payload_list param is incomplete in AppSession::send()", ERROR );
+ return undef;
+ }
+
+ my @doc = ();
+
+ my $disconnect = 0;
+ my $connecting = 0;
+
+ while( @payload_list ) {
+
+ my ($msg_type, $payload) = ( shift(@payload_list), shift(@payload_list) );
+
+ if ($msg_type eq 'DISCONNECT' ) {
+ $disconnect++;
+ if( $self->state == DISCONNECTED && !$connecting) {
+ next;
+ }
+ }
+
+ if( $msg_type eq "CONNECT" ) {
+ $connecting++;
+ }
+
+ my $msg = OpenSRF::DomainObject::oilsMessage->new();
+ $msg->type($msg_type);
+
+ no warnings;
+ $msg->threadTrace( $tT || int($self->session_threadTrace) || int($self->last_threadTrace) );
+ use warnings;
+
+ if ($msg->type eq 'REQUEST') {
+ if ( !defined($tT) || $self->last_threadTrace != $tT ) {
+ $msg->update_threadTrace;
+ $self->session_threadTrace( $msg->threadTrace );
+ $tT = $self->session_threadTrace;
+ OpenSRF::AppRequest->new($self, $payload);
+ }
+ }
+
+ $msg->api_level($self->api_level);
+ $msg->payload($payload) if $payload;
+
+ my $locale = $self->session_locale;
+ $msg->sender_locale($locale) if ($locale);
+
+ push @doc, $msg;
+
+
+ $logger->info( "AppSession sending ".$msg->type." to ".$self->remote_id.
+ " with threadTrace [".$msg->threadTrace."]");
+
+ }
+
+ if ($self->endpoint == CLIENT and ! $disconnect) {
+ $self->queue_wait(0);
+
+
+ if($self->stateless && $self->state != CONNECTED) {
+ $self->reset;
+ $logger->debug("AppSession is stateless in send", INTERNAL );
+ }
+
+ if( !$self->stateless and $self->state != CONNECTED ) {
+
+ $logger->debug( "Sending connect before request 1", INTERNAL );
+
+ unless (($self->state == CONNECTING && $connecting )) {
+ $logger->debug( "Sending connect before request 2", INTERNAL );
+ my $v = $self->connect();
+ if( ! $v ) {
+ $logger->debug( "Unable to connect to remote service in AppSession::send()", ERROR );
+ return undef;
+ }
+ if( ref($v) and $v->can("class") and $v->class->isa( "OpenSRF::EX" ) ) {
+ return $v;
+ }
+ }
+ }
+
+ }
+ my $json = OpenSRF::Utils::JSON->perl2JSON(\@doc);
+ $logger->internal("AppSession sending doc: $json");
+
+ $self->{peer_handle}->send(
+ to => $self->remote_id,
+ thread => $self->session_id,
+ body => $json );
+
+ if( $disconnect) {
+ $self->state( DISCONNECTED );
+ }
+
+ my $req = $self->app_request( $tT );
+ $req->{_start} = time;
+ return $req
+}
+
+sub app_request {
+ my $self = shift;
+ my $tT = shift;
+
+ return undef unless (defined $tT);
+ my ($req) = grep { $_->threadTrace == $tT } @{ $self->{request_queue} };
+
+ return $req;
+}
+
+sub remove_app_request {
+ my $self = shift;
+ my $req = shift;
+
+ my @list = grep { $_->threadTrace != $req->threadTrace } @{ $self->{request_queue} };
+
+ $self->{request_queue} = \@list;
+}
+
+sub endpoint {
+ return $_[0]->{endpoint};
+}
+
+
+sub session_id {
+ my $self = shift;
+ return $self->{session_id};
+}
+
+sub push_queue {
+ my $self = shift;
+ my $resp = shift;
+ my $req = $self->app_request($resp->[1]);
+ return $req->push_queue( $resp->[0] ) if ($req);
+ push @{ $self->{recv_queue} }, $resp->[0];
+}
+
+sub last_threadTrace {
+ my $self = shift;
+ my $new_last_threadTrace = shift;
+
+ my $old_last_threadTrace = $self->{last_threadTrace};
+ if (defined $new_last_threadTrace) {
+ $self->{last_threadTrace} = $new_last_threadTrace;
+ return $new_last_threadTrace unless ($old_last_threadTrace);
+ }
+
+ return $old_last_threadTrace;
+}
+
+sub session_threadTrace {
+ my $self = shift;
+ my $new_last_threadTrace = shift;
+
+ my $old_last_threadTrace = $self->{session_threadTrace};
+ if (defined $new_last_threadTrace) {
+ $self->{session_threadTrace} = $new_last_threadTrace;
+ return $new_last_threadTrace unless ($old_last_threadTrace);
+ }
+
+ return $old_last_threadTrace;
+}
+
+sub last_message_type {
+ my $self = shift;
+ my $new_last_message_type = shift;
+
+ my $old_last_message_type = $self->{last_message_type};
+ if (defined $new_last_message_type) {
+ $self->{last_message_type} = $new_last_message_type;
+ return $new_last_message_type unless ($old_last_message_type);
+ }
+
+ return $old_last_message_type;
+}
+
+sub last_message_api_level {
+ my $self = shift;
+ my $new_last_message_api_level = shift;
+
+ my $old_last_message_api_level = $self->{last_message_api_level};
+ if (defined $new_last_message_api_level) {
+ $self->{last_message_api_level} = $new_last_message_api_level;
+ return $new_last_message_api_level unless ($old_last_message_api_level);
+ }
+
+ return $old_last_message_api_level;
+}
+
+sub remote_id {
+ my $self = shift;
+ my $new_remote_id = shift;
+
+ my $old_remote_id = $self->{remote_id};
+ if (defined $new_remote_id) {
+ $self->{remote_id} = $new_remote_id;
+ return $new_remote_id unless ($old_remote_id);
+ }
+
+ return $old_remote_id;
+}
+
+sub client_auth {
+ return undef;
+ my $self = shift;
+ my $new_ua = shift;
+
+ my $old_ua = $self->{client_auth};
+ if (defined $new_ua) {
+ $self->{client_auth} = $new_ua;
+ return $new_ua unless ($old_ua);
+ }
+
+ return $old_ua->cloneNode(1);
+}
+
+sub state {
+ my $self = shift;
+ my $new_state = shift;
+
+ my $old_state = $self->{state};
+ if (defined $new_state) {
+ $self->{state} = $new_state;
+ return $new_state unless ($old_state);
+ }
+
+ return $old_state;
+}
+
+sub DESTROY {
+ my $self = shift;
+ delete $$self{$_} for keys %$self;
+ return undef;
+}
+
+sub recv {
+ my $self = shift;
+ my @proto_args = @_;
+ my %args;
+
+ if ( @proto_args ) {
+ if ( !(@proto_args % 2) ) {
+ %args = @proto_args;
+ } elsif (@proto_args == 1) {
+ %args = ( timeout => @proto_args );
+ }
+ }
+
+ #$logger->debug( ref($self). " recv_queue before wait: " . $self->_print_queue(), INTERNAL );
+
+ if( exists( $args{timeout} ) ) {
+ $args{timeout} = int($args{timeout});
+ $self->{recv_timeout} = $args{timeout};
+ }
+
+ #$args{timeout} = 0 if ($self->complete);
+
+ if(defined($args{timeout})) {
+ $logger->debug( ref($self) ."->recv with timeout " . $args{timeout}, INTERNAL );
+ }
+
+ my $avail = @{ $self->{recv_queue} };
+ $self->{remaining_recv_timeout} = $self->{recv_timeout};
+
+ if (!$args{count}) {
+ if (wantarray) {
+ $args{count} = $avail;
+ } else {
+ $args{count} = 1;
+ }
+ }
+
+ while ( $self->{remaining_recv_timeout} > 0 and $avail < $args{count} ) {
+ last if $self->complete;
+ my $starttime = time;
+ $self->queue_wait($self->{remaining_recv_timeout});
+ my $endtime = time;
+ if ($self->{timeout_reset}) {
+ $self->{timeout_reset} = 0;
+ } else {
+ $self->{remaining_recv_timeout} -= ($endtime - $starttime)
+ }
+ $avail = @{ $self->{recv_queue} };
+ }
+
+
+ my @list;
+ while ( my $msg = shift @{ $self->{recv_queue} } ) {
+ push @list, $msg;
+ last if (scalar(@list) >= $args{count});
+ }
+
+ $logger->debug( "Number of matched responses: " . @list, DEBUG );
+ $self->queue_wait(0); # check for statuses
+
+ return $list[0] if (!wantarray);
+ return @list;
+}
+
+sub push_resend {
+ my $self = shift;
+ push @OpenSRF::AppSession::_RESEND_QUEUE, @_;
+}
+
+sub flush_resend {
+ my $self = shift;
+ $logger->debug( "Resending..." . @_RESEND_QUEUE, INTERNAL );
+ while ( my $req = shift @OpenSRF::AppSession::_RESEND_QUEUE ) {
+ $req->resend unless $req->complete;
+ }
+}
+
+
+sub queue_wait {
+ my $self = shift;
+ if( ! $self->{peer_handle} ) { return 0; }
+ my $timeout = shift || 0;
+ $logger->debug( "Calling queue_wait($timeout)" , INTERNAL );
+ my $o = $self->{peer_handle}->process($timeout);
+ $self->flush_resend;
+ return $o;
+}
+
+sub _print_queue {
+ my( $self ) = @_;
+ my $string = "";
+ foreach my $msg ( @{$self->{recv_queue}} ) {
+ $string = $string . $msg->toString(1) . "\n";
+ }
+ return $string;
+}
+
+sub status {
+ my $self = shift;
+ return unless $self;
+ $self->send( 'STATUS', @_ );
+}
+
+sub reset_request_timeout {
+ my $self = shift;
+ my $tt = shift;
+ my $req = $self->app_request($tt);
+ $req->{remaining_recv_timeout} = $req->{recv_timeout};
+ $req->{timout_reset} = 1;
+}
+
+#-------------------------------------------------------------------------------
+
+package OpenSRF::AppRequest;
+use base qw/OpenSRF::AppSession/;
+use OpenSRF::Utils::Logger qw/:level/;
+use OpenSRF::DomainObject::oilsResponse qw/:status/;
+use Time::HiRes qw/time usleep/;
+
+sub new {
+ my $class = shift;
+ $class = ref($class) || $class;
+
+ my $session = shift;
+ my $threadTrace = $session->session_threadTrace || $session->last_threadTrace;
+ my $payload = shift;
+
+ my $self = { session => $session,
+ threadTrace => $threadTrace,
+ payload => $payload,
+ complete => 0,
+ timeout_reset => 0,
+ recv_timeout => 30,
+ remaining_recv_timeout => 30,
+ recv_queue => [],
+ };
+
+ bless $self => $class;
+
+ push @{ $self->session->{request_queue} }, $self;
+
+ return $self;
+}
+
+sub recv_timeout {
+ my $self = shift;
+ my $timeout = shift;
+ if (defined $timeout) {
+ $self->{recv_timeout} = $timeout;
+ $self->{remaining_recv_timeout} = $timeout;
+ }
+ return $self->{recv_timeout};
+}
+
+sub queue_size {
+ my $size = @{$_[0]->{recv_queue}};
+ return $size;
+}
+
+sub send {
+ my $self = shift;
+ return unless ($self and $self->session and !$self->complete);
+ $self->session->send(@_);
+}
+
+sub finish {
+ my $self = shift;
+ return unless $self->session;
+ $self->session->remove_app_request($self);
+ delete($$self{$_}) for (keys %$self);
+}
+
+sub session {
+ return shift()->{session};
+}
+
+sub complete {
+ my $self = shift;
+ my $complete = shift;
+ return $self->{complete} if ($self->{complete});
+ if (defined $complete) {
+ $self->{complete} = $complete;
+ $self->{_duration} = time - $self->{_start} if ($self->{complete});
+ } else {
+ $self->session->queue_wait(0);
+ }
+ return $self->{complete};
+}
+
+sub duration {
+ my $self = shift;
+ $self->wait_complete;
+ return $self->{_duration};
+}
+
+sub wait_complete {
+ my $self = shift;
+ my $timeout = shift || 10;
+ my $time_remaining = $timeout;
+
+ while ( ! $self->complete and $time_remaining > 0 ) {
+ my $starttime = time;
+ $self->queue_wait($time_remaining);
+ my $endtime = time;
+ $time_remaining -= ($endtime - $starttime);
+ }
+
+ return $self->complete;
+}
+
+sub threadTrace {
+ return shift()->{threadTrace};
+}
+
+sub push_queue {
+ my $self = shift;
+ my $resp = shift;
+ if( !$resp ) { return 0; }
+ if( UNIVERSAL::isa($resp, "Error")) {
+ $self->{failed} = $resp;
+ $self->complete(1);
+ #return; eventually...
+ }
+ push @{ $self->{recv_queue} }, $resp;
+}
+
+sub failed {
+ my $self = shift;
+ return $self->{failed};
+}
+
+sub queue_wait {
+ my $self = shift;
+ return $self->session->queue_wait(@_)
+}
+
+sub payload { return shift()->{payload}; }
+
+sub resend {
+ my $self = shift;
+ return unless ($self and $self->session and !$self->complete);
+ OpenSRF::Utils::Logger->debug( "I'm resending the request for threadTrace ". $self->threadTrace, DEBUG);
+ return $self->session->send('REQUEST', $self->payload, $self->threadTrace );
+}
+
+sub status {
+ my $self = shift;
+ my $msg = shift;
+ return unless ($self and $self->session and !$self->complete);
+ $self->session->send( 'STATUS',$msg, $self->threadTrace );
+}
+
+sub stream_push {
+ my $self = shift;
+ my $msg = shift;
+ $self->respond( $msg );
+}
+
+sub respond {
+ my $self = shift;
+ my $msg = shift;
+ return unless ($self and $self->session and !$self->complete);
+
+ my $response;
+ if (ref($msg) && UNIVERSAL::isa($msg, 'OpenSRF::DomainObject::oilsResult')) {
+ $response = $msg;
+ } else {
+ $response = new OpenSRF::DomainObject::oilsResult;
+ $response->content($msg);
+ }
+
+ $self->session->send('RESULT', $response, $self->threadTrace);
+}
+
+sub respond_complete {
+ my $self = shift;
+ my $msg = shift;
+ return unless ($self and $self->session and !$self->complete);
+
+ my $response;
+ if (ref($msg) && UNIVERSAL::isa($msg, 'OpenSRF::DomainObject::oilsResult')) {
+ $response = $msg;
+ } else {
+ $response = new OpenSRF::DomainObject::oilsResult;
+ $response->content($msg);
+ }
+
+ my $stat = OpenSRF::DomainObject::oilsConnectStatus->new(
+ statusCode => STATUS_COMPLETE(),
+ status => 'Request Complete' );
+
+
+ $self->session->send( 'RESULT' => $response, 'STATUS' => $stat, $self->threadTrace);
+ $self->complete(1);
+}
+
+sub register_death_callback {
+ my $self = shift;
+ my $cb = shift;
+ $self->session->register_callback( death => $cb );
+}
+
+
+# utility method. checks to see of the request failed.
+# if so, throws an OpenSRF::EX::ERROR. if everything is
+# ok, it returns the content of the request
+sub gather {
+ my $self = shift;
+ my $finish = shift;
+ $self->wait_complete;
+ my $resp = $self->recv( timeout => 60 );
+ if( $self->failed() ) {
+ throw OpenSRF::EX::ERROR
+ ($self->failed()->stringify());
+ }
+ if(!$resp) { return undef; }
+ my $content = $resp->content;
+ if($finish) { $self->finish();}
+ return $content;
+}
+
+
+package OpenSRF::AppSubrequest;
+
+sub respond {
+ my $self = shift;
+ my $resp = shift;
+ push @{$$self{resp}}, $resp if (defined $resp);
+}
+sub respond_complete { respond(@_); }
+
+sub new {
+ my $class = shift;
+ $class = ref($class) || $class;
+ return bless({resp => [], @_}, $class);
+}
+
+sub responses { @{$_[0]->{resp}} }
+
+sub session {
+ my $x = shift;
+ my $s = shift;
+ $x->{session} = $s if ($s);
+ return $x->{session};
+}
+
+sub status {}
+
+
+1;
+
--- /dev/null
+package OpenSRF::Application;
+# vim:noet:ts=4
+use vars qw/$_app $log @_METHODS $thunk $server_class/;
+
+use base qw/OpenSRF/;
+use OpenSRF::AppSession;
+use OpenSRF::DomainObject::oilsMethod;
+use OpenSRF::DomainObject::oilsResponse qw/:status/;
+use OpenSRF::Utils::Logger qw/:level $logger/;
+use Data::Dumper;
+use Time::HiRes qw/time/;
+use OpenSRF::EX qw/:try/;
+use Carp;
+use OpenSRF::Utils::JSON;
+#use OpenSRF::UnixServer; # to get the server class from UnixServer::App
+
+sub DESTROY{};
+
+use strict;
+use warnings;
+
+$log = 'OpenSRF::Utils::Logger';
+
+our $in_request = 0;
+our @pending_requests;
+
+sub package {
+ my $self = shift;
+ return 1 unless ref($self);
+ return $self->{package};
+}
+
+sub signature {
+ my $self = shift;
+ return 0 unless ref($self);
+ return $self->{signature};
+}
+
+sub strict {
+ my $self = shift;
+ return 0 unless ref($self);
+ return $self->{strict};
+}
+
+sub argc {
+ my $self = shift;
+ return 0 unless ref($self);
+ return $self->{argc};
+}
+
+sub api_name {
+ my $self = shift;
+ return 1 unless ref($self);
+ return $self->{api_name};
+}
+
+sub api_level {
+ my $self = shift;
+ return 1 unless ref($self);
+ return $self->{api_level};
+}
+
+sub session {
+ my $self = shift;
+ my $session = shift;
+
+ if($session) {
+ $self->{session} = $session;
+ }
+ return $self->{session};
+}
+
+sub server_class {
+ my $class = shift;
+ if($class) {
+ $server_class = $class;
+ }
+ return $server_class;
+}
+
+sub thunk {
+ my $self = shift;
+ my $flag = shift;
+ $thunk = $flag if (defined $flag);
+ return $thunk;
+}
+
+sub application_implementation {
+ my $self = shift;
+ my $app = shift;
+
+ if (defined $app) {
+ $_app = $app;
+ $_app->use;
+ if( $@ ) {
+ $log->error( "Error loading application_implementation: $app -> $@", ERROR);
+ }
+
+ }
+
+ return $_app;
+}
+
+sub handler {
+ my ($self, $session, $app_msg) = @_;
+
+ if( ! $app_msg ) {
+ return 1; # error?
+ }
+
+ my $app = $self->application_implementation;
+
+ if ($session->last_message_type eq 'REQUEST') {
+
+ my @p = $app_msg->params;
+ my $method_name = $app_msg->method;
+ my $method_proto = $session->last_message_api_level;
+ $log->info("CALL: $method_name [". (@p ? join(', ',@p) : '') ."]");
+
+ my $coderef = $app->method_lookup( $method_name, $method_proto, 1, 1 );
+
+ unless ($coderef) {
+ $session->status( OpenSRF::DomainObject::oilsMethodException->new(
+ statusCode => STATUS_NOTFOUND(),
+ status => "Method [$method_name] not found for $app"));
+ return 1;
+ }
+
+ unless ($session->continue_request) {
+ $session->status(
+ OpenSRF::DomainObject::oilsConnectStatus->new(
+ statusCode => STATUS_REDIRECTED(),
+ status => 'Disconnect on max requests' ) );
+ $session->kill_me;
+ return 1;
+ }
+
+ if (ref $coderef) {
+ my @args = $app_msg->params;
+ my $appreq = OpenSRF::AppRequest->new( $session );
+
+ $log->debug( "in_request = $in_request : [" . $appreq->threadTrace."]", INTERNAL );
+ if( $in_request ) {
+ $log->debug( "Pushing onto pending requests: " . $appreq->threadTrace, DEBUG );
+ push @pending_requests, [ $appreq, \@args, $coderef ];
+ return 1;
+ }
+
+
+ $in_request++;
+
+ $log->debug( "Executing coderef for {$method_name}", INTERNAL );
+
+ my $resp;
+ try {
+ # un-if(0) this block to enable param checking based on signature and argc
+ if ($coderef->strict) {
+ if (@args < $coderef->argc) {
+ die "Not enough params passed to ".
+ $coderef->api_name." : requires ". $coderef->argc
+ }
+ if (@args) {
+ my $sig = $coderef->signature;
+ if ($sig && exists $sig->{params}) {
+ for my $p (0 .. scalar(@{ $sig->{params} }) - 1 ) {
+ my $s = $sig->{params}->[$p];
+ my $a = $args[$p];
+ if ($s->{class} && OpenSRF::Utils::JSON->lookup_hint(ref $a) ne $s->{class}) {
+ die "Incorrect param class at position $p : should be a '$$s{class}'";
+ } elsif ($s->{type}) {
+ if (lc($s->{type}) eq 'object' && $a !~ /HASH/o) {
+ die "Incorrect param type at position $p : should be an 'object'";
+ } elsif (lc($s->{type}) eq 'array' && $a !~ /ARRAY/o) {
+ die "Incorrect param type at position $p : should be an 'array'";
+ } elsif (lc($s->{type}) eq 'number' && (ref($a) || $a !~ /^-?\d+(?:\.\d+)?$/o)) {
+ die "Incorrect param type at position $p : should be a 'number'";
+ } elsif (lc($s->{type}) eq 'string' && ref($a)) {
+ die "Incorrect param type at position $p : should be a 'string'";
+ }
+ }
+ }
+ }
+ }
+ }
+
+ my $start = time();
+ $resp = $coderef->run( $appreq, @args);
+ my $time = sprintf '%.3f', time() - $start;
+
+ $log->debug( "Method duration for [$method_name]: ". $time );
+ if( defined( $resp ) ) {
+ $appreq->respond_complete( $resp );
+ } else {
+ $appreq->status( OpenSRF::DomainObject::oilsConnectStatus->new(
+ statusCode => STATUS_COMPLETE(),
+ status => 'Request Complete' ) );
+ }
+ } catch Error with {
+ my $e = shift;
+ warn "Caught error from 'run' method: $e\n";
+
+ if(UNIVERSAL::isa($e,"Error")) {
+ $e = $e->stringify();
+ }
+ my $sess_id = $session->session_id;
+ $session->status(
+ OpenSRF::DomainObject::oilsMethodException->new(
+ statusCode => STATUS_INTERNALSERVERERROR(),
+ status => " *** Call to [$method_name] failed for session ".
+ "[$sess_id], thread trace ".
+ "[".$appreq->threadTrace."]:\n$e\n"
+ )
+ );
+ };
+
+
+
+ # ----------------------------------------------
+
+
+ # XXX may need this later
+ # $_->[1] = 1 for (@OpenSRF::AppSession::_CLIENT_CACHE);
+
+ $in_request--;
+
+ $log->debug( "Pending Requests: " . scalar(@pending_requests), INTERNAL );
+
+ # cycle through queued requests
+ while( my $aref = shift @pending_requests ) {
+ $in_request++;
+ my $resp;
+ try {
+ # un-if(0) this block to enable param checking based on signature and argc
+ if (0) {
+ if (@args < $aref->[2]->argc) {
+ die "Not enough params passed to ".
+ $aref->[2]->api_name." : requires ". $aref->[2]->argc
+ }
+ if (@args) {
+ my $sig = $aref->[2]->signature;
+ if ($sig && exists $sig->{params}) {
+ for my $p (0 .. scalar(@{ $sig->{params} }) - 1 ) {
+ my $s = $sig->{params}->[$p];
+ my $a = $args[$p];
+ if ($s->{class} && OpenSRF::Utils::JSON->lookup_hint(ref $a) ne $s->{class}) {
+ die "Incorrect param class at position $p : should be a '$$s{class}'";
+ } elsif ($s->{type}) {
+ if (lc($s->{type}) eq 'object' && $a !~ /HASH/o) {
+ die "Incorrect param type at position $p : should be an 'object'";
+ } elsif (lc($s->{type}) eq 'array' && $a !~ /ARRAY/o) {
+ die "Incorrect param type at position $p : should be an 'array'";
+ } elsif (lc($s->{type}) eq 'number' && (ref($a) || $a !~ /^-?\d+(?:\.\d+)?$/o)) {
+ die "Incorrect param type at position $p : should be a 'number'";
+ } elsif (lc($s->{type}) eq 'string' && ref($a)) {
+ die "Incorrect param type at position $p : should be a 'string'";
+ }
+ }
+ }
+ }
+ }
+ }
+
+ my $start = time;
+ my $response = $aref->[2]->run( $aref->[0], @{$aref->[1]} );
+ my $time = sprintf '%.3f', time - $start;
+ $log->debug( "Method duration for [".$aref->[2]->api_name." -> ".join(', ',@{$aref->[1]}).']: '.$time, DEBUG );
+
+ $appreq = $aref->[0];
+ if( ref( $response ) ) {
+ $appreq->respond_complete( $response );
+ } else {
+ $appreq->status( OpenSRF::DomainObject::oilsConnectStatus->new(
+ statusCode => STATUS_COMPLETE(),
+ status => 'Request Complete' ) );
+ }
+ $log->debug( "Executed: " . $appreq->threadTrace, INTERNAL );
+ } catch Error with {
+ my $e = shift;
+ if(UNIVERSAL::isa($e,"Error")) {
+ $e = $e->stringify();
+ }
+ $session->status(
+ OpenSRF::DomainObject::oilsMethodException->new(
+ statusCode => STATUS_INTERNALSERVERERROR(),
+ status => "Call to [".$aref->[2]->api_name."] faild: $e"
+ )
+ );
+ };
+ $in_request--;
+ }
+
+ return 1;
+ }
+
+ $log->info("Received non-REQUEST message in Application handler");
+
+ my $res = OpenSRF::DomainObject::oilsMethodException->new(
+ status => "Received non-REQUEST message in Application handler");
+ $session->send('ERROR', $res);
+ $session->kill_me;
+ return 1;
+
+ } else {
+ $session->push_queue([ $app_msg, $session->last_threadTrace ]);
+ }
+
+ $session->last_message_type('');
+ $session->last_message_api_level('');
+
+ return 1;
+}
+
+sub is_registered {
+ my $self = shift;
+ my $api_name = shift;
+ my $api_level = shift || 1;
+ return exists($_METHODS[$api_level]{$api_name});
+}
+
+
+sub normalize_whitespace {
+ my $txt = shift;
+
+ $txt =~ s/^\s+//gso;
+ $txt =~ s/\s+$//gso;
+ $txt =~ s/\s+/ /gso;
+ $txt =~ s/\n//gso;
+ $txt =~ s/\. /\. /gso;
+
+ return $txt;
+}
+
+sub parse_string_signature {
+ my $string = shift;
+ return [] unless $string;
+ my @chunks = split(/\@/smo, $string);
+
+ my @params;
+ my $ret;
+ my $desc = '';
+ for (@chunks) {
+ if (/^return (.+)$/so) {
+ $ret = [normalize_whitespace($1)];
+ } elsif (/^param (\w+) \b(.+)$/so) {
+ push @params, [ $1, normalize_whitespace($2) ];
+ } else {
+ $desc .= '@' if $desc;
+ $desc .= $_;
+ }
+ }
+
+ return [normalize_whitespace($desc),\@params, $ret];
+}
+
+sub parse_array_signature {
+ my $array = shift;
+ my ($d,$p,$r) = @$array;
+ return {} unless ($d or $p or $r);
+
+ return {
+ desc => $d,
+ params => [
+ map {
+ { name => $$_[0],
+ desc => $$_[1],
+ type => $$_[2],
+ class => $$_[3],
+ }
+ } @$p
+ ],
+ 'return'=>
+ { desc => $$r[0],
+ type => $$r[1],
+ class => $$r[2],
+ }
+ };
+}
+
+sub register_method {
+ my $self = shift;
+ my $app = ref($self) || $self;
+ my %args = @_;
+
+
+ throw OpenSRF::DomainObject::oilsMethodException unless ($args{method});
+
+ $args{api_level} = 1 unless(defined($args{api_level}));
+ $args{stream} ||= 0;
+ $args{remote} ||= 0;
+ $args{argc} ||= 0;
+ $args{package} ||= $app;
+ $args{server_class} = server_class();
+ $args{api_name} ||= $args{server_class} . '.' . $args{method};
+
+ # un-if(0) this block to enable signature parsing
+ if (!$args{signature}) {
+ if ($args{notes} && !ref($args{notes})) {
+ $args{signature} =
+ parse_array_signature( parse_string_signature( $args{notes} ) );
+ }
+ } elsif( !ref($args{signature}) ) {
+ $args{signature} =
+ parse_array_signature( parse_string_signature( $args{signature} ) );
+ } elsif( ref($args{signature}) eq 'ARRAY') {
+ $args{signature} =
+ parse_array_signature( $args{signature} );
+ }
+
+ unless ($args{object_hint}) {
+ ($args{object_hint} = $args{package}) =~ s/::/_/go;
+ }
+
+ OpenSRF::Utils::JSON->register_class_hint( name => $args{package}, hint => $args{object_hint}, type => "hash" );
+
+ $_METHODS[$args{api_level}]{$args{api_name}} = bless \%args => $app;
+
+ __PACKAGE__->register_method(
+ stream => 0,
+ argc => $args{argc},
+ api_name => $args{api_name}.'.atomic',
+ method => 'make_stream_atomic',
+ notes => "This is a system generated method. Please see the definition for $args{api_name}",
+ ) if ($args{stream});
+}
+
+sub retrieve_remote_apis {
+ my $method = shift;
+ my $session = OpenSRF::AppSession->create('router');
+ try {
+ $session->connect or OpenSRF::EX::WARN->throw("Connection to router timed out");
+ } catch Error with {
+ my $e = shift;
+ $log->debug( "Remote subrequest returned an error:\n". $e );
+ return undef;
+ } finally {
+ return undef unless ($session->state == $session->CONNECTED);
+ };
+
+ my $req = $session->request( 'opensrf.router.info.class.list' );
+ my $list = $req->recv;
+
+ if( UNIVERSAL::isa($list,"Error") ) {
+ throw $list;
+ }
+
+ my $content = $list->content;
+
+ $req->finish;
+ $session->finish;
+ $session->disconnect;
+
+ my %u_list = map { ($_ => 1) } @$content;
+
+ for my $class ( keys %u_list ) {
+ next if($class eq $server_class);
+ populate_remote_method_cache($class, $method);
+ }
+}
+
+sub populate_remote_method_cache {
+ my $class = shift;
+ my $meth = shift;
+
+ my $session = OpenSRF::AppSession->create($class);
+ try {
+ $session->connect or OpenSRF::EX::WARN->throw("Connection to $class timed out");
+
+ my $call = 'opensrf.system.method.all' unless (defined $meth);
+ $call = 'opensrf.system.method' if (defined $meth);
+
+ my $req = $session->request( $call, $meth );
+
+ while (my $method = $req->recv) {
+ next if (UNIVERSAL::isa($method, 'Error'));
+
+ $method = $method->content;
+ next if ( exists($_METHODS[$$method{api_level}]) &&
+ exists($_METHODS[$$method{api_level}]{$$method{api_name}}) );
+ $method->{remote} = 1;
+ bless($method, __PACKAGE__ );
+ $_METHODS[$$method{api_level}]{$$method{api_name}} = $method;
+ }
+
+ $req->finish;
+ $session->finish;
+ $session->disconnect;
+
+ } catch Error with {
+ my $e = shift;
+ $log->debug( "Remote subrequest returned an error:\n". $e );
+ return undef;
+ };
+}
+
+sub method_lookup {
+ my $self = shift;
+ my $method = shift;
+ my $proto = shift;
+ my $no_recurse = shift || 0;
+ my $no_remote = shift || 0;
+
+ # this instead of " || 1;" above to allow api_level 0
+ $proto = $self->api_level unless (defined $proto);
+
+ my $class = ref($self) || $self;
+
+ $log->debug("Lookup of [$method] by [$class] in api_level [$proto]", DEBUG);
+ $log->debug("Available methods\n\t".join("\n\t", keys %{ $_METHODS[$proto] }), INTERNAL);
+
+ my $meth;
+ if (__PACKAGE__->thunk) {
+ for my $p ( reverse(1 .. $proto) ) {
+ if (exists $_METHODS[$p]{$method}) {
+ $meth = $_METHODS[$p]{$method};
+ }
+ }
+ } else {
+ if (exists $_METHODS[$proto]{$method}) {
+ $meth = $_METHODS[$proto]{$method};
+ }
+ }
+
+ if (defined $meth) {
+ if($no_remote and $meth->{remote}) {
+ $log->debug("OH CRAP We're not supposed to return remote methods", WARN);
+ return undef;
+ }
+
+ } elsif (!$no_recurse) {
+ $log->debug("We didn't find [$method], asking everyone else.", DEBUG);
+ retrieve_remote_apis($method);
+ $meth = $self->method_lookup($method,$proto,1);
+ }
+
+ return $meth;
+}
+
+sub run {
+ my $self = shift;
+ my $req = shift;
+
+ my $resp;
+ my @params = @_;
+
+ if ( !UNIVERSAL::isa($req, 'OpenSRF::AppRequest') ) {
+ $log->debug("Creating a SubRequest object", DEBUG);
+ unshift @params, $req;
+ $req = OpenSRF::AppSubrequest->new;
+ $req->session( $self->session ) if ($self->session);
+
+ } else {
+ $log->debug("This is a top level request", DEBUG);
+ }
+
+ if (!$self->{remote}) {
+ my $code = \&{$self->{package} . '::' . $self->{method}};
+ my $err = undef;
+
+ try {
+ $resp = $code->($self, $req, @params);
+
+ } catch Error with {
+ $err = shift;
+
+ if( ref($self) eq 'HASH') {
+ $log->error("Sub $$self{package}::$$self{method} DIED!!!\n\t$err\n", ERROR);
+ }
+ };
+
+ if($err) {
+ if(UNIVERSAL::isa($err,"Error")) {
+ throw $err;
+ } else {
+ die $err->stringify;
+ }
+ }
+
+
+ $log->debug("Coderef for [$$self{package}::$$self{method}] has been run", DEBUG);
+
+ if ( ref($req) and UNIVERSAL::isa($req, 'OpenSRF::AppSubrequest') ) {
+ $req->respond($resp) if (defined $resp);
+ $log->debug("SubRequest object is responding with : " . join(" ",$req->responses), DEBUG);
+ return $req->responses;
+ } else {
+ $log->debug("A top level Request object is responding $resp", DEBUG) if (defined $resp);
+ return $resp;
+ }
+ } else {
+ my $session = OpenSRF::AppSession->create($self->{server_class});
+ try {
+ #$session->connect or OpenSRF::EX::WARN->throw("Connection to [$$self{server_class}] timed out");
+ my $remote_req = $session->request( $self->{api_name}, @params );
+ while (my $remote_resp = $remote_req->recv) {
+ OpenSRF::Utils::Logger->debug("Remote Subrequest Received " . $remote_resp, INTERNAL );
+ if( UNIVERSAL::isa($remote_resp,"Error") ) {
+ throw $remote_resp;
+ }
+ $req->respond( $remote_resp->content );
+ }
+ $remote_req->finish();
+
+ } catch Error with {
+ my $e = shift;
+ $log->debug( "Remote subrequest returned an error:\n". $e );
+ return undef;
+ };
+
+ if ($session) {
+ $session->disconnect();
+ $session->finish();
+ }
+
+ $log->debug( "Remote Subrequest Responses " . join(" ", $req->responses), INTERNAL );
+
+ return $req->responses;
+ }
+ # huh? how'd we get here...
+ return undef;
+}
+
+sub introspect {
+ my $self = shift;
+ my $client = shift;
+ my $method = shift;
+ my $limit = shift;
+ my $offset = shift;
+
+ if ($self->api_name =~ /all$/o) {
+ $offset = $limit;
+ $limit = $method;
+ $method = undef;
+ }
+
+ my ($seen,$returned) = (0,0);
+ for my $api_level ( reverse(1 .. $#_METHODS) ) {
+ for my $api_name ( sort keys %{$_METHODS[$api_level]} ) {
+ if (!$offset || $offset <= $seen) {
+ if (!$_METHODS[$api_level]{$api_name}{remote}) {
+ if (defined($method)) {
+ if ($api_name =~ $method) {
+ if (!$limit || $returned < $limit) {
+ $client->respond( $_METHODS[$api_level]{$api_name} );
+ $returned++;
+ }
+ }
+ } else {
+ if (!$limit || $returned < $limit) {
+ $client->respond( $_METHODS[$api_level]{$api_name} );
+ $returned++;
+ }
+ }
+ }
+ }
+ $seen++;
+ }
+ }
+
+ return undef;
+}
+__PACKAGE__->register_method(
+ stream => 1,
+ method => 'introspect',
+ api_name => 'opensrf.system.method.all',
+ argc => 0,
+ signature => {
+ desc => q/This method is used to introspect an entire OpenSRF Application/,
+ return => {
+ desc => q/A stream of objects describing the methods available via this OpenSRF Application/,
+ type => 'object'
+ }
+ },
+);
+__PACKAGE__->register_method(
+ stream => 1,
+ method => 'introspect',
+ argc => 1,
+ api_name => 'opensrf.system.method',
+ argc => 1,
+ signature => {
+ desc => q/Use this method to get the definition of a single OpenSRF Method/,
+ params => [
+ { desc => q/The method to introspect/,
+ type => 'string' },
+ ],
+ return => { desc => q/An object describing the method requested, or an error if it can't be found/,
+ type => 'object' }
+ },
+);
+
+sub echo_method {
+ my $self = shift;
+ my $client = shift;
+ my @args = @_;
+
+ $client->respond( $_ ) for (@args);
+ return undef;
+}
+__PACKAGE__->register_method(
+ stream => 1,
+ method => 'echo_method',
+ argc => 1,
+ api_name => 'opensrf.system.echo',
+ signature => {
+ desc => q/A test method that will echo back it's arguments in a streaming response/,
+ params => [
+ { desc => q/One or more arguments to echo back/ }
+ ],
+ return => { desc => q/A stream of the arguments passed/ }
+ },
+);
+
+sub time_method {
+ my( $self, $conn ) = @_;
+ return CORE::time;
+}
+__PACKAGE__->register_method(
+ method => 'time_method',
+ argc => 0,
+ api_name => 'opensrf.system.time',
+ signature => {
+ desc => q/Returns the current system time as epoch seconds/,
+ return => { desc => q/epoch seconds/ }
+ }
+);
+
+sub make_stream_atomic {
+ my $self = shift;
+ my $req = shift;
+ my @args = @_;
+
+ (my $m_name = $self->api_name) =~ s/\.atomic$//o;
+ my $m = $self->method_lookup($m_name);
+
+ $m->session( $req->session );
+ my @results = $m->run(@args);
+ $m->session('');
+
+ return \@results;
+}
+
+
+1;
+
+
--- /dev/null
+package OpenSRF::App::Client;
+use base 'OpenSRF::Application';
+use OpenSRF::Utils::Logger qw/:level/;
+
+
+1;
--- /dev/null
+package OpenSRF::Application::Demo::Math;
+use base qw/OpenSRF::Application/;
+use OpenSRF::Application;
+use OpenSRF::Utils::Logger qw/:level/;
+use OpenSRF::DomainObject::oilsResponse;
+use OpenSRF::EX qw/:try/;
+use strict;
+use warnings;
+
+
+sub DESTROY{}
+
+our $log = 'OpenSRF::Utils::Logger';
+
+sub send_request {
+ my $self = shift;
+ my $client = shift;
+
+ my $method_name = shift;
+ my @params = @_;
+
+ my $session = OpenSRF::AppSession->create( "opensrf.dbmath" );
+ my $request = $session->request( "dbmath.$method_name", @params );
+ my $response = $request->recv();
+ if(!$response) { return undef; }
+ if($response->isa("Error")) {throw $response ($response->stringify);}
+ $session->finish();
+
+ return $response->content;
+
+}
+__PACKAGE__->register_method( method => 'send_request', api_name => '_send_request' );
+
+__PACKAGE__->register_method( method => 'add_1', api_name => 'add' );
+sub add_1 {
+ my $self = shift;
+ my $client = shift;
+ my @args = @_;
+
+ my $meth = $self->method_lookup('_send_request');
+ my ($result) = $meth->run('add',@args);
+
+ return $result;
+}
+
+__PACKAGE__->register_method( method => 'sub_1', api_name => 'sub' );
+sub sub_1 {
+ my $self = shift;
+ my $client = shift;
+ my @args = @_;
+
+ my $meth = $self->method_lookup('_send_request');
+ my ($result) = $meth->run('sub',@args);
+
+ return $result;
+}
+
+__PACKAGE__->register_method( method => 'mult_1', api_name => 'mult' );
+sub mult_1 {
+ my $self = shift;
+ my $client = shift;
+ my @args = @_;
+
+ my $meth = $self->method_lookup('_send_request');
+ my ($result) = $meth->run('mult',@args);
+
+ return $result;
+}
+
+__PACKAGE__->register_method( method => 'div_1', api_name => 'div' );
+sub div_1 {
+ my $self = shift;
+ my $client = shift;
+ my @args = @_;
+
+ my $meth = $self->method_lookup('_send_request');
+ my ($result) = $meth->run('div',@args);
+
+ return $result;
+}
+
+
+1;
--- /dev/null
+package OpenSRF::Application::Demo::MathDB;
+use OpenSRF::Utils::JSON;
+use base qw/OpenSRF::Application/;
+use OpenSRF::Application;
+use OpenSRF::DomainObject::oilsResponse qw/:status/;
+use OpenSRF::Utils::Logger qw/:level/;
+use strict;
+use warnings;
+
+sub DESTROY{}
+our $log = 'OpenSRF::Utils::Logger';
+sub initialize {}
+
+__PACKAGE__->register_method( method => 'add_1', api_name => 'dbmath.add' );
+sub add_1 {
+ my $self = shift;
+ my $client = shift;
+
+ my $n1 = shift;
+ my $n2 = shift;
+ my $a = $n1 + $n2;
+ return OpenSRF::Utils::JSON::number->new($a);
+}
+
+__PACKAGE__->register_method( method => 'sub_1', api_name => 'dbmath.sub' );
+sub sub_1 {
+ my $self = shift;
+ my $client = shift;
+
+ my $n1 = shift;
+ my $n2 = shift;
+ my $a = $n1 - $n2;
+ return OpenSRF::Utils::JSON::number->new($a);
+}
+
+__PACKAGE__->register_method( method => 'mult_1', api_name => 'dbmath.mult' );
+sub mult_1 {
+ my $self = shift;
+ my $client = shift;
+
+ my $n1 = shift;
+ my $n2 = shift;
+ my $a = $n1 * $n2;
+ return OpenSRF::Utils::JSON::number->new($a);
+}
+
+__PACKAGE__->register_method( method => 'div_1', api_name => 'dbmath.div' );
+sub div_1 {
+ my $self = shift;
+ my $client = shift;
+
+ my $n1 = shift;
+ my $n2 = shift;
+ my $a = $n1 / $n2;
+ return OpenSRF::Utils::JSON::number->new($a);
+}
+
+1;
--- /dev/null
+package OpenSRF::Application::Persist;
+use base qw/OpenSRF::Application/;
+use OpenSRF::Application;
+
+use OpenSRF::Utils::SettingsClient;
+use OpenSRF::EX qw/:try/;
+use OpenSRF::Utils qw/:common/;
+use OpenSRF::Utils::Logger;
+use OpenSRF::Utils::JSON;
+use DBI;
+
+use vars qw/$dbh $log $default_expire_time/;
+
+sub initialize {
+ $log = 'OpenSRF::Utils::Logger';
+
+ $sc = OpenSRF::Utils::SettingsClient->new;
+
+ my $dbfile = $sc->config_value( apps => 'opensrf.persist' => app_settings => 'dbfile');
+ unless ($dbfile) {
+ throw OpenSRF::EX::PANIC ("Can't find my dbfile for SQLite!");
+ }
+
+ my $init_dbh = DBI->connect("dbi:SQLite:dbname=$dbfile","","");
+ $init_dbh->{AutoCommit} = 1;
+ $init_dbh->{RaiseError} = 0;
+
+ $init_dbh->do( <<" SQL" );
+ CREATE TABLE storage (
+ id INTEGER PRIMARY KEY,
+ name_id INTEGER,
+ value TEXT
+ );
+ SQL
+
+ $init_dbh->do( <<" SQL" );
+ CREATE TABLE store_name (
+ id INTEGER PRIMARY KEY,
+ name TEXT UNIQUE
+ );
+ SQL
+
+ $init_dbh->do( <<" SQL" );
+ CREATE TABLE store_expire (
+ id INTEGER PRIMARY KEY,
+ atime INTEGER,
+ expire_interval INTEGER
+ );
+ SQL
+
+}
+
+sub child_init {
+ my $sc = OpenSRF::Utils::SettingsClient->new;
+
+ $default_expire_time = $sc->config_value( apps => 'opensrf.persist' => app_settings => 'default_expire_time' );
+ $default_expire_time ||= 300;
+
+ my $dbfile = $sc->config_value( apps => 'opensrf.persist' => app_settings => 'dbfile');
+ unless ($dbfile) {
+ throw OpenSRF::EX::PANIC ("Can't find my dbfile for SQLite!");
+ }
+
+ $dbh = DBI->connect("dbi:SQLite:dbname=$dbfile","","");
+ $dbh->{AutoCommit} = 1;
+ $dbh->{RaiseError} = 0;
+
+}
+
+sub create_store {
+ my $self = shift;
+ my $client = shift;
+
+ my $name = shift || '';
+
+ try {
+
+ my $continue = 0;
+ try {
+ _get_name_id($name);
+
+ } catch Error with {
+ $continue++;
+ };
+
+ throw OpenSRF::EX::WARN ("Duplicate key: object name [$name] already exists! " . $dbh->errstr)
+ unless ($continue);
+
+ my $sth = $dbh->prepare("INSERT INTO store_name (name) VALUES (?);");
+ $sth->execute($name);
+ $sth->finish;
+
+ unless ($name) {
+ my $last_id = $dbh->last_insert_id(undef, undef, 'store_name', 'id');
+ $name = 'AUTOGENERATED!!'.$last_id;
+ $dbh->do("UPDATE store_name SET name = '$name' WHERE id = '$last_id';");
+ }
+
+ _flush_by_name($name);
+ return $name;
+ } catch Error with {
+ return undef;
+ };
+}
+__PACKAGE__->register_method(
+ api_name => 'opensrf.persist.slot.create',
+ method => 'create_store',
+ argc => 1,
+);
+
+
+sub create_expirable_store {
+ my $self = shift;
+ my $client = shift;
+ my $name = shift || do { throw OpenSRF::EX::InvalidArg ("Expirable slots must be given a name!") };
+ my $time = shift || $default_expire_time;
+
+ try {
+ ($name) = $self->method_lookup( 'opensrf.persist.slot.create' )->run( $name );
+ return undef unless $name;
+
+ $self->method_lookup('opensrf.persist.slot.set_expire')->run($name, $time);
+ return $name;
+ } catch Error with {
+ return undef;
+ };
+
+}
+__PACKAGE__->register_method(
+ api_name => 'opensrf.persist.slot.create_expirable',
+ method => 'create_expirable_store',
+ argc => 2,
+);
+
+sub _update_expire_atime {
+ my $id = shift;
+ $dbh->do('UPDATE store_expire SET atime = ? WHERE id = ?', {}, time(), $id);
+}
+
+sub set_expire_interval {
+ my $self = shift;
+ my $client = shift;
+ my $slot = shift;
+ my $new_interval = shift;
+
+ try {
+ my $etime = interval_to_seconds($new_interval);
+ my $sid = _get_name_id($slot);
+
+ $dbh->do('DELETE FROM store_expire where id = ?', {}, $sid);
+ return 0 if ($etime == 0);
+
+ $dbh->do('INSERT INTO store_expire (id, atime, expire_interval) VALUES (?,?,?);',{},$sid,time(),$etime);
+ return $etime;
+ }
+}
+__PACKAGE__->register_method(
+ api_name => 'opensrf.persist.slot.set_expire',
+ method => 'set_expire_interval',
+ argc => 2,
+);
+
+sub find_slot {
+ my $self = shift;
+ my $client = shift;
+ my $slot = shift;
+
+ my $sid = _get_name_id($slot);
+ return $slot if ($sid);
+ return undef;
+}
+__PACKAGE__->register_method(
+ api_name => 'opensrf.persist.slot.find',
+ method => 'find_slot',
+ argc => 2,
+);
+
+sub get_expire_interval {
+ my $self = shift;
+ my $client = shift;
+ my $slot = shift;
+
+ my $sid = _get_name_id($slot);
+ my ($int) = $dbh->selectrow_array('SELECT expire_interval FROM store_expire WHERE id = ?;',{},$sid);
+ return undef unless ($int);
+
+ my ($future) = $dbh->selectrow_array('SELECT atime + expire_interval FROM store_expire WHERE id = ?;',{},$sid);
+ return $future - time();
+}
+__PACKAGE__->register_method(
+ api_name => 'opensrf.persist.slot.get_expire',
+ method => 'get_expire_interval',
+ argc => 2,
+);
+
+
+sub _sweep_expired_slots {
+ return if (shift());
+
+ my $expired_slots = $dbh->selectcol_arrayref(<<" SQL", {}, time() );
+ SELECT id FROM store_expire WHERE (atime + expire_interval) <= ?;
+ SQL
+
+ return unless ($expired_slots);
+
+ $dbh->do('DELETE FROM storage WHERE name_id IN ('.join(',', map { '?' } @$expired_slots).');', {}, @$expired_slots);
+ $dbh->do('DELETE FROM store_expire WHERE id IN ('.join(',', map { '?' } @$expired_slots).');', {}, @$expired_slots);
+ for my $id (@$expired_slots) {
+ _flush_by_name(_get_id_name($id), 1);
+ }
+}
+
+sub add_item {
+ my $self = shift;
+ my $client = shift;
+
+ my $name = shift or do {
+ throw OpenSRF::EX::WARN ("No name specified!");
+ };
+
+ my $value = shift || '';
+
+ try {
+ my $name_id = _get_name_id($name);
+
+ if ($self->api_name =~ /object/) {
+ $dbh->do('DELETE FROM storage WHERE name_id = ?;', {}, $name_id);
+ }
+
+ $dbh->do('INSERT INTO storage (name_id,value) VALUES (?,?);', {}, $name_id, OpenSRF::Utils::JSON->perl2JSON($value));
+
+ _flush_by_name($name);
+
+ return $name;
+ } catch Error with {
+ return undef;
+ };
+}
+__PACKAGE__->register_method(
+ api_name => 'opensrf.persist.object.set',
+ method => 'add_item',
+ argc => 2,
+);
+__PACKAGE__->register_method(
+ api_name => 'opensrf.persist.queue.push',
+ method => 'add_item',
+ argc => 2,
+);
+__PACKAGE__->register_method(
+ api_name => 'opensrf.persist.stack.push',
+ method => 'add_item',
+ argc => 2,
+);
+
+sub _get_id_name {
+ my $name = shift or do {
+ throw OpenSRF::EX::WARN ("No slot id specified!");
+ };
+
+
+ my $name_id = $dbh->selectcol_arrayref("SELECT name FROM store_name WHERE id = ?;", {}, $name);
+
+ if (!ref($name_id) || !defined($name_id->[0])) {
+ throw OpenSRF::EX::WARN ("Slot id [$name] does not exist!");
+ }
+
+ return $name_id->[0];
+}
+
+sub _get_name_id {
+ my $name = shift or do {
+ throw OpenSRF::EX::WARN ("No slot name specified!");
+ };
+
+
+ my $name_id = $dbh->selectrow_arrayref("SELECT id FROM store_name WHERE name = ?;", {}, $name);
+
+ if (!ref($name_id) || !defined($name_id->[0])) {
+ throw OpenSRF::EX::WARN ("Slot name [$name] does not exist!");
+ }
+
+ return $name_id->[0];
+}
+
+sub destroy_store {
+ my $self = shift;
+ my $client = shift;
+
+ my $name = shift;
+
+ my $problem = 0;
+ try {
+ my $name_id = _get_name_id($name);
+
+ $dbh->do("DELETE FROM storage WHERE name_id = ?;", {}, $name_id);
+ $dbh->do("DELETE FROM store_name WHERE id = ?;", {}, $name_id);
+ $dbh->do("DELETE FROM store_expire WHERE id = ?;", {}, $name_id);
+
+ _sweep_expired_slots();
+ return $name;
+ } catch Error with {
+ return undef;
+ };
+
+}
+__PACKAGE__->register_method(
+ api_name => 'opensrf.persist.slot.destroy',
+ method => 'destroy_store',
+ argc => 1,
+);
+
+sub _flush_by_name {
+ my $name = shift;
+ my $no_sweep = shift;
+
+ my $name_id = _get_name_id($name);
+
+ unless ($no_sweep) {
+ _update_expire_atime($name);
+ _sweep_expired_slots();
+ }
+
+ if ($name =~ /^AUTOGENERATED!!/) {
+ my $count = $dbh->selectcol_arrayref("SELECT COUNT(*) FROM storage WHERE name_id = ?;", {}, $name_id);
+ if (!ref($count) || $$count[0] == 0) {
+ $dbh->do("DELETE FROM store_name WHERE name = ?;", {}, $name);
+ }
+ }
+}
+
+sub pop_queue {
+ my $self = shift;
+ my $client = shift;
+
+ my $name = shift or do {
+ throw OpenSRF::EX::WARN ("No queue name specified!");
+ };
+
+ try {
+ my $name_id = _get_name_id($name);
+
+ my $value = $dbh->selectrow_arrayref('SELECT id, value FROM storage WHERE name_id = ? ORDER BY id ASC LIMIT 1;', {}, $name_id);
+ $dbh->do('DELETE FROM storage WHERE id = ?;',{}, $value->[0]) unless ($self->api_name =~ /peek$/);
+
+ _flush_by_name($name);
+
+ return OpenSRF::Utils::JSON->JSON2perl( $value->[1] );
+ } catch Error with {
+ #my $e = shift;
+ #return $e;
+ return undef;
+ };
+}
+__PACKAGE__->register_method(
+ api_name => 'opensrf.persist.queue.peek',
+ method => 'pop_queue',
+ argc => 1,
+);
+__PACKAGE__->register_method(
+ api_name => 'opensrf.persist.queue.pop',
+ method => 'pop_queue',
+ argc => 1,
+);
+
+
+sub peek_slot {
+ my $self = shift;
+ my $client = shift;
+
+ my $name = shift or do {
+ throw OpenSRF::EX::WARN ("No slot name specified!");
+ };
+ my $name_id = _get_name_id($name);
+
+ my $order = 'ASC';
+ $order = 'DESC' if ($self->api_name =~ /stack/o);
+
+ my $values = $dbh->selectall_arrayref("SELECT value FROM storage WHERE name_id = ? ORDER BY id $order;", {}, $name_id);
+
+ $client->respond( OpenSRF::Utils::JSON->JSON2perl( $_->[0] ) ) for (@$values);
+
+ _flush_by_name($name);
+ return undef;
+}
+__PACKAGE__->register_method(
+ api_name => 'opensrf.persist.queue.peek.all',
+ method => 'peek_slot',
+ argc => 1,
+ stream => 1,
+);
+__PACKAGE__->register_method(
+ api_name => 'opensrf.persist.stack.peek.all',
+ method => 'peek_slot',
+ argc => 1,
+ stream => 1,
+);
+
+
+sub store_size {
+ my $self = shift;
+ my $client = shift;
+
+ my $name = shift or do {
+ throw OpenSRF::EX::WARN ("No queue name specified!");
+ };
+ my $name_id = _get_name_id($name);
+
+ my $value = $dbh->selectcol_arrayref('SELECT SUM(LENGTH(value)) FROM storage WHERE name_id = ?;', {}, $name_id);
+
+ return OpenSRF::Utils::JSON->JSON2perl( $value->[0] );
+}
+__PACKAGE__->register_method(
+ api_name => 'opensrf.persist.queue.size',
+ method => 'shift_stack',
+ argc => 1,
+);
+__PACKAGE__->register_method(
+ api_name => 'opensrf.persist.stack.size',
+ method => 'shift_stack',
+ argc => 1,
+);
+__PACKAGE__->register_method(
+ api_name => 'opensrf.persist.object.size',
+ method => 'shift_stack',
+ argc => 1,
+);
+
+sub store_depth {
+ my $self = shift;
+ my $client = shift;
+
+ my $name = shift or do {
+ throw OpenSRF::EX::WARN ("No queue name specified!");
+ };
+ my $name_id = _get_name_id($name);
+
+ my $value = $dbh->selectcol_arrayref('SELECT COUNT(*) FROM storage WHERE name_id = ?;', {}, $name_id);
+
+ return OpenSRF::Utils::JSON->JSON2perl( $value->[0] );
+}
+__PACKAGE__->register_method(
+ api_name => 'opensrf.persist.queue.length',
+ method => 'shift_stack',
+ argc => 1,
+);
+__PACKAGE__->register_method(
+ api_name => 'opensrf.persist.stack.depth',
+ method => 'shift_stack',
+ argc => 1,
+);
+
+sub shift_stack {
+ my $self = shift;
+ my $client = shift;
+
+ my $name = shift or do {
+ throw OpenSRF::EX::WARN ("No slot name specified!");
+ };
+
+ try {
+ my $name_id = _get_name_id($name);
+
+ my $value = $dbh->selectrow_arrayref('SELECT id, value FROM storage WHERE name_id = ? ORDER BY id DESC LIMIT 1;', {}, $name_id);
+ $dbh->do('DELETE FROM storage WHERE id = ?;',{}, $value->[0]) unless ($self->api_name =~ /peek$/);
+
+ _flush_by_name($name);
+
+ return OpenSRF::Utils::JSON->JSON2perl( $value->[1] );
+ } catch Error with {
+ my $e = shift;
+ return undef;
+ };
+}
+__PACKAGE__->register_method(
+ api_name => 'opensrf.persist.stack.peek',
+ method => 'shift_stack',
+ argc => 1,
+);
+__PACKAGE__->register_method(
+ api_name => 'opensrf.persist.stack.pop',
+ method => 'shift_stack',
+ argc => 1,
+);
+
+sub get_object {
+ my $self = shift;
+ my $client = shift;
+
+ my $name = shift or do {
+ throw OpenSRF::EX::WARN ("No object name specified!");
+ };
+
+ try {
+ my $name_id = _get_name_id($name);
+
+ my $value = $dbh->selectrow_arrayref('SELECT name_id, value FROM storage WHERE name_id = ? ORDER BY id DESC LIMIT 1;', {}, $name_id);
+ $dbh->do('DELETE FROM storage WHERE name_id = ?',{}, $value->[0]) unless ($self->api_name =~ /peek$/);
+
+ _flush_by_name($name);
+
+ return OpenSRF::Utils::JSON->JSON2perl( $value->[1] );
+ } catch Error with {
+ return undef;
+ };
+}
+__PACKAGE__->register_method(
+ api_name => 'opensrf.persist.object.peek',
+ method => 'shift_stack',
+ argc => 1,
+);
+__PACKAGE__->register_method(
+ api_name => 'opensrf.persist.object.get',
+ method => 'shift_stack',
+ argc => 1,
+);
+
+1;
--- /dev/null
+package OpenSRF::Application::Settings;
+use OpenSRF::Application;
+use OpenSRF::Utils::SettingsParser;
+use OpenSRF::Utils::Logger qw/$logger/;
+use base 'OpenSRF::Application';
+
+sub child_exit {
+ $logger->debug("settings server child exiting...$$");
+}
+
+
+__PACKAGE__->register_method( method => 'get_host_config', api_name => 'opensrf.settings.host_config.get' );
+sub get_host_config {
+ my( $self, $client, $host ) = @_;
+ my $parser = OpenSRF::Utils::SettingsParser->new();
+ return $parser->get_server_config($host);
+}
+
+__PACKAGE__->register_method( method => 'get_default_config', api_name => 'opensrf.settings.default_config.get' );
+sub get_default_config {
+ my( $self, $client ) = @_;
+ my $parser = OpenSRF::Utils::SettingsParser->new();
+ return $parser->get_default_config();
+}
+
+
+
+
+__PACKAGE__->register_method( method => 'xpath_get', api_name => 'opensrf.settings.xpath.get' );
+
+__PACKAGE__->register_method(
+ method => 'xpath_get',
+ api_name => 'opensrf.settings.xpath.get.raw' );
+
+sub xpath_get {
+ my($self, $client, $xpath) = @_;
+ warn "*************** Received XPATH $xpath\n";
+ return OpenSRF::Utils::SettingsParser->new()->_get_all( $xpath );
+}
+
+
+1;
--- /dev/null
+package OpenSRF::DomainObject::oilsMessage;
+use OpenSRF::Utils::JSON;
+use OpenSRF::AppSession;
+use OpenSRF::DomainObject::oilsResponse qw/:status/;
+use OpenSRF::Utils::Logger qw/:level/;
+use warnings; use strict;
+use OpenSRF::EX qw/:try/;
+
+OpenSRF::Utils::JSON->register_class_hint(hint => 'osrfMessage', name => 'OpenSRF::DomainObject::oilsMessage', type => 'hash');
+
+sub toString {
+ my $self = shift;
+ my $pretty = shift;
+ return OpenSRF::Utils::JSON->perl2prettyJSON($self) if ($pretty);
+ return OpenSRF::Utils::JSON->perl2JSON($self);
+}
+
+sub new {
+ my $self = shift;
+ my $class = ref($self) || $self;
+ my %args = @_;
+ return bless \%args => $class;
+}
+
+
+=head1 NAME
+
+OpenSRF::DomainObject::oilsMessage
+
+=head1
+
+use OpenSRF::DomainObject::oilsMessage;
+
+my $msg = OpenSRF::DomainObject::oilsMessage->new( type => 'CONNECT' );
+
+$msg->payload( $domain_object );
+
+=head1 ABSTRACT
+
+OpenSRF::DomainObject::oilsMessage is used internally to wrap data sent
+between client and server. It provides the structure needed to authenticate
+session data, and also provides the logic needed to unwrap session data and
+pass this information along to the Application Layer.
+
+=cut
+
+my $log = 'OpenSRF::Utils::Logger';
+
+=head1 METHODS
+
+=head2 OpenSRF::DomainObject::oilsMessage->type( [$new_type] )
+
+=over 4
+
+Used to specify the type of message. One of
+B<CONNECT, REQUEST, RESULT, STATUS, ERROR, or DISCONNECT>.
+
+=back
+
+=cut
+
+sub type {
+ my $self = shift;
+ my $val = shift;
+ $self->{type} = $val if (defined $val);
+ return $self->{type};
+}
+
+=head2 OpenSRF::DomainObject::oilsMessage->api_level( [$new_api_level] )
+
+=over 4
+
+Used to specify the api_level of message. Currently, only api_level C<1> is
+supported. This will be used to check that messages are well-formed, and as
+a hint to the Application as to which version of a method should fulfill a
+REQUEST message.
+
+=back
+
+=cut
+
+sub api_level {
+ my $self = shift;
+ my $val = shift;
+ $self->{api_level} = $val if (defined $val);
+ return $self->{api_level};
+}
+
+=head2 OpenSRF::DomainObject::oilsMessage->sender_locale( [$locale] );
+
+=over 4
+
+Sets or gets the current message locale hint. Useful for telling the
+server how you see the world.
+
+=back
+
+=cut
+
+sub sender_locale {
+ my $self = shift;
+ my $val = shift;
+ $self->{locale} = $val if (defined $val);
+ return $self->{locale};
+}
+
+=head2 OpenSRF::DomainObject::oilsMessage->threadTrace( [$new_threadTrace] );
+
+=over 4
+
+Sets or gets the current message sequence identifier, or thread trace number,
+for a message. Useful as a debugging aid, but that's about it.
+
+=back
+
+=cut
+
+sub threadTrace {
+ my $self = shift;
+ my $val = shift;
+ $self->{threadTrace} = $val if (defined $val);
+ return $self->{threadTrace};
+}
+
+=head2 OpenSRF::DomainObject::oilsMessage->update_threadTrace
+
+=over 4
+
+Increments the threadTrace component of a message. This is automatic when
+using the normal session processing stack.
+
+=back
+
+=cut
+
+sub update_threadTrace {
+ my $self = shift;
+ my $tT = $self->threadTrace;
+
+ $tT ||= 0;
+ $tT++;
+
+ $log->debug("Setting threadTrace to $tT",DEBUG);
+
+ $self->threadTrace($tT);
+
+ return $tT;
+}
+
+=head2 OpenSRF::DomainObject::oilsMessage->payload( [$new_payload] )
+
+=over 4
+
+Sets or gets the payload of a message. This should be exactly one object
+of (sub)type domainObject or domainObjectCollection.
+
+=back
+
+=cut
+
+sub payload {
+ my $self = shift;
+ my $val = shift;
+ $self->{payload} = $val if (defined $val);
+ return $self->{payload};
+}
+
+=head2 OpenSRF::DomainObject::oilsMessage->handler( $session_id )
+
+=over 4
+
+Used by the message processing stack to set session state information from the current
+message, and then sends control (via the payload) to the Application layer.
+
+=back
+
+=cut
+
+sub handler {
+ my $self = shift;
+ my $session = shift;
+
+ my $mtype = $self->type;
+ my $locale = $self->sender_locale || '';
+ my $api_level = $self->api_level || 1;
+ my $tT = $self->threadTrace;
+
+ $log->debug("Message locale is $locale", DEBUG);
+
+ $session->last_message_type($mtype);
+ $session->last_message_api_level($api_level);
+ $session->last_threadTrace($tT);
+ $session->session_locale($locale);
+
+ $log->debug(" Received api_level => [$api_level], MType => [$mtype], ".
+ "from [".$session->remote_id."], threadTrace[".$self->threadTrace."]");
+
+ my $val;
+ if ( $session->endpoint == $session->SERVER() ) {
+ $val = $self->do_server( $session, $mtype, $api_level, $tT );
+
+ } elsif ($session->endpoint == $session->CLIENT()) {
+ $val = $self->do_client( $session, $mtype, $api_level, $tT );
+ }
+
+ if( $val ) {
+ return OpenSRF::Application->handler($session, $self->payload);
+ } else {
+ $log->debug("Request was handled internally", DEBUG);
+ }
+
+ return 1;
+
+}
+
+
+
+# handle server side message processing
+
+# !!! Returning 0 means that we don't want to pass ourselves up to the message layer !!!
+sub do_server {
+ my( $self, $session, $mtype, $api_level, $tT ) = @_;
+
+ # A Server should never receive STATUS messages. If so, we drop them.
+ # This is to keep STATUS's from dead client sessions from creating new server
+ # sessions which send mangled session exceptions to backends for messages
+ # that they are not aware of any more.
+ if( $mtype eq 'STATUS' ) { return 0; }
+
+
+ if ($mtype eq 'DISCONNECT') {
+ $session->disconnect;
+ $session->kill_me;
+ return 0;
+ }
+
+ if ($session->state == $session->CONNECTING()) {
+
+ if($mtype ne "CONNECT" and $session->stateless) {
+ return 1; #pass the message up the stack
+ }
+
+ # the transport layer thinks this is a new connection. is it?
+ unless ($mtype eq 'CONNECT') {
+ $log->error("Connection seems to be mangled: Got $mtype instead of CONNECT");
+
+ my $res = OpenSRF::DomainObject::oilsBrokenSession->new(
+ status => "Connection seems to be mangled: Got $mtype instead of CONNECT",
+ );
+
+ $session->status($res);
+ $session->kill_me;
+ return 0;
+
+ }
+
+ my $res = OpenSRF::DomainObject::oilsConnectStatus->new;
+ $session->status($res);
+ $session->state( $session->CONNECTED );
+
+ return 0;
+ }
+
+
+ return 1;
+
+}
+
+
+# Handle client side message processing. Return 1 when the the message should be pushed
+# up to the application layer. return 0 otherwise.
+sub do_client {
+
+ my( $self, $session , $mtype, $api_level, $tT) = @_;
+
+
+ if ($mtype eq 'STATUS') {
+
+ if ($self->payload->statusCode == STATUS_OK) {
+ $session->state($session->CONNECTED);
+ $log->debug("We connected successfully to ".$session->app);
+ return 0;
+ }
+
+ if ($self->payload->statusCode == STATUS_TIMEOUT) {
+ $session->state( $session->DISCONNECTED );
+ $session->reset;
+ $session->connect;
+ $session->push_resend( $session->app_request($self->threadTrace) );
+ $log->debug("Disconnected because of timeout");
+ return 0;
+
+ } elsif ($self->payload->statusCode == STATUS_REDIRECTED) {
+ $session->state( $session->DISCONNECTED );
+ $session->reset;
+ $session->connect;
+ $session->push_resend( $session->app_request($self->threadTrace) );
+ $log->debug("Disconnected because of redirect", WARN);
+ return 0;
+
+ } elsif ($self->payload->statusCode == STATUS_EXPFAILED) {
+ $session->state( $session->DISCONNECTED );
+ $log->debug("Disconnected because of mangled session", WARN);
+ $session->reset;
+ $session->push_resend( $session->app_request($self->threadTrace) );
+ return 0;
+
+ } elsif ($self->payload->statusCode == STATUS_CONTINUE) {
+ $session->reset_request_timeout($self->threadTrace);
+ return 0;
+
+ } elsif ($self->payload->statusCode == STATUS_COMPLETE) {
+ my $req = $session->app_request($self->threadTrace);
+ $req->complete(1) if ($req);
+ return 0;
+ }
+
+ # add more STATUS handling code here (as 'elsif's), for Message layer status stuff
+
+ #$session->state( $session->DISCONNECTED() );
+ #$session->reset;
+
+ } elsif ($session->state == $session->CONNECTING()) {
+ # This should be changed to check the type of response (is it a connectException?, etc.)
+ }
+
+ if( $self->payload and $self->payload->isa( "ERROR" ) ) {
+ if ($session->raise_remote_errors) {
+ $self->payload->throw();
+ }
+ }
+
+ $log->debug("oilsMessage passing to Application: " . $self->type." : ".$session->remote_id );
+
+ return 1;
+
+}
+
+1;
--- /dev/null
+package OpenSRF::DomainObject::oilsMethod;
+
+use OpenSRF::Utils::JSON;
+OpenSRF::Utils::JSON->register_class_hint(hint => 'osrfMethod', name => 'OpenSRF::DomainObject::oilsMethod', type => 'hash');
+
+sub toString {
+ my $self = shift;
+ my $pretty = shift;
+ return OpenSRF::Utils::JSON->perl2prettyJSON($self) if ($pretty);
+ return OpenSRF::Utils::JSON->perl2JSON($self);
+}
+
+sub new {
+ my $self = shift;
+ my $class = ref($self) || $self;
+ my %args = @_;
+ return bless \%args => $class;
+}
+
+
+=head1 NAME
+
+OpenSRF::DomainObject::oilsMethod
+
+=head1 SYNOPSIS
+
+use OpenSRF::DomainObject::oilsMethod;
+
+my $method = OpenSRF::DomainObject::oilsMethod->new( method => 'search' );
+
+$method->return_type( 'mods' );
+
+$method->params( 'title:harry potter' );
+
+$client->send( 'REQUEST', $method );
+
+=head1 METHODS
+
+=head2 OpenSRF::DomainObject::oilsMethod->method( [$new_method_name] )
+
+=over 4
+
+Sets or gets the method name that will be called on the server. As above,
+this can be specified as a build attribute as well as added to a prebuilt
+oilsMethod object.
+
+=back
+
+=cut
+
+sub method {
+ my $self = shift;
+ my $val = shift;
+ $self->{method} = $val if (defined $val);
+ return $self->{method};
+}
+
+=head2 OpenSRF::DomainObject::oilsMethod->return_type( [$new_return_type] )
+
+=over 4
+
+Sets or gets the return type for this method call. This can also be supplied as
+a build attribute.
+
+This option does not require that the server return the type you request. It is
+used as a suggestion when more than one return type or format is possible.
+
+=back
+
+=cut
+
+
+sub return_type {
+ my $self = shift;
+ my $val = shift;
+ $self->{return_type} = $val if (defined $val);
+ return $self->{return_type};
+}
+
+=head2 OpenSRF::DomainObject::oilsMethod->params( @new_params )
+
+=over 4
+
+Sets or gets the parameters for this method call. Just pass in either text
+parameters, or DOM nodes of any type.
+
+=back
+
+=cut
+
+
+sub params {
+ my $self = shift;
+ my @args = @_;
+ $self->{params} = \@args if (@args);
+ return @{ $self->{params} };
+}
+
+1;
--- /dev/null
+package OpenSRF::DomainObject::oilsResponse;
+use vars qw/@EXPORT_OK %EXPORT_TAGS/;
+use Exporter;
+use OpenSRF::Utils::JSON;
+use base qw/Exporter/;
+use OpenSRF::Utils::Logger qw/:level/;
+
+OpenSRF::Utils::JSON->register_class_hint( hint => 'osrfResponse', name => 'OpenSRF::DomainObject::oilsResponse', type => 'hash' );
+
+BEGIN {
+@EXPORT_OK = qw/STATUS_CONTINUE STATUS_OK STATUS_ACCEPTED
+ STATUS_BADREQUEST STATUS_UNAUTHORIZED STATUS_FORBIDDEN
+ STATUS_NOTFOUND STATUS_NOTALLOWED STATUS_TIMEOUT
+ STATUS_INTERNALSERVERERROR STATUS_NOTIMPLEMENTED
+ STATUS_VERSIONNOTSUPPORTED STATUS_REDIRECTED
+ STATUS_EXPFAILED STATUS_COMPLETE/;
+
+%EXPORT_TAGS = (
+ status => [ qw/STATUS_CONTINUE STATUS_OK STATUS_ACCEPTED
+ STATUS_BADREQUEST STATUS_UNAUTHORIZED STATUS_FORBIDDEN
+ STATUS_NOTFOUND STATUS_NOTALLOWED STATUS_TIMEOUT
+ STATUS_INTERNALSERVERERROR STATUS_NOTIMPLEMENTED
+ STATUS_VERSIONNOTSUPPORTED STATUS_REDIRECTED
+ STATUS_EXPFAILED STATUS_COMPLETE/ ],
+);
+
+}
+
+=head1 NAME
+
+OpenSRF::DomainObject::oilsResponse
+
+=head1 SYNOPSIS
+
+use OpenSRF::DomainObject::oilsResponse qw/:status/;
+
+my $resp = OpenSRF::DomainObject::oilsResponse->new;
+
+$resp->status( 'a status message' );
+
+$resp->statusCode( STATUS_CONTINUE );
+
+$client->respond( $resp );
+
+=head1 ABSTRACT
+
+OpenSRF::DomainObject::oilsResponse implements the base class for all Application
+layer messages send between the client and server.
+
+=cut
+
+sub STATUS_CONTINUE { return 100 }
+
+sub STATUS_OK { return 200 }
+sub STATUS_ACCEPTED { return 202 }
+sub STATUS_COMPLETE { return 205 }
+
+sub STATUS_REDIRECTED { return 307 }
+
+sub STATUS_BADREQUEST { return 400 }
+sub STATUS_UNAUTHORIZED { return 401 }
+sub STATUS_FORBIDDEN { return 403 }
+sub STATUS_NOTFOUND { return 404 }
+sub STATUS_NOTALLOWED { return 405 }
+sub STATUS_TIMEOUT { return 408 }
+sub STATUS_EXPFAILED { return 417 }
+
+sub STATUS_INTERNALSERVERERROR { return 500 }
+sub STATUS_NOTIMPLEMENTED { return 501 }
+sub STATUS_VERSIONNOTSUPPORTED { return 505 }
+
+my $log = 'OpenSRF::Utils::Logger';
+
+sub toString {
+ my $self = shift;
+ my $pretty = shift;
+ return OpenSRF::Utils::JSON->perl2prettyJSON($self) if ($pretty);
+ return OpenSRF::Utils::JSON->perl2JSON($self);
+}
+
+sub new {
+ my $class = shift;
+ $class = ref($class) || $class;
+
+ my $default_status = eval "\$${class}::status";
+ my $default_statusCode = eval "\$${class}::statusCode";
+
+ my %args = ( status => $default_status,
+ statusCode => $default_statusCode,
+ @_ );
+
+ return bless( \%args => $class );
+}
+
+sub status {
+ my $self = shift;
+ my $val = shift;
+ $self->{status} = $val if (defined $val);
+ return $self->{status};
+}
+
+sub statusCode {
+ my $self = shift;
+ my $val = shift;
+ $self->{statusCode} = $val if (defined $val);
+ return $self->{statusCode};
+}
+
+#-------------------------------------------------------------------------------
+
+package OpenSRF::DomainObject::oilsStatus;
+use OpenSRF::DomainObject::oilsResponse qw/:status/;
+use base 'OpenSRF::DomainObject::oilsResponse';
+use vars qw/$status $statusCode/;
+OpenSRF::Utils::JSON->register_class_hint( hint => 'osrfStatus', name => 'OpenSRF::DomainObject::oilsStatus', type => 'hash' );
+
+=head1 NAME
+
+OpenSRF::DomainObject::oilsException
+
+=head1 SYNOPSIS
+
+use OpenSRF::DomainObject::oilsResponse;
+
+...
+
+# something happens.
+
+$client->status( OpenSRF::DomainObject::oilsStatus->new );
+
+=head1 ABSTRACT
+
+The base class for Status messages sent between client and server. This
+is implemented on top of the C<OpenSRF::DomainObject::oilsResponse> class, and
+sets the default B<status> to C<Status> and B<statusCode> to C<STATUS_OK>.
+
+=cut
+
+$status = 'Status';
+$statusCode = STATUS_OK;
+
+#-------------------------------------------------------------------------------
+
+package OpenSRF::DomainObject::oilsConnectStatus;
+use OpenSRF::DomainObject::oilsResponse qw/:status/;
+use base 'OpenSRF::DomainObject::oilsStatus';
+use vars qw/$status $statusCode/;
+OpenSRF::Utils::JSON->register_class_hint( hint => 'osrfConnectStatus', name => 'OpenSRF::DomainObject::oilsConnectStatus', type => 'hash' );
+
+=head1 NAME
+
+OpenSRF::DomainObject::oilsConnectStatus
+
+=head1 SYNOPSIS
+
+use OpenSRF::DomainObject::oilsResponse;
+
+...
+
+# something happens.
+
+$client->status( new OpenSRF::DomainObject::oilsConnectStatus );
+
+=head1 ABSTRACT
+
+The class for Stati relating to the connection status of a session. This
+is implemented on top of the C<OpenSRF::DomainObject::oilsStatus> class, and
+sets the default B<status> to C<Connection Successful> and B<statusCode> to C<STATUS_OK>.
+
+=head1 SEE ALSO
+
+B<OpenSRF::DomainObject::oilsStatus>
+
+=cut
+
+$status = 'Connection Successful';
+$statusCode = STATUS_OK;
+
+#-------------------------------------------------------------------------------
+
+package OpenSRF::DomainObject::oilsContinueStatus;
+use OpenSRF::DomainObject::oilsResponse qw/:status/;
+use base 'OpenSRF::DomainObject::oilsStatus';
+use vars qw/$status $statusCode/;
+OpenSRF::Utils::JSON->register_class_hint( hint => 'osrfContinueStatus', name => 'OpenSRF::DomainObject::oilsContinueStatus', type => 'hash' );
+
+=head1 NAME
+
+OpenSRF::DomainObject::oilsContinueStatus
+
+=head1 SYNOPSIS
+
+use OpenSRF::DomainObject::oilsResponse;
+
+...
+
+# something happens.
+
+$client->status( new OpenSRF::DomainObject::oilsContinueStatus );
+
+=head1 ABSTRACT
+
+Implements the STATUS_CONTINUE message, informing the client that it should
+continue to wait for a response to its request.
+
+=head1 SEE ALSO
+
+B<OpenSRF::DomainObject::oilsStatus>
+
+=cut
+
+$status = 'Please hold. Creating response...';
+$statusCode = STATUS_CONTINUE;
+
+1;
+
+#-------------------------------------------------------------------------------
+
+package OpenSRF::DomainObject::oilsResult;
+use OpenSRF::DomainObject::oilsResponse qw/:status/;
+use base 'OpenSRF::DomainObject::oilsResponse';
+use vars qw/$status $statusCode/;
+OpenSRF::Utils::JSON->register_class_hint( hint => 'osrfResult', name => 'OpenSRF::DomainObject::oilsResult', type => 'hash' );
+
+
+$status = 'OK';
+$statusCode = STATUS_OK;
+
+=head1 NAME
+
+OpenSRF::DomainObject::oilsResult
+
+=head1 SYNOPSIS
+
+use OpenSRF::DomainObject::oilsResponse;
+
+ .... do stuff, create $object ...
+
+my $res = OpenSRF::DomainObject::oilsResult->new;
+
+$res->content($object)
+
+$session->respond( $res );
+
+=head1 ABSTRACT
+
+This is the base class for encapuslating RESULT messages send from the server
+to a client. It is a subclass of B<OpenSRF::DomainObject::oilsResponse>, and
+sets B<status> to C<OK> and B<statusCode> to C<STATUS_OK>.
+
+=head1 METHODS
+
+=head2 OpenSRF::DomainObject::oilsMessage->content( [$new_content] )
+
+=over 4
+
+Sets or gets the content of the response. This should be exactly one object
+of (sub)type domainObject or domainObjectCollection.
+
+=back
+
+=cut
+
+sub content {
+ my $self = shift;
+ my $val = shift;
+
+ $self->{content} = $val if (defined $val);
+ return $self->{content};
+}
+
+=head1 SEE ALSO
+
+B<OpenSRF::DomainObject::oilsResponse>
+
+=cut
+
+1;
+
+#-------------------------------------------------------------------------------
+
+package OpenSRF::DomainObject::oilsException;
+use OpenSRF::DomainObject::oilsResponse qw/:status/;
+use OpenSRF::EX;
+use base qw/OpenSRF::EX OpenSRF::DomainObject::oilsResponse/;
+use vars qw/$status $statusCode/;
+use Error;
+OpenSRF::Utils::JSON->register_class_hint( hint => 'osrfException', name => 'OpenSRF::DomainObject::oilsException', type => 'hash' );
+
+sub message {
+ my $self = shift;
+ return '<' . $self->statusCode . '> ' . $self->status;
+}
+
+sub new {
+ my $class = shift;
+ return $class->OpenSRF::DomainObject::oilsResponse::new( @_ );
+}
+
+
+=head1 NAME
+
+OpenSRF::DomainObject::oilsException
+
+=head1 SYNOPSIS
+
+use OpenSRF::DomainObject::oilsResponse;
+
+...
+
+# something breaks.
+
+$client->send( 'ERROR', OpenSRF::DomainObject::oilsException->new( status => "ARRRRRRG!" ) );
+
+=head1 ABSTRACT
+
+The base class for Exception messages sent between client and server. This
+is implemented on top of the C<OpenSRF::DomainObject::oilsResponse> class, and
+sets the default B<status> to C<Exception occurred> and B<statusCode> to C<STATUS_BADREQUEST>.
+
+=cut
+
+$status = 'Exception occurred';
+$statusCode = STATUS_INTERNALSERVERERROR;
+
+#-------------------------------------------------------------------------------
+
+package OpenSRF::DomainObject::oilsConnectException;
+use OpenSRF::DomainObject::oilsResponse qw/:status/;
+use OpenSRF::EX;
+use base qw/OpenSRF::DomainObject::oilsException OpenSRF::EX::ERROR/;
+use vars qw/$status $statusCode/;
+OpenSRF::Utils::JSON->register_class_hint( hint => 'osrfConnectException', name => 'OpenSRF::DomainObject::oilsConnectException', type => 'hash' );
+
+=head1 NAME
+
+OpenSRF::DomainObject::oilsConnectException
+
+=head1 SYNOPSIS
+
+use OpenSRF::DomainObject::oilsResponse;
+
+...
+
+# something breaks while connecting.
+
+$client->send( 'ERROR', new OpenSRF::DomainObject::oilsConnectException );
+
+=head1 ABSTRACT
+
+The class for Exceptions that occur durring the B<CONNECT> phase of a session. This
+is implemented on top of the C<OpenSRF::DomainObject::oilsException> class, and
+sets the default B<status> to C<Connect Request Failed> and B<statusCode> to C<STATUS_FORBIDDEN>.
+
+=head1 SEE ALSO
+
+B<OpenSRF::DomainObject::oilsException>
+
+=cut
+
+
+$status = 'Connect Request Failed';
+$statusCode = STATUS_FORBIDDEN;
+
+#-------------------------------------------------------------------------------
+
+package OpenSRF::DomainObject::oilsMethodException;
+use OpenSRF::DomainObject::oilsResponse qw/:status/;
+use base 'OpenSRF::DomainObject::oilsException';
+use vars qw/$status $statusCode/;
+OpenSRF::Utils::JSON->register_class_hint( hint => 'osrfMethodException', name => 'OpenSRF::DomainObject::oilsMethodException', type => 'hash' );
+
+=head1 NAME
+
+OpenSRF::DomainObject::oilsMethodException
+
+=head1 SYNOPSIS
+
+use OpenSRF::DomainObject::oilsResponse;
+
+...
+
+# something breaks while looking up or starting
+# a method call.
+
+$client->send( 'ERROR', new OpenSRF::DomainObject::oilsMethodException );
+
+=head1 ABSTRACT
+
+The class for Exceptions that occur during the B<CONNECT> phase of a session. This
+is implemented on top of the C<OpenSRF::DomainObject::oilsException> class, and
+sets the default B<status> to C<Connect Request Failed> and B<statusCode> to C<STATUS_NOTFOUND>.
+
+=head1 SEE ALSO
+
+B<OpenSRF::DomainObject::oilsException>
+
+=cut
+
+
+$status = 'A server error occurred during method execution';
+$statusCode = STATUS_INTERNALSERVERERROR;
+
+# -------------------------------------------
+
+package OpenSRF::DomainObject::oilsServerError;
+use OpenSRF::DomainObject::oilsResponse qw/:status/;
+use base 'OpenSRF::DomainObject::oilsException';
+use vars qw/$status $statusCode/;
+OpenSRF::Utils::JSON->register_class_hint( hint => 'osrfServerError', name => 'OpenSRF::DomainObject::oilsServerError', type => 'hash' );
+
+$status = 'Internal Server Error';
+$statusCode = STATUS_INTERNALSERVERERROR;
+
+# -------------------------------------------
+
+package OpenSRF::DomainObject::oilsBrokenSession;
+use OpenSRF::DomainObject::oilsResponse qw/:status/;
+use OpenSRF::EX;
+use base qw/OpenSRF::DomainObject::oilsException OpenSRF::EX::ERROR/;
+use vars qw/$status $statusCode/;
+OpenSRF::Utils::JSON->register_class_hint( hint => 'osrfBrokenSession', name => 'OpenSRF::DomainObject::oilsBrokenSession', type => 'hash' );
+$status = "Request on Disconnected Session";
+$statusCode = STATUS_EXPFAILED;
+
+#-------------------------------------------------------------------------------
+
+package OpenSRF::DomainObject::oilsXMLParseError;
+use OpenSRF::DomainObject::oilsResponse qw/:status/;
+use OpenSRF::EX;
+use base qw/OpenSRF::DomainObject::oilsException OpenSRF::EX::ERROR/;
+use vars qw/$status $statusCode/;
+OpenSRF::Utils::JSON->register_class_hint( hint => 'osrfXMLParseError', name => 'OpenSRF::DomainObject::oilsXMLParseError', type => 'hash' );
+$status = "XML Parse Error";
+$statusCode = STATUS_EXPFAILED;
+
+#-------------------------------------------------------------------------------
+
+package OpenSRF::DomainObject::oilsAuthException;
+use OpenSRF::DomainObject::oilsResponse qw/:status/;
+use OpenSRF::EX;
+use base qw/OpenSRF::DomainObject::oilsException OpenSRF::EX::ERROR/;
+OpenSRF::Utils::JSON->register_class_hint( hint => 'osrfAuthException', name => 'OpenSRF::DomainObject::oilsAuthException', type => 'hash' );
+use vars qw/$status $statusCode/;
+$status = "Authentication Failure";
+$statusCode = STATUS_FORBIDDEN;
+
+1;
--- /dev/null
+package OpenSRF::EX;
+use Error qw(:try);
+use base qw( OpenSRF Error );
+use OpenSRF::Utils::Logger;
+
+my $log = "OpenSRF::Utils::Logger";
+$Error::Debug = 1;
+
+sub new {
+ my( $class, $message ) = @_;
+ $class = ref( $class ) || $class;
+ my $self = {};
+ $self->{'msg'} = ${$class . '::ex_msg_header'} .": $message";
+ return bless( $self, $class );
+}
+
+sub message() { return $_[0]->{'msg'}; }
+
+sub DESTROY{}
+
+
+=head1 OpenSRF::EX
+
+Top level exception. This class logs an exception when it is thrown. Exception subclasses
+should subclass one of OpenSRF::EX::INFO, NOTICE, WARN, ERROR, CRITICAL, and PANIC and provide
+a new() method that takes a message and a message() method that returns that message.
+
+=cut
+
+=head2 Synopsis
+
+
+ throw OpenSRF::EX::Jabber ("I Am Dying");
+
+ OpenSRF::EX::InvalidArg->throw( "Another way" );
+
+ my $je = OpenSRF::EX::Jabber->new( "I Cannot Connect" );
+ $je->throw();
+
+
+ See OpenSRF/EX.pm for example subclasses.
+
+=cut
+
+# Log myself and throw myself
+
+#sub message() { shift->alert_abstract(); }
+
+#sub new() { shift->alert_abstract(); }
+
+sub throw() {
+
+ my $self = shift;
+
+ if( ! ref( $self ) || scalar( @_ ) ) {
+ $self = $self->new( @_ );
+ }
+
+ if( $self->class->isa( "OpenSRF::EX::INFO" ) ||
+ $self->class->isa( "OpenSRF::EX::NOTICE" ) ||
+ $self->class->isa( "OpenSRF::EX::WARN" ) ) {
+
+ $log->debug( $self->stringify(), $log->DEBUG );
+ }
+
+ else{ $log->debug( $self->stringify(), $log->ERROR ); }
+
+ $self->SUPER::throw;
+}
+
+
+sub stringify() {
+ my $self = shift;
+ my($package, $file, $line) = get_caller();
+ my $name = ref($self);
+ my $msg = $self->message();
+
+ my ($sec,$min,$hour,$mday,$mon,$year) = localtime();
+ $year += 1900; $mon += 1;
+ my $date = sprintf(
+ '%s-%0.2d-%0.2dT%0.2d:%0.2d:%0.2d',
+ $year, $mon, $mday, $hour, $min, $sec);
+
+ return "Exception: $name $date $package $file:$line $msg\n";
+}
+
+
+# --- determine the originating caller of this exception
+sub get_caller() {
+
+ my $package = caller();
+ my $x = 0;
+ while( $package->isa( "Error" ) || $package =~ /^Error::/ ) {
+ $package = caller( ++$x );
+ }
+ return (caller($x));
+}
+
+
+
+
+# -------------------------------------------------------------------
+# -------------------------------------------------------------------
+
+# Top level exception subclasses defining the different exception
+# levels.
+
+# -------------------------------------------------------------------
+
+package OpenSRF::EX::INFO;
+use base qw(OpenSRF::EX);
+our $ex_msg_header = "System INFO";
+
+# -------------------------------------------------------------------
+
+package OpenSRF::EX::NOTICE;
+use base qw(OpenSRF::EX);
+our $ex_msg_header = "System NOTICE";
+
+# -------------------------------------------------------------------
+
+package OpenSRF::EX::WARN;
+use base qw(OpenSRF::EX);
+our $ex_msg_header = "System WARNING";
+
+# -------------------------------------------------------------------
+
+package OpenSRF::EX::ERROR;
+use base qw(OpenSRF::EX);
+our $ex_msg_header = "System ERROR";
+
+# -------------------------------------------------------------------
+
+package OpenSRF::EX::CRITICAL;
+use base qw(OpenSRF::EX);
+our $ex_msg_header = "System CRITICAL";
+
+# -------------------------------------------------------------------
+
+package OpenSRF::EX::PANIC;
+use base qw(OpenSRF::EX);
+our $ex_msg_header = "System PANIC";
+
+# -------------------------------------------------------------------
+# -------------------------------------------------------------------
+
+# Some basic exceptions
+
+# -------------------------------------------------------------------
+package OpenSRF::EX::Jabber;
+use base 'OpenSRF::EX::ERROR';
+our $ex_msg_header = "Jabber Exception";
+
+package OpenSRF::EX::JabberDisconnected;
+use base 'OpenSRF::EX::ERROR';
+our $ex_msg_header = "JabberDisconnected Exception";
+
+=head2 OpenSRF::EX::Jabber
+
+Thrown when there is a problem using the Jabber service
+
+=cut
+
+package OpenSRF::EX::Transport;
+use base 'OpenSRF::EX::ERROR';
+our $ex_msg_header = "Transport Exception";
+
+
+
+# -------------------------------------------------------------------
+package OpenSRF::EX::InvalidArg;
+use base 'OpenSRF::EX::ERROR';
+our $ex_msg_header = "Invalid Arg Exception";
+
+=head2 OpenSRF::EX::InvalidArg
+
+Thrown where an argument to a method was invalid or not provided
+
+=cut
+
+
+# -------------------------------------------------------------------
+package OpenSRF::EX::Socket;
+use base 'OpenSRF::EX::ERROR';
+our $ex_msg_header = "Socket Exception";
+
+=head2 OpenSRF::EX::Socket
+
+Thrown when there is a network layer exception
+
+=cut
+
+
+
+# -------------------------------------------------------------------
+package OpenSRF::EX::Config;
+use base 'OpenSRF::EX::PANIC';
+our $ex_msg_header = "Config Exception";
+
+=head2 OpenSRF::EX::Config
+
+Thrown when a package requires a config option that it cannot retrieve
+or the config file itself cannot be loaded
+
+=cut
+
+
+# -------------------------------------------------------------------
+package OpenSRF::EX::User;
+use base 'OpenSRF::EX::ERROR';
+our $ex_msg_header = "User Exception";
+
+=head2 OpenSRF::EX::User
+
+Thrown when an error occurs due to user identification information
+
+=cut
+
+package OpenSRF::EX::Session;
+use base 'OpenSRF::EX::ERROR';
+our $ex_msg_header = "Session Error";
+
+
+1;
--- /dev/null
+package OpenSRF::MultiSession;
+use OpenSRF::AppSession;
+use OpenSRF::Utils::Logger;
+use Time::HiRes qw/time usleep/;
+
+my $log = 'OpenSRF::Utils::Logger';
+
+sub new {
+ my $class = shift;
+ $class = ref($class) || $class;
+
+ my $self = bless {@_} => $class;
+
+ $self->{api_level} = 1 if (!defined($self->{api_level}));
+ $self->{session_hash_function} = \&_dummy_session_hash_function
+ if (!defined($self->{session_hash_function}));
+
+ if ($self->{cap}) {
+ $self->session_cap($self->{cap}) if (!$self->session_cap);
+ $self->request_cap($self->{cap}) if (!$self->request_cap);
+ }
+
+ if (!$self->session_cap) {
+ # XXX make adaptive the default once the logic is in place
+ #$self->adaptive(1);
+
+ $self->session_cap(10);
+ }
+ if (!$self->request_cap) {
+ # XXX make adaptive the default once the logic is in place
+ #$self->adaptive(1);
+
+ $self->request_cap(10);
+ }
+
+ $self->{sessions} = [];
+ $self->{running} = [];
+ $self->{completed} = [];
+ $self->{failed} = [];
+
+ for ( 1 .. $self->session_cap) {
+ push @{ $self->{sessions} },
+ OpenSRF::AppSession->create(
+ $self->{app},
+ $self->{api_level},
+ 1
+ );
+ #print "Creating connection ".$self->{sessions}->[-1]->session_id." ...\n";
+ $log->debug("Creating connection ".$self->{sessions}->[-1]->session_id." ...");
+ }
+
+ return $self;
+}
+
+sub _dummy_session_hash_function {
+ my $self = shift;
+ $self->{_dummy_hash_counter} = 1 if (!exists($self->{_dummy_hash_counter}));
+ return $self->{_dummy_hash_counter}++;
+}
+
+sub connect {
+ my $self = shift;
+ for my $ses (@{$self->{sessions}}) {
+ $ses->connect unless ($ses->connected);
+ }
+}
+
+sub finish {
+ my $self = shift;
+ $_->finish for (@{$self->{sessions}});
+}
+
+sub disconnect {
+ my $self = shift;
+ $_->disconnect for (@{$self->{sessions}});
+}
+
+sub session_hash_function {
+ my $self = shift;
+ my $session_hash_function = shift;
+ return unless (ref $self);
+
+ $self->{session_hash_function} = $session_hash_function if (defined $session_hash_function);
+ return $self->{session_hash_function};
+}
+
+sub failure_handler {
+ my $self = shift;
+ my $failure_handler = shift;
+ return unless (ref $self);
+
+ $self->{failure_handler} = $failure_handler if (defined $failure_handler);
+ return $self->{failure_handler};
+}
+
+sub success_handler {
+ my $self = shift;
+ my $success_handler = shift;
+ return unless (ref $self);
+
+ $self->{success_handler} = $success_handler if (defined $success_handler);
+ return $self->{success_handler};
+}
+
+sub session_cap {
+ my $self = shift;
+ my $cap = shift;
+ return unless (ref $self);
+
+ $self->{session_cap} = $cap if (defined $cap);
+ return $self->{session_cap};
+}
+
+sub request_cap {
+ my $self = shift;
+ my $cap = shift;
+ return unless (ref $self);
+
+ $self->{request_cap} = $cap if (defined $cap);
+ return $self->{request_cap};
+}
+
+sub adaptive {
+ my $self = shift;
+ my $adapt = shift;
+ return unless (ref $self);
+
+ $self->{adaptive} = $adapt if (defined $adapt);
+ return $self->{adaptive};
+}
+
+sub completed {
+ my $self = shift;
+ my $count = shift;
+ return unless (ref $self);
+
+
+ if (wantarray) {
+ $count ||= scalar @{$self->{completed}};
+ }
+
+ if (defined $count) {
+ return () unless (@{$self->{completed}});
+ return splice @{$self->{completed}}, 0, $count;
+ }
+
+ return scalar @{$self->{completed}};
+}
+
+sub failed {
+ my $self = shift;
+ my $count = shift;
+ return unless (ref $self);
+
+
+ if (wantarray) {
+ $count ||= scalar @{$self->{failed}};
+ }
+
+ if (defined $count) {
+ return () unless (@{$self->{failed}});
+ return splice @{$self->{failed}}, 0, $count;
+ }
+
+ return scalar @{$self->{failed}};
+}
+
+sub running {
+ my $self = shift;
+ return unless (ref $self);
+ return scalar(@{ $self->{running} });
+}
+
+
+sub request {
+ my $self = shift;
+ my $hash_param;
+
+ my $method = shift;
+ if (ref $method) {
+ $hash_param = $method;
+ $method = shift;
+ }
+
+ my @params = @_;
+
+ $self->session_reap;
+ if ($self->running < $self->request_cap ) {
+ my $index = $self->session_hash_function->($self, (defined $hash_param ? $hash_param : ()), $method, @params);
+ my $ses = $self->{sessions}->[$index % $self->session_cap];
+
+ #print "Running $method using session ".$ses->session_id."\n";
+
+ my $req = $ses->request( $method, @params );
+
+ push @{ $self->{running} },
+ { req => $req,
+ meth => $method,
+ hash => $hash_param,
+ params => [@params]
+ };
+
+ $log->debug("Making request [$method] ".$self->running."...");
+
+ return $req;
+ } elsif (!$self->adaptive) {
+ #print "Oops. Too many running: ".$self->running."\n";
+ $self->session_wait;
+ return $self->request((defined $hash_param ? $hash_param : ()), $method => @params);
+ } else {
+ # XXX do addaptive stuff ...
+ }
+}
+
+sub session_wait {
+ my $self = shift;
+ my $all = shift;
+
+ my $count;
+ if ($all) {
+ $count = $self->running;
+ while ($self->running) {
+ $self->session_reap;
+ }
+ return $count;
+ } else {
+ while(($count = $self->session_reap) == 0 && $self->running) {
+ usleep 100;
+ }
+ return $count;
+ }
+}
+
+sub session_reap {
+ my $self = shift;
+
+ my @done;
+ my @running;
+ while ( my $req = shift @{ $self->{running} } ) {
+ if ($req->{req}->complete) {
+ #print "Currently running: ".$self->running."\n";
+
+ $req->{response} = [ $req->{req}->recv ];
+ $req->{duration} = $req->{req}->duration;
+
+ #print "Completed ".$req->{meth}." in session ".$req->{req}->session->session_id." [$req->{duration}]\n";
+
+ if ($req->{req}->failed) {
+ #print "ARG!!!! Failed command $req->{meth} in session ".$req->{req}->session->session_id."\n";
+ $req->{error} = $req->{req}->failed;
+ push @{ $self->{failed} }, $req;
+ } else {
+ push @{ $self->{completed} }, $req;
+ }
+
+ push @done, $req;
+
+ } else {
+ #$log->debug("Still running ".$req->{meth}." in session ".$req->{req}->session->session_id);
+ push @running, $req;
+ }
+ }
+ push @{ $self->{running} }, @running;
+
+ for my $req ( @done ) {
+ my $handler = $req->{error} ? $self->failure_handler : $self->success_handler;
+ $handler->($self, $req) if ($handler);
+
+ $req->{req}->finish;
+ delete $$req{$_} for (keys %$req);
+
+ }
+
+ my $complete = scalar @done;
+ my $incomplete = scalar @running;
+
+ #$log->debug("Still running $incomplete, completed $complete");
+
+ return $complete;
+}
+
+1;
+
--- /dev/null
+package OpenSRF::System;
+use strict; use warnings;
+use OpenSRF;
+use base 'OpenSRF';
+use OpenSRF::Utils::Logger qw(:level);
+use OpenSRF::Transport::Listener;
+use OpenSRF::Transport;
+use OpenSRF::UnixServer;
+use OpenSRF::Utils;
+use OpenSRF::Utils::LogServer;
+use OpenSRF::EX qw/:try/;
+use POSIX qw/setsid :sys_wait_h/;
+use OpenSRF::Utils::Config;
+use OpenSRF::Utils::SettingsParser;
+use OpenSRF::Utils::SettingsClient;
+use OpenSRF::Application;
+use Net::Server::PreFork;
+use strict;
+
+my $bootstrap_config_file;
+sub import {
+ my( $self, $config ) = @_;
+ $bootstrap_config_file = $config;
+}
+
+=head2 Name/Description
+
+OpenSRF::System
+
+To start the system: OpenSRF::System->bootstrap();
+
+Simple system process management and automation. After instantiating the class, simply call
+bootstrap() to launch the system. Each launched process is stored as a process-id/method-name
+pair in a local hash. When we receive a SIG{CHILD}, we loop through this hash and relaunch
+any child processes that may have terminated.
+
+Currently automated processes include launching the internal Unix Servers, launching the inbound
+connections for each application, and starting the system shell.
+
+
+Note: There should be only one instance of this class
+alive at any given time. It is designed as a globel process handler and, hence, will cause much
+oddness if you call the bootstrap() method twice or attempt to create two of these by trickery.
+There is a single instance of the class created on the first call to new(). This same instance is
+returned on subsequent calls to new().
+
+=cut
+
+$| = 1;
+
+sub DESTROY {}
+
+# ----------------------------------------------
+
+$SIG{INT} = sub { instance()->killall(); };
+
+$SIG{HUP} = sub{ instance()->hupall(); };
+
+#$SIG{CHLD} = \&process_automation;
+
+
+{
+ # ---
+ # put $instance in a closure and return it for requests to new()
+ # since there should only be one System instance running
+ # -----
+ my $instance;
+ sub instance { return __PACKAGE__->new(); }
+ sub new {
+ my( $class ) = @_;
+
+ if( ! $instance ) {
+ $class = ref( $class ) || $class;
+ my $self = {};
+ $self->{'pid_hash'} = {};
+ bless( $self, $class );
+ $instance = $self;
+ }
+ return $instance;
+ }
+}
+
+# ----------------------------------------------
+# Commands to execute at system launch
+
+sub _unixserver {
+ my( $app ) = @_;
+ return "OpenSRF::UnixServer->new( '$app')->serve()";
+}
+
+sub _listener {
+ my( $app ) = @_;
+ return "OpenSRF::Transport::Listener->new( '$app' )->initialize()->listen()";
+}
+
+
+# ----------------------------------------------
+# Boot up the system
+
+sub load_bootstrap_config {
+
+ if(OpenSRF::Utils::Config->current) {
+ return;
+ }
+
+ if(!$bootstrap_config_file) {
+ die "Please provide a bootstrap config file to OpenSRF::System!\n" .
+ "use OpenSRF::System qw(/path/to/bootstrap_config);";
+ }
+
+ OpenSRF::Utils::Config->load( config_file => $bootstrap_config_file );
+
+ OpenSRF::Utils::JSON->register_class_hint( name => "OpenSRF::Application", hint => "method", type => "hash" );
+
+ OpenSRF::Transport->message_envelope( "OpenSRF::Transport::SlimJabber::MessageWrapper" );
+ OpenSRF::Transport::PeerHandle->set_peer_client( "OpenSRF::Transport::SlimJabber::PeerConnection" );
+ OpenSRF::Transport::Listener->set_listener( "OpenSRF::Transport::SlimJabber::Inbound" );
+ OpenSRF::Application->server_class('client');
+}
+
+sub bootstrap {
+
+ my $self = __PACKAGE__->instance();
+ load_bootstrap_config();
+ OpenSRF::Utils::Logger::set_config();
+ my $bsconfig = OpenSRF::Utils::Config->current;
+
+ # Start a process group and make me the captain
+ exit if (OpenSRF::Utils::safe_fork());
+ chdir('/');
+ setsid();
+ close STDIN;
+ close STDOUT;
+ close STDERR;
+
+ $0 = "OpenSRF System";
+
+ # -----------------------------------------------
+ # Launch the settings sever if necessary...
+ my $are_settings_server = 0;
+ if( (my $cfile = $bsconfig->bootstrap->settings_config) ) {
+ my $parser = OpenSRF::Utils::SettingsParser->new();
+
+ # since we're (probably) the settings server, we can go ahead and load the real config file
+ $parser->initialize( $cfile );
+ $OpenSRF::Utils::SettingsClient::host_config =
+ $parser->get_server_config($bsconfig->env->hostname);
+
+ my $client = OpenSRF::Utils::SettingsClient->new();
+ my $apps = $client->config_value("activeapps", "appname");
+ if(ref($apps) ne "ARRAY") { $apps = [$apps]; }
+
+ if(!defined($apps) || @$apps == 0) {
+ print "No apps to load, exiting...";
+ return;
+ }
+
+ for my $app (@$apps) {
+ # verify we are a settings server and launch
+ if( $app eq "opensrf.settings" and
+ $client->config_value("apps","opensrf.settings", "language") =~ /perl/i ) {
+
+ $are_settings_server = 1;
+ $self->launch_settings();
+ sleep 1;
+ $self->launch_settings_listener();
+ last;
+ }
+ }
+ }
+
+ # Launch everything else
+ OpenSRF::System->bootstrap_client(client_name => "system_client");
+ my $client = OpenSRF::Utils::SettingsClient->new();
+ my $apps = $client->config_value("activeapps", "appname" );
+ if(!ref($apps)) { $apps = [$apps]; }
+
+ if(!defined($apps) || @$apps == 0) {
+ print "No apps to load, exiting...";
+ return;
+ }
+
+ my $server_type = $client->config_value("server_type");
+ $server_type ||= "basic";
+
+ my $con = OpenSRF::Transport::PeerHandle->retrieve;
+ if($con) {
+ $con->disconnect;
+ }
+
+
+
+ if( $server_type eq "prefork" ) {
+ $server_type = "Net::Server::PreFork";
+ } else {
+ $server_type = "Net::Server::Single";
+ }
+
+ _log( " * Server type: $server_type", INTERNAL );
+
+ $server_type->use;
+
+ if( $@ ) {
+ throw OpenSRF::EX::PANIC ("Cannot set $server_type: $@" );
+ }
+
+ push @OpenSRF::UnixServer::ISA, $server_type;
+
+ _log( " * System bootstrap" );
+
+ # --- Boot the Unix servers
+ $self->launch_unix($apps);
+
+ sleep 2;
+
+ # --- Boot the listeners
+ $self->launch_listener($apps);
+
+ sleep 1;
+
+ _log( " * System is ready..." );
+
+# sleep 1;
+# my $ps = `ps ax | grep " Open" | grep -v grep | sort -r -k5`;
+# print "\n --- PS --- \n$ps --- PS ---\n\n";
+
+ while( 1 ) { sleep; }
+ exit;
+}
+
+
+
+# ----------------------------------------------
+# Bootstraps a single client connection.
+
+# named params are 'config_file' and 'client_name'
+#
+sub bootstrap_client {
+ my $self = shift;
+
+ my $con = OpenSRF::Transport::PeerHandle->retrieve;
+
+ if($con and $con->tcp_connected) {
+ return;
+ }
+
+ my %params = @_;
+
+ $bootstrap_config_file =
+ $params{config_file} || $bootstrap_config_file;
+
+ my $app = $params{client_name} || "client";
+
+
+ load_bootstrap_config();
+ OpenSRF::Utils::Logger::set_config();
+ OpenSRF::Transport::PeerHandle->construct( $app );
+
+}
+
+sub connected {
+ if (my $con = OpenSRF::Transport::PeerHandle->retrieve) {
+ return 1 if ($con->tcp_connected);
+ }
+ return 0;
+}
+
+sub bootstrap_logger {
+ $0 = "Log Server";
+ OpenSRF::Utils::LogServer->serve();
+}
+
+
+# ----------------------------------------------
+# Cycle through the known processes, reap the dead child
+# and put a new child in its place. (MMWWAHAHHAHAAAA!)
+
+sub process_automation {
+
+ my $self = __PACKAGE__->instance();
+
+ foreach my $pid ( keys %{$self->pid_hash} ) {
+
+ if( waitpid( $pid, WNOHANG ) == $pid ) {
+
+ my $method = $self->pid_hash->{$pid};
+ delete $self->pid_hash->{$pid};
+
+ my $newpid = OpenSRF::Utils::safe_fork();
+
+ OpenSRF::Utils::Logger->debug( "Relaunching $method", ERROR );
+ _log( "Relaunching => $method" );
+
+ if( $newpid ) {
+ $self->pid_hash( $newpid, $method );
+ }
+ else { eval $method; exit; }
+ }
+ }
+
+ $SIG{CHLD} = \&process_automation;
+}
+
+
+
+sub launch_settings {
+
+ # XXX the $self like this and pid automation will not work with this setup....
+ my($self) = @_;
+ @OpenSRF::UnixServer::ISA = qw(OpenSRF Net::Server::PreFork);
+
+ my $pid = OpenSRF::Utils::safe_fork();
+ if( $pid ) {
+ $self->pid_hash( $pid , "launch_settings()" );
+ }
+ else {
+ my $apname = "opensrf.settings";
+ #$0 = "OpenSRF App [$apname]";
+ eval _unixserver( $apname );
+ if($@) { die "$@\n"; }
+ exit;
+ }
+
+ @OpenSRF::UnixServer::ISA = qw(OpenSRF);
+
+}
+
+
+sub launch_settings_listener {
+
+ my $self = shift;
+ my $app = "opensrf.settings";
+ my $pid = OpenSRF::Utils::safe_fork();
+ if ( $pid ) {
+ $self->pid_hash( $pid , _listener( $app ) );
+ }
+ else {
+ my $apname = $app;
+ $0 = "OpenSRF listener [$apname]";
+ eval _listener( $app );
+ exit;
+ }
+
+}
+
+# ----------------------------------------------
+# Launch the Unix Servers
+
+sub launch_unix {
+ my( $self, $apps ) = @_;
+
+ my $client = OpenSRF::Utils::SettingsClient->new();
+
+ foreach my $app ( @$apps ) {
+
+ next unless $app;
+ my $lang = $client->config_value( "apps", $app, "language");
+ next unless $lang =~ /perl/i;
+ next if $app eq "opensrf.settings";
+
+ _log( " * Starting UnixServer for $app..." );
+
+ my $pid = OpenSRF::Utils::safe_fork();
+ if( $pid ) {
+ $self->pid_hash( $pid , _unixserver( $app ) );
+ }
+ else {
+ my $apname = $app;
+ $0 = "OpenSRF App ($apname)";
+ eval _unixserver( $app );
+ exit;
+ }
+ }
+}
+
+# ----------------------------------------------
+# Launch the inbound clients
+
+sub launch_listener {
+
+ my( $self, $apps ) = @_;
+ my $client = OpenSRF::Utils::SettingsClient->new();
+
+ foreach my $app ( @$apps ) {
+
+ next unless $app;
+ my $lang = $client->config_value( "apps", $app, "language");
+ next unless $lang =~ /perl/i;
+ next if $app eq "opensrf.settings";
+
+ _log( " * Starting Listener for $app..." );
+
+ my $pid = OpenSRF::Utils::safe_fork();
+ if ( $pid ) {
+ $self->pid_hash( $pid , _listener( $app ) );
+ }
+ else {
+ my $apname = $app;
+ $0 = "OpenSRF listener [$apname]";
+ eval _listener( $app );
+ exit;
+ }
+ }
+}
+
+
+# ----------------------------------------------
+
+sub pid_hash {
+ my( $self, $pid, $method ) = @_;
+ $self->{'pid_hash'}->{$pid} = $method
+ if( $pid and $method );
+ return $self->{'pid_hash'};
+}
+
+# ----------------------------------------------
+# If requested, the System can shut down.
+
+sub killall {
+
+ $SIG{CHLD} = 'IGNORE';
+ $SIG{INT} = 'IGNORE';
+ kill( 'INT', -$$ ); #kill all in process group
+ exit;
+
+}
+
+# ----------------------------------------------
+# Handle $SIG{HUP}
+sub hupall {
+
+ _log( "HUPping brood" );
+ $SIG{CHLD} = 'IGNORE';
+ $SIG{HUP} = 'IGNORE';
+ kill( 'HUP', -$$ );
+# $SIG{CHLD} = \&process_automation;
+ $SIG{HUP} = sub{ instance()->hupall(); };
+}
+
+
+# ----------------------------------------------
+# Log to debug, and stdout
+
+sub _log {
+ my $string = shift;
+ OpenSRF::Utils::Logger->debug( $string, INFO );
+ print $string . "\n";
+}
+
+# ----------------------------------------------
+
+
+1;
+
+
--- /dev/null
+package OpenSRF::Transport;
+use strict; use warnings;
+use base 'OpenSRF';
+use Time::HiRes qw/time/;
+use OpenSRF::AppSession;
+use OpenSRF::Utils::JSON;
+use OpenSRF::Utils::Logger qw(:level);
+use OpenSRF::DomainObject::oilsResponse qw/:status/;
+use OpenSRF::EX qw/:try/;
+use OpenSRF::Transport::SlimJabber::MessageWrapper;
+
+#------------------
+# --- These must be implemented by all Transport subclasses
+# -------------------------------------------
+
+=head2 get_listener
+
+Returns the package name of the package the system will use to
+gather incoming requests
+
+=cut
+
+sub get_listener { shift()->alert_abstract(); }
+
+=head2 get_peer_client
+
+Returns the name of the package responsible for client communication
+
+=cut
+
+sub get_peer_client { shift()->alert_abstract(); }
+
+=head2 get_msg_envelope
+
+Returns the name of the package responsible for parsing incoming messages
+
+=cut
+
+sub get_msg_envelope { shift()->alert_abstract(); }
+
+# -------------------------------------------
+
+our $message_envelope;
+my $logger = "OpenSRF::Utils::Logger";
+
+
+
+=head2 message_envelope( [$envelope] );
+
+Sets the message envelope class that will allow us to extract
+information from the messages we receive from the low
+level transport
+
+=cut
+
+sub message_envelope {
+ my( $class, $envelope ) = @_;
+ if( $envelope ) {
+ $message_envelope = $envelope;
+ $envelope->use;
+ if( $@ ) {
+ $logger->error(
+ "Error loading message_envelope: $envelope -> $@", ERROR);
+ }
+ }
+ return $message_envelope;
+}
+
+=head2 handler( $data )
+
+Creates a new MessageWrapper, extracts the remote_id, session_id, and message body
+from the message. Then, creates or retrieves the AppSession object with the session_id and remote_id.
+Finally, creates the message document from the body of the message and calls
+the handler method on the message document.
+
+=cut
+
+sub handler {
+ my $start_time = time();
+ my( $class, $service, $data ) = @_;
+
+ $logger->transport( "Transport handler() received $data", INTERNAL );
+
+ my $remote_id = $data->from;
+ my $sess_id = $data->thread;
+ my $body = $data->body;
+ my $type = $data->type;
+
+ $logger->set_osrf_xid($data->osrf_xid);
+
+
+ if (defined($type) and $type eq 'error') {
+ throw OpenSRF::EX::Session ("$remote_id IS NOT CONNECTED TO THE NETWORK!!!");
+
+ }
+
+ # See if the app_session already exists. If so, make
+ # sure the sender hasn't changed if we're a server
+ my $app_session = OpenSRF::AppSession->find( $sess_id );
+ if( $app_session and $app_session->endpoint == $app_session->SERVER() and
+ $app_session->remote_id ne $remote_id ) {
+
+ my $c = OpenSRF::Utils::SettingsClient->new();
+ if($c->config_value("apps", $app_session->service, "migratable")) {
+ $logger->debug("service is migratable, new client is $remote_id");
+ } else {
+
+ $logger->warn("Backend Gone or invalid sender");
+ my $res = OpenSRF::DomainObject::oilsBrokenSession->new();
+ $res->status( "Backend Gone or invalid sender, Reconnect" );
+ $app_session->status( $res );
+ return 1;
+ }
+ }
+
+ # Retrieve or build the app_session as appropriate (server_build decides which to do)
+ $logger->transport( "AppSession is valid or does not exist yet", INTERNAL );
+ $app_session = OpenSRF::AppSession->server_build( $sess_id, $remote_id, $service );
+
+ if( ! $app_session ) {
+ throw OpenSRF::EX::Session ("Transport::handler(): No AppSession object returned from server_build()");
+ }
+
+ # Create a document from the JSON contained within the message
+ my $doc;
+ eval { $doc = OpenSRF::Utils::JSON->JSON2perl($body); };
+ if( $@ ) {
+
+ $logger->warn("Received bogus JSON: $@");
+ $logger->warn("Bogus JSON data: $body");
+ my $res = OpenSRF::DomainObject::oilsXMLParseError->new( status => "JSON Parse Error --- $body\n\n$@" );
+
+ $app_session->status($res);
+ #$app_session->kill_me;
+ return 1;
+ }
+
+ $logger->transport( "Transport::handler() creating \n$body", INTERNAL );
+
+ # We need to disconnect the session if we got a jabber error on the client side. For
+ # server side, we'll just tear down the session and go away.
+ if (defined($type) and $type eq 'error') {
+ # If we're a server
+ if( $app_session->endpoint == $app_session->SERVER() ) {
+ $app_session->kill_me;
+ return 1;
+ } else {
+ $app_session->reset;
+ $app_session->state( $app_session->DISCONNECTED );
+ # below will lead to infinite looping, should return an exception
+ #$app_session->push_resend( $app_session->app_request(
+ # $doc->documentElement->firstChild->threadTrace ) );
+ $logger->debug(
+ "Got Jabber error on client connection $remote_id, nothing we can do..", ERROR );
+ return 1;
+ }
+ }
+
+ # cycle through and pass each oilsMessage contained in the message
+ # up to the message layer for processing.
+ for my $msg (@$doc) {
+
+ next unless ( $msg && UNIVERSAL::isa($msg => 'OpenSRF::DomainObject::oilsMessage'));
+
+ if( $app_session->endpoint == $app_session->SERVER() ) {
+
+ try {
+
+ if( ! $msg->handler( $app_session ) ) { return 0; }
+
+ $logger->debug("Successfully handled message", DEBUG);
+
+ } catch Error with {
+
+ my $e = shift;
+ my $res = OpenSRF::DomainObject::oilsServerError->new();
+ $res->status( $res->status . "\n$e");
+ $app_session->status($res) if $res;
+ $app_session->kill_me;
+ return 0;
+
+ };
+
+ } else {
+
+ if( ! $msg->handler( $app_session ) ) { return 0; }
+ $logger->info("Successfully handled message", DEBUG);
+
+ }
+
+ }
+
+ $logger->debug(sprintf("Message processing duration: %.3fs",(time() - $start_time)), DEBUG);
+
+ return $app_session;
+}
+
+1;
--- /dev/null
+package OpenSRF::Transport::Listener;
+use base 'OpenSRF';
+use OpenSRF::Utils::Logger qw(:level);
+use OpenSRF::Transport::SlimJabber::Inbound;
+use base 'OpenSRF::Transport::SlimJabber::Inbound';
+
+=head1 Description
+
+This is the empty class that acts as the subclass of the transport listener. My API
+includes
+
+new( $app )
+ create a new Listener with appname $app
+
+initialize()
+ Perform any transport layer connections/authentication.
+
+listen()
+ Block, wait for, and process incoming messages
+
+=cut
+
+=head2 set_listener()
+
+Sets my superclass. Pass in a string representing the perl module
+(e.g. OpenSRF::Transport::Jabber::JInbound) to be used as the
+superclass and it will be pushed onto @ISA.
+
+=cut
+
+sub set_listener {
+ my( $class, $listener ) = @_;
+ OpenSRF::Utils::Logger->transport("Loading Listener $listener", INFO );
+ if( $listener ) {
+ $listener->use;
+ if( $@ ) {
+ OpenSRF::Utils::Logger->error(
+ "Unable to set transport listener: $@", ERROR );
+ }
+ unshift @ISA, $listener;
+ }
+}
+
+
+1;
--- /dev/null
+package OpenSRF::Transport::PeerHandle;
+use OpenSRF::Utils::Logger qw(:level);
+use OpenSRF::EX;
+use base qw/OpenSRF::Transport::SlimJabber::PeerConnection/;
+use vars '@ISA';
+
+my $peer;
+
+=head2 peer_handle( $handle )
+
+Assigns the object that will act as the peer connection handle.
+
+=cut
+sub peer_handle {
+ my( $class, $handle ) = @_;
+ if( $handle ) { $peer = $handle; }
+ return $peer;
+}
+
+
+=head2 set_peer_client( $peer )
+
+Sets the class that will act as the superclass of this class.
+Pass in a string representing the module to be used as the superclass,
+and that module is 'used' and unshifted into @ISA. We now have that
+classes capabilities.
+
+=cut
+sub set_peer_client {
+ my( $class, $peer ) = @_;
+ if( $peer ) {
+ $peer->use;
+ if( $@ ) {
+ throw OpenSRF::EX::PANIC ( "Unable to set peer client: $@" );
+ }
+ unshift @ISA, $peer;
+ }
+}
+
+1;
--- /dev/null
+package OpenSRF::Transport::SlimJabber;
+use base qw/OpenSRF::Transport/;
+
+=head2 OpenSRF::Transport::SlimJabber
+
+Implements the Transport interface for providing the system with appropriate
+classes for handling transport layer messaging
+
+=cut
+
+
+sub get_listener { return "OpenSRF::Transport::SlimJabber::Inbound"; }
+
+sub get_peer_client { return "OpenSRF::Transport::SlimJabber::PeerConnection"; }
+
+sub get_msg_envelope { return "OpenSRF::Transport::SlimJabber::MessageWrapper"; }
+
+1;
--- /dev/null
+package OpenSRF::Transport::SlimJabber::Client;
+
+use strict;
+use warnings;
+
+use OpenSRF::EX;
+use OpenSRF::Utils::Config;
+use OpenSRF::Utils::Logger qw/$logger/;
+use OpenSRF::Transport::SlimJabber::XMPPReader;
+use OpenSRF::Transport::SlimJabber::XMPPMessage;
+use IO::Socket::UNIX;
+use FreezeThaw qw/freeze/;
+
+sub DESTROY{
+ shift()->disconnect;
+}
+
+=head1 NAME
+
+OpenSRF::Transport::SlimJabber::Client
+
+=head1 SYNOPSIS
+
+
+
+=head1 DESCRIPTION
+
+
+
+=cut
+
+=head1 METHODS
+
+=head2 new
+
+=cut
+
+sub new {
+ my( $class, %params ) = @_;
+ my $self = bless({}, ref($class) || $class);
+ $self->params(\%params);
+ return $self;
+}
+
+=head2 reader
+
+=cut
+
+sub reader {
+ my($self, $reader) = @_;
+ $self->{reader} = $reader if $reader;
+ return $self->{reader};
+}
+
+=head2 params
+
+=cut
+
+sub params {
+ my($self, $params) = @_;
+ $self->{params} = $params if $params;
+ return $self->{params};
+}
+
+=head2 socket
+
+=cut
+
+sub socket {
+ my($self, $socket) = @_;
+ $self->{socket} = $socket if $socket;
+ return $self->{socket};
+}
+
+=head2 disconnect
+
+=cut
+
+sub disconnect {
+ my $self = shift;
+ $self->reader->disconnect if $self->reader;
+}
+
+
+=head2 gather
+
+=cut
+
+sub gather {
+ my $self = shift;
+ $self->process( 0 );
+}
+
+# -------------------------------------------------
+
+=head2 tcp_connected
+
+=cut
+
+sub tcp_connected {
+ my $self = shift;
+ return $self->reader->tcp_connected if $self->reader;
+ return 0;
+}
+
+
+
+=head2 send
+
+=cut
+
+sub send {
+ my $self = shift;
+ my $msg = OpenSRF::Transport::SlimJabber::XMPPMessage->new(@_);
+ $self->reader->send($msg->to_xml);
+}
+
+=head2 initialize
+
+=cut
+
+sub initialize {
+
+ my $self = shift;
+
+ my $host = $self->params->{host};
+ my $port = $self->params->{port};
+ my $username = $self->params->{username};
+ my $resource = $self->params->{resource};
+ my $password = $self->params->{password};
+
+ my $jid = "$username\@$host/$resource";
+
+ my $conf = OpenSRF::Utils::Config->current;
+
+ my $tail = "_$$";
+ $tail = "" if !$conf->bootstrap->router_name and $username eq "router";
+ $resource = "$resource$tail";
+
+ my $socket = IO::Socket::INET->new(
+ PeerHost => $host,
+ PeerPort => $port,
+ Peer => $port,
+ Proto => 'tcp' );
+
+ throw OpenSRF::EX::Jabber("Could not open TCP socket to Jabber server: $!")
+ unless ( $socket and $socket->connected );
+
+ $self->socket($socket);
+ $self->reader(OpenSRF::Transport::SlimJabber::XMPPReader->new($socket));
+ $self->reader->connect($host, $username, $password, $resource);
+
+ throw OpenSRF::EX::Jabber("Could not authenticate with Jabber server: $!")
+ unless ( $self->reader->connected );
+
+ return $self;
+}
+
+
+=head2 construct
+
+=cut
+
+sub construct {
+ my( $class, $app ) = @_;
+ $class->peer_handle($class->new( $app )->initialize());
+}
+
+
+=head2 process
+
+=cut
+
+sub process {
+ my($self, $timeout) = @_;
+
+ $timeout ||= 0;
+ $timeout = int($timeout);
+
+ unless( $self->reader and $self->reader->connected ) {
+ throw OpenSRF::EX::JabberDisconnected
+ ("This JabberClient instance is no longer connected to the server ");
+ }
+
+ return $self->reader->wait_msg($timeout);
+}
+
+
+=head2 flush_socket
+
+Sets the socket to O_NONBLOCK, reads all of the data off of the
+socket, the restores the sockets flags. Returns 1 on success, 0 if
+the socket isn't connected.
+
+=cut
+
+sub flush_socket {
+ my $self = shift;
+ return $self->reader->flush_socket;
+}
+
+1;
+
+
--- /dev/null
+package OpenSRF::Transport::SlimJabber::Inbound;
+use strict;use warnings;
+use base qw/OpenSRF::Transport::SlimJabber::Client/;
+use OpenSRF::EX qw(:try);
+use OpenSRF::Utils::Logger qw(:level);
+use OpenSRF::Utils::SettingsClient;
+use OpenSRF::Utils::Config;
+use Time::HiRes qw/usleep/;
+use FreezeThaw qw/freeze/;
+
+my $logger = "OpenSRF::Utils::Logger";
+
+=head1 Description
+
+This is the jabber connection where all incoming client requests will be accepted.
+This connection takes the data, passes it off to the system then returns to take
+more data. Connection params are all taken from the config file and the values
+retreived are based on the $app name passed into new().
+
+This service should be loaded at system startup.
+
+=cut
+
+{
+ my $unix_sock;
+ sub unix_sock { return $unix_sock; }
+ my $instance;
+
+ sub new {
+ my( $class, $app ) = @_;
+ $class = ref( $class ) || $class;
+ if( ! $instance ) {
+
+ my $conf = OpenSRF::Utils::Config->current;
+ my $domain = $conf->bootstrap->domain;
+ $logger->error("use of <domains/> is deprecated") if $conf->bootstrap->domains;
+
+ my $username = $conf->bootstrap->username;
+ my $password = $conf->bootstrap->passwd;
+ my $port = $conf->bootstrap->port;
+ my $host = $domain;
+ my $resource = $app . '_listener_at_' . $conf->env->hostname;
+
+ my $router_name = $conf->bootstrap->router_name;
+ # no router, only one listener running..
+ if(!$router_name) {
+ $username = "router";
+ $resource = $app;
+ }
+
+ OpenSRF::Utils::Logger->transport("Inbound as $username, $password, $resource, $host, $port\n", INTERNAL );
+
+ my $self = __PACKAGE__->SUPER::new(
+ username => $username,
+ resource => $resource,
+ password => $password,
+ host => $host,
+ port => $port,
+ );
+
+ $self->{app} = $app;
+
+ my $client = OpenSRF::Utils::SettingsClient->new();
+ my $f = $client->config_value("dirs", "sock");
+ $unix_sock = join( "/", $f,
+ $client->config_value("apps", $app, "unix_config", "unix_sock" ));
+ bless( $self, $class );
+ $instance = $self;
+ }
+ return $instance;
+ }
+
+}
+
+sub DESTROY {
+ my $self = shift;
+ for my $router (@{$self->{routers}}) {
+ if($self->tcp_connected()) {
+ $logger->info("disconnecting from router $router");
+ $self->send( to => $router, body => "registering",
+ router_command => "unregister" , router_class => $self->{app} );
+ }
+ }
+}
+
+sub listen {
+ my $self = shift;
+
+ $self->{routers} = [];
+
+ try {
+
+ my $conf = OpenSRF::Utils::Config->current;
+ my $router_name = $conf->bootstrap->router_name;
+ my $routers = $conf->bootstrap->routers;
+ $logger->info("loading router info $routers");
+
+ for my $router (@$routers) {
+ if(ref $router) {
+ if( !$router->{services} || grep { $_ eq $self->{app} } @{$router->{services}->{service}} ) {
+ my $name = $router->{name};
+ my $domain = $router->{domain};
+ my $target = "$name\@$domain/router";
+ push(@{$self->{routers}}, $target);
+ $logger->info( $self->{app} . " connecting to router $target");
+ $self->send( to => $target, body => "registering", router_command => "register" , router_class => $self->{app} );
+ }
+ } else {
+ my $target = "$router_name\@$router/router";
+ push(@{$self->{routers}}, $target);
+ $logger->info( $self->{app} . " connecting to router $target");
+ $self->send( to => $target, body => "registering", router_command => "register" , router_class => $self->{app} );
+ }
+ }
+
+ } catch Error with {
+ $logger->transport( $self->{app} . ": No routers defined" , WARN );
+ # no routers defined
+ };
+
+
+
+
+ $logger->transport( $self->{app} . " going into listen loop", INFO );
+
+ while(1) {
+
+ my $sock = $self->unix_sock();
+ my $o;
+
+ $logger->debug("Inbound listener calling process()");
+
+ try {
+ $o = $self->process(-1);
+
+ if(!$o){
+ $logger->error(
+ "Inbound received no data from the Jabber socket in process()");
+ usleep(100000); # otherwise we loop and pound syslog logger with errors
+ }
+
+ } catch OpenSRF::EX::JabberDisconnected with {
+
+ $logger->error("Inbound process lost its ".
+ "jabber connection. Attempting to reconnect...");
+ $self->initialize;
+ $o = undef;
+ };
+
+
+ if($o) {
+ my $socket = IO::Socket::UNIX->new( Peer => $sock );
+ throw OpenSRF::EX::Socket(
+ "Unable to connect to UnixServer: socket-file: $sock \n :=> $! " )
+ unless ($socket->connected);
+ print $socket freeze($o);
+ $socket->close;
+ }
+ }
+
+ throw OpenSRF::EX::Socket( "How did we get here?!?!" );
+}
+
+1;
+
--- /dev/null
+package OpenSRF::Transport::SlimJabber::MessageWrapper;
+use strict; use warnings;
+use OpenSRF::Transport::SlimJabber::XMPPMessage;
+
+# ----------------------------------------------------------
+# Legacy wrapper for XMPPMessage
+# ----------------------------------------------------------
+
+sub new {
+ my $class = shift;
+ my $msg = shift;
+ return bless({msg => $msg}, ref($class) || $class);
+}
+
+sub msg {
+ my($self, $msg) = @_;
+ $self->{msg} = $msg if $msg;
+ return $self->{msg};
+}
+
+sub toString {
+ return $_[0]->msg->to_xml;
+}
+
+sub get_body {
+ return $_[0]->msg->body;
+}
+
+sub get_sess_id {
+ return $_[0]->msg->thread;
+}
+
+sub get_msg_type {
+ return $_[0]->msg->type;
+}
+
+sub get_remote_id {
+ return $_[0]->msg->from;
+}
+
+sub setType {
+ $_[0]->msg->type(shift());
+}
+
+sub setTo {
+ $_[0]->msg->to(shift());
+}
+
+sub setThread {
+ $_[0]->msg->thread(shift());
+}
+
+sub setBody {
+ $_[0]->msg->body(shift());
+}
+
+sub set_router_command {
+ $_[0]->msg->router_command(shift());
+}
+sub set_router_class {
+ $_[0]->msg->router_class(shift());
+}
+
+sub set_osrf_xid {
+ $_[0]->msg->osrf_xid(shift());
+}
+
+sub get_osrf_xid {
+ return $_[0]->msg->osrf_xid;
+}
+
+1;
--- /dev/null
+package OpenSRF::Transport::SlimJabber::PeerConnection;
+use strict;
+use base qw/OpenSRF::Transport::SlimJabber::Client/;
+use OpenSRF::Utils::Config;
+use OpenSRF::Utils::Logger qw(:level);
+use OpenSRF::EX qw/:try/;
+
+=head1 Description
+
+Represents a single connection to a remote peer. The
+Jabber values are loaded from the config file.
+
+Subclasses OpenSRF::Transport::SlimJabber::Client.
+
+=cut
+
+=head2 new()
+
+ new( $appname );
+
+ The $appname parameter tells this class how to find the correct
+ Jabber username, password, etc to connect to the server.
+
+=cut
+
+our %apps_hash;
+our $_singleton_connection;
+
+sub retrieve {
+ my( $class, $app ) = @_;
+ return $_singleton_connection;
+}
+
+
+sub new {
+ my( $class, $app ) = @_;
+
+ my $peer_con = $class->retrieve;
+ return $peer_con if ($peer_con and $peer_con->tcp_connected);
+
+ my $config = OpenSRF::Utils::Config->current;
+
+ if( ! $config ) {
+ throw OpenSRF::EX::Config( "No suitable config found for PeerConnection" );
+ }
+
+ my $conf = OpenSRF::Utils::Config->current;
+ my $domain = $conf->bootstrap->domain;
+ my $h = $conf->env->hostname;
+ OpenSRF::Utils::Logger->error("use of <domains/> is deprecated") if $conf->bootstrap->domains;
+
+ my $username = $conf->bootstrap->username;
+ my $password = $conf->bootstrap->passwd;
+ my $port = $conf->bootstrap->port;
+ my $resource = "${app}_drone_at_$h";
+ my $host = $domain; # XXX for now...
+
+ if( $app eq "client" ) { $resource = "client_at_$h"; }
+
+ OpenSRF::EX::Config->throw( "JPeer could not load all necesarry values from config" )
+ unless ( $username and $password and $resource and $host and $port );
+
+ OpenSRF::Utils::Logger->transport( "Built Peer with", INTERNAL );
+
+ my $self = __PACKAGE__->SUPER::new(
+ username => $username,
+ resource => $resource,
+ password => $password,
+ host => $host,
+ port => $port,
+ );
+
+ bless( $self, $class );
+
+ $self->app($app);
+
+ $_singleton_connection = $self;
+ $apps_hash{$app} = $self;
+
+ return $_singleton_connection;
+ return $apps_hash{$app};
+}
+
+sub process {
+ my $self = shift;
+ my $val = $self->SUPER::process(@_);
+ return 0 unless $val;
+ return OpenSRF::Transport->handler($self->app, $val);
+}
+
+sub app {
+ my $self = shift;
+ my $app = shift;
+ $self->{app} = $app if $app;
+ return $self->{app};
+}
+
+1;
+
--- /dev/null
+package OpenSRF::Transport::SlimJabber::XMPPMessage;
+use strict; use warnings;
+use OpenSRF::Utils::Logger qw/$logger/;
+use OpenSRF::EX qw/:try/;
+use strict; use warnings;
+use XML::LibXML;
+
+use constant JABBER_MESSAGE =>
+ "<message to='%s' from='%s' router_command='%s' router_class='%s' osrf_xid='%s'>".
+ "<thread>%s</thread><body>%s</body></message>";
+
+sub new {
+ my $class = shift;
+ my %args = @_;
+ my $self = bless({}, $class);
+
+ if($args{xml}) {
+ $self->parse_xml($args{xml});
+
+ } else {
+ $self->{to} = $args{to} || '';
+ $self->{from} = $args{from} || '';
+ $self->{thread} = $args{thread} || '';
+ $self->{body} = $args{body} || '';
+ $self->{osrf_xid} = $args{osrf_xid} || '';
+ $self->{router_command} = $args{router_command} || '';
+ $self->{router_class} = $args{router_class} || '';
+ }
+
+ return $self;
+}
+
+sub to {
+ my($self, $to) = @_;
+ $self->{to} = $to if defined $to;
+ return $self->{to};
+}
+sub from {
+ my($self, $from) = @_;
+ $self->{from} = $from if defined $from;
+ return $self->{from};
+}
+sub thread {
+ my($self, $thread) = @_;
+ $self->{thread} = $thread if defined $thread;
+ return $self->{thread};
+}
+sub body {
+ my($self, $body) = @_;
+ $self->{body} = $body if defined $body;
+ return $self->{body};
+}
+sub status {
+ my($self, $status) = @_;
+ $self->{status} = $status if defined $status;
+ return $self->{status};
+}
+sub type {
+ my($self, $type) = @_;
+ $self->{type} = $type if defined $type;
+ return $self->{type};
+}
+sub err_type {
+ my($self, $err_type) = @_;
+ $self->{err_type} = $err_type if defined $err_type;
+ return $self->{err_type};
+}
+sub err_code {
+ my($self, $err_code) = @_;
+ $self->{err_code} = $err_code if defined $err_code;
+ return $self->{err_code};
+}
+sub osrf_xid {
+ my($self, $osrf_xid) = @_;
+ $self->{osrf_xid} = $osrf_xid if defined $osrf_xid;
+ return $self->{osrf_xid};
+}
+sub router_command {
+ my($self, $router_command) = @_;
+ $self->{router_command} = $router_command if defined $router_command;
+ return $self->{router_command};
+}
+sub router_class {
+ my($self, $router_class) = @_;
+ $self->{router_class} = $router_class if defined $router_class;
+ return $self->{router_class};
+}
+
+
+sub to_xml {
+ my $self = shift;
+
+ my $body = $self->{body};
+ $body =~ s/&/&/sog;
+ $body =~ s/</</sog;
+ $body =~ s/>/>/sog;
+
+ return sprintf(
+ JABBER_MESSAGE,
+ $self->{to},
+ $self->{from},
+ $self->{router_command},
+ $self->{router_class},
+ $self->{osrf_xid},
+ $self->{thread},
+ $body
+ );
+}
+
+sub parse_xml {
+ my($self, $xml) = @_;
+ my($doc, $err);
+
+ try {
+ $doc = XML::LibXML->new->parse_string($xml);
+ } catch Error with {
+ my $err = shift;
+ $logger->error("Error parsing message xml: $xml --- $err");
+ };
+ throw $err if $err;
+
+ my $root = $doc->documentElement;
+
+ $self->{body} = $root->findnodes('/message/body').'';
+ $self->{thread} = $root->findnodes('/message/thread').'';
+ $self->{from} = $root->getAttribute('router_from');
+ $self->{from} = $root->getAttribute('from') unless $self->{from};
+ $self->{to} = $root->getAttribute('to');
+ $self->{type} = $root->getAttribute('type');
+ $self->{osrf_xid} = $root->getAttribute('osrf_xid');
+}
+
+
+1;
--- /dev/null
+package OpenSRF::Transport::SlimJabber::XMPPReader;
+use strict; use warnings;
+use XML::Parser;
+use Fcntl qw(F_GETFL F_SETFL O_NONBLOCK);
+use Time::HiRes qw/time/;
+use OpenSRF::Transport::SlimJabber::XMPPMessage;
+use OpenSRF::Utils::Logger qw/$logger/;
+
+# -----------------------------------------------------------
+# Connect, disconnect, and authentication messsage templates
+# -----------------------------------------------------------
+use constant JABBER_CONNECT =>
+ "<stream:stream to='%s' xmlns='jabber:client' xmlns:stream='http://etherx.jabber.org/streams'>";
+
+use constant JABBER_BASIC_AUTH =>
+ "<iq id='123' type='set'><query xmlns='jabber:iq:auth'>" .
+ "<username>%s</username><password>%s</password><resource>%s</resource></query></iq>";
+
+use constant JABBER_DISCONNECT => "</stream:stream>";
+
+
+# -----------------------------------------------------------
+# XMPP Stream states
+# -----------------------------------------------------------
+use constant DISCONNECTED => 1;
+use constant CONNECT_RECV => 2;
+use constant CONNECTED => 3;
+
+
+# -----------------------------------------------------------
+# XMPP Message states
+# -----------------------------------------------------------
+use constant IN_NOTHING => 1;
+use constant IN_BODY => 2;
+use constant IN_THREAD => 3;
+use constant IN_STATUS => 4;
+
+
+# -----------------------------------------------------------
+# Constructor, getter/setters
+# -----------------------------------------------------------
+sub new {
+ my $class = shift;
+ my $socket = shift;
+
+ my $self = bless({}, $class);
+
+ $self->{queue} = [];
+ $self->{stream_state} = DISCONNECTED;
+ $self->{xml_state} = IN_NOTHING;
+ $self->socket($socket);
+
+ my $p = new XML::Parser(Handlers => {
+ Start => \&start_element,
+ End => \&end_element,
+ Char => \&characters,
+ });
+
+ $self->parser($p->parse_start); # create a push parser
+ $self->parser->{_parent_} = $self;
+ $self->{message} = OpenSRF::Transport::SlimJabber::XMPPMessage->new;
+ return $self;
+}
+
+sub push_msg {
+ my($self, $msg) = @_;
+ push(@{$self->{queue}}, $msg) if $msg;
+}
+
+sub next_msg {
+ my $self = shift;
+ return shift @{$self->{queue}};
+}
+
+sub peek_msg {
+ my $self = shift;
+ return (@{$self->{queue}} > 0);
+}
+
+sub parser {
+ my($self, $parser) = @_;
+ $self->{parser} = $parser if $parser;
+ return $self->{parser};
+}
+
+sub socket {
+ my($self, $socket) = @_;
+ $self->{socket} = $socket if $socket;
+ return $self->{socket};
+}
+
+sub stream_state {
+ my($self, $stream_state) = @_;
+ $self->{stream_state} = $stream_state if $stream_state;
+ return $self->{stream_state};
+}
+
+sub xml_state {
+ my($self, $xml_state) = @_;
+ $self->{xml_state} = $xml_state if $xml_state;
+ return $self->{xml_state};
+}
+
+sub message {
+ my($self, $message) = @_;
+ $self->{message} = $message if $message;
+ return $self->{message};
+}
+
+
+# -----------------------------------------------------------
+# Stream and connection handling methods
+# -----------------------------------------------------------
+
+sub connect {
+ my($self, $domain, $username, $password, $resource) = @_;
+
+ $self->send(sprintf(JABBER_CONNECT, $domain));
+ $self->wait(10);
+
+ unless($self->{stream_state} == CONNECT_RECV) {
+ $logger->error("No initial XMPP response from server");
+ return 0;
+ }
+
+ $self->send(sprintf(JABBER_BASIC_AUTH, $username, $password, $resource));
+ $self->wait(10);
+
+ unless($self->connected) {
+ $logger->error('XMPP connect failed');
+ return 0;
+ }
+
+ return 1;
+}
+
+sub disconnect {
+ my $self = shift;
+ if($self->tcp_connected) {
+ $self->send(JABBER_DISCONNECT);
+ shutdown($self->socket, 2);
+ }
+ close($self->socket);
+}
+
+# -----------------------------------------------------------
+# returns true if this stream is connected to the server
+# -----------------------------------------------------------
+sub connected {
+ my $self = shift;
+ return ($self->tcp_connected and $self->{stream_state} == CONNECTED);
+}
+
+# -----------------------------------------------------------
+# returns true if the socket is connected
+# -----------------------------------------------------------
+sub tcp_connected {
+ my $self = shift;
+ return ($self->socket and $self->socket->connected);
+}
+
+# -----------------------------------------------------------
+# sends pre-formated XML
+# -----------------------------------------------------------
+sub send {
+ my($self, $xml) = @_;
+ $self->{socket}->print($xml);
+}
+
+# -----------------------------------------------------------
+# Puts a file handle into blocking mode
+# -----------------------------------------------------------
+sub set_block {
+ my $fh = shift;
+ my $flags = fcntl($fh, F_GETFL, 0);
+ $flags &= ~O_NONBLOCK;
+ fcntl($fh, F_SETFL, $flags);
+}
+
+
+# -----------------------------------------------------------
+# Puts a file handle into non-blocking mode
+# -----------------------------------------------------------
+sub set_nonblock {
+ my $fh = shift;
+ my $flags = fcntl($fh, F_GETFL, 0);
+ fcntl($fh, F_SETFL, $flags | O_NONBLOCK);
+}
+
+
+sub wait {
+ my($self, $timeout) = @_;
+
+ return $self->next_msg if $self->peek_msg;
+
+ $timeout ||= 0;
+ $timeout = undef if $timeout < 0;
+ my $socket = $self->{socket};
+
+ set_block($socket);
+
+ # build the select readset
+ my $infile = '';
+ vec($infile, $socket->fileno, 1) = 1;
+ return undef unless select($infile, undef, undef, $timeout);
+
+ # now slurp the data off the socket
+ my $buf;
+ my $read_size = 1024;
+ while(my $n = sysread($socket, $buf, $read_size)) {
+ $self->{parser}->parse_more($buf) if $buf;
+ if($n < $read_size or $self->peek_msg) {
+ set_block($socket);
+ last;
+ }
+ set_nonblock($socket);
+ }
+
+ return $self->next_msg;
+}
+
+# -----------------------------------------------------------
+# Waits up to timeout seconds for a fully-formed XMPP
+# message to arrive. If timeout is < 0, waits indefinitely
+# -----------------------------------------------------------
+sub wait_msg {
+ my($self, $timeout) = @_;
+ my $xml;
+
+ $timeout = 0 unless defined $timeout;
+
+ if($timeout < 0) {
+ while(1) {
+ return $xml if $xml = $self->wait($timeout);
+ }
+
+ } else {
+ while($timeout >= 0) {
+ my $start = time;
+ return $xml if $xml = $self->wait($timeout);
+ $timeout -= time - $start;
+ }
+ }
+
+ return undef;
+}
+
+
+# -----------------------------------------------------------
+# SAX Handlers
+# -----------------------------------------------------------
+
+
+sub start_element {
+ my($parser, $name, %attrs) = @_;
+ my $self = $parser->{_parent_};
+
+ if($name eq 'message') {
+
+ my $msg = $self->{message};
+ $msg->{to} = $attrs{'to'};
+ $msg->{from} = $attrs{router_from} if $attrs{router_from};
+ $msg->{from} = $attrs{from} unless $msg->{from};
+ $msg->{osrf_xid} = $attrs{'osrf_xid'};
+ $msg->{type} = $attrs{type};
+
+ } elsif($name eq 'body') {
+ $self->{xml_state} = IN_BODY;
+
+ } elsif($name eq 'thread') {
+ $self->{xml_state} = IN_THREAD;
+
+ } elsif($name eq 'stream:stream') {
+ $self->{stream_state} = CONNECT_RECV;
+
+ } elsif($name eq 'iq') {
+ if($attrs{type} and $attrs{type} eq 'result') {
+ $self->{stream_state} = CONNECTED;
+ }
+
+ } elsif($name eq 'status') {
+ $self->{xml_state } = IN_STATUS;
+
+ } elsif($name eq 'stream:error') {
+ $self->{stream_state} = DISCONNECTED;
+
+ } elsif($name eq 'error') {
+ $self->{message}->{err_type} = $attrs{'type'};
+ $self->{message}->{err_code} = $attrs{'code'};
+ $self->{stream_state} = DISCONNECTED;
+ }
+}
+
+sub characters {
+ my($parser, $chars) = @_;
+ my $self = $parser->{_parent_};
+ my $state = $self->{xml_state};
+
+ if($state == IN_BODY) {
+ $self->{message}->{body} .= $chars;
+
+ } elsif($state == IN_THREAD) {
+ $self->{message}->{thread} .= $chars;
+
+ } elsif($state == IN_STATUS) {
+ $self->{message}->{status} .= $chars;
+ }
+}
+
+sub end_element {
+ my($parser, $name) = @_;
+ my $self = $parser->{_parent_};
+ $self->{xml_state} = IN_NOTHING;
+
+ if($name eq 'message') {
+ $self->push_msg($self->{message});
+ $self->{message} = OpenSRF::Transport::SlimJabber::XMPPMessage->new;
+
+ } elsif($name eq 'stream:stream') {
+ $self->{stream_state} = DISCONNECTED;
+ }
+}
+
+sub flush_socket {
+ my $self = shift;
+ my $socket = $self->socket;
+ return 0 unless $socket and $socket->connected;
+
+ my $flags = fcntl($socket, F_GETFL, 0);
+ fcntl($socket, F_SETFL, $flags | O_NONBLOCK);
+
+ while( my $n = sysread( $socket, my $buf, 8192 ) ) {
+ $logger->debug("flush_socket dropped $n bytes of data");
+ $logger->error("flush_socket dropped data on disconnected socket: $buf")
+ unless($socket->connected);
+ }
+
+ fcntl($socket, F_SETFL, $flags);
+ return 0 unless $socket->connected;
+ return 1;
+}
+
+
+
+
+
+1;
+
+
+
+
+
--- /dev/null
+package OpenSRF::UnixServer;
+use strict; use warnings;
+use base qw/OpenSRF/;
+use OpenSRF::EX qw(:try);
+use OpenSRF::Utils::Logger qw(:level $logger);
+use OpenSRF::Transport::PeerHandle;
+use OpenSRF::Application;
+use OpenSRF::AppSession;
+use OpenSRF::DomainObject::oilsResponse qw/:status/;
+use OpenSRF::System;
+use OpenSRF::Utils::SettingsClient;
+use Time::HiRes qw(time);
+use OpenSRF::Utils::JSON;
+use vars qw/@ISA $app/;
+use Fcntl qw(F_GETFL F_SETFL O_NONBLOCK);
+use Carp;
+use FreezeThaw qw/thaw/;
+
+use IO::Socket::INET;
+use IO::Socket::UNIX;
+
+sub DESTROY { confess "Dying $$"; }
+
+=head1 What am I
+
+All inbound messages are passed on to the UnixServer for processing.
+We take the data, close the Unix socket, and pass the data on to our abstract
+'process()' method.
+
+Our purpose is to 'multiplex' a single TCP connection into multiple 'client' connections.
+So when you pass data down the Unix socket to us, we have been preforked and waiting
+to disperse new data among us.
+
+=cut
+
+sub app { return $app; }
+
+{
+
+ sub new {
+ my( $class, $app1 ) = @_;
+ if( ! $app1 ) {
+ throw OpenSRF::EX::InvalidArg( "UnixServer requires an app name to run" );
+ }
+ $app = $app1;
+ my $self = bless( {}, $class );
+# my $client = OpenSRF::Utils::SettingsClient->new();
+# if( $client->config_value("server_type") !~ /fork/i ||
+# OpenSRF::Utils::Config->current->bootstrap->settings_config ) {
+# warn "Calling hooks for non-prefork\n";
+# $self->configure_hook();
+# $self->child_init_hook();
+# }
+ return $self;
+ }
+
+}
+
+=head2 process_request()
+
+Takes the incoming data, closes the Unix socket and hands the data untouched
+to the abstract process() method. This method is implemented in our subclasses.
+
+=cut
+
+sub process_request {
+
+ my $self = shift;
+ my $data; my $d;
+ while( $d = <STDIN> ) { $data .= $d; }
+
+ my $orig = $0;
+ $0 = "$0*";
+
+ if( ! $data or ! defined( $data ) or $data eq "" ) {
+ close($self->{server}->{client});
+ $logger->debug("Unix child received empty data from socket", ERROR);
+ $0 = $orig;
+ return;
+ }
+
+
+ if( ! close( $self->{server}->{client} ) ) {
+ $logger->debug( "Error closing Unix socket: $!", ERROR );
+ }
+
+ my $app = $self->app();
+ $logger->transport( "UnixServer for $app received $data", INTERNAL );
+
+ # --------------------------------------------------------------
+ # Drop all data from the socket before coninuting to process
+ # --------------------------------------------------------------
+ my $ph = OpenSRF::Transport::PeerHandle->retrieve;
+ if(!$ph->flush_socket()) {
+ $logger->error("We received a request ".
+ "and we are no longer connected to the jabber network. ".
+ "We will go away and drop this request: $data");
+ exit;
+ }
+
+ ($data) = thaw($data);
+ my $app_session = OpenSRF::Transport->handler( $self->app(), $data );
+
+ if(!ref($app_session)) {
+ $logger->transport( "Did not receive AppSession from transport handler, returning...", WARN );
+ $0 = $orig;
+ return;
+ }
+
+ if($app_session->stateless and $app_session->state != $app_session->CONNECTED()){
+ $logger->debug("Exiting keepalive for stateless session / orig = $orig");
+ $app_session->kill_me;
+ $0 = $orig;
+ return;
+ }
+
+
+ my $client = OpenSRF::Utils::SettingsClient->new();
+ my $keepalive = $client->config_value("apps", $self->app(), "keepalive");
+
+ my $req_counter = 0;
+ while( $app_session and
+ $app_session->state and
+ $app_session->state != $app_session->DISCONNECTED() and
+ $app_session->find( $app_session->session_id ) ) {
+
+
+ my $before = time;
+ $logger->debug( "UnixServer calling queue_wait $keepalive", INTERNAL );
+ $app_session->queue_wait( $keepalive );
+ $logger->debug( "after queue wait $keepalive", INTERNAL );
+ my $after = time;
+
+ if( ($after - $before) >= $keepalive ) {
+
+ my $res = OpenSRF::DomainObject::oilsConnectStatus->new(
+ status => "Disconnected on timeout",
+ statusCode => STATUS_TIMEOUT);
+ $app_session->status($res);
+ $app_session->state( $app_session->DISCONNECTED() );
+ last;
+ }
+
+ }
+
+ my $x = 0;
+ while( $app_session && $app_session->queue_wait(0) ) {
+ $logger->debug( "Looping on zombies " . $x++ , DEBUG);
+ }
+
+ $logger->debug( "Timed out, disconnected, or authentication failed" );
+ $app_session->kill_me if ($app_session);
+
+ $0 = $orig;
+}
+
+
+sub serve {
+ my( $self ) = @_;
+
+ my $app = $self->app();
+ $logger->set_service($app);
+
+ $0 = "OpenSRF master [$app]";
+
+ my $client = OpenSRF::Utils::SettingsClient->new();
+ my @base = ('apps', $app, 'unix_config' );
+
+ my $min_servers = $client->config_value(@base, 'min_children');
+ my $max_servers = $client->config_value(@base, "max_children" );
+ my $min_spare = $client->config_value(@base, "min_spare_children" );
+ my $max_spare = $client->config_value(@base, "max_spare_children" );
+ my $max_requests = $client->config_value(@base, "max_requests" );
+ # fwiw, these file paths are (obviously) not portable
+ my $log_file = join("/", $client->config_value("dirs", "log"), $client->config_value(@base, "unix_log" ));
+ my $port = join("/", $client->config_value("dirs", "sock"), $client->config_value(@base, "unix_sock" ));
+ my $pid_file = join("/", $client->config_value("dirs", "pid"), $client->config_value(@base, "unix_pid" ));
+
+ $min_spare ||= $min_servers;
+ $max_spare ||= $max_servers;
+ $max_requests ||= 1000;
+
+ $logger->info("UnixServer: min=$min_servers, max=$max_servers, min_spare=$min_spare ".
+ "max_spare=$max_spare, max_req=$max_requests, log_file=$log_file, port=$port, pid_file=$pid_file");
+
+ $self->run(
+ min_servers => $min_servers,
+ max_servers => $max_servers,
+ min_spare_servers => $min_spare,
+ max_spare_servers => $max_spare,
+ max_requests => $max_requests,
+ log_file => $log_file,
+ port => $port,
+ proto => 'unix',
+ pid_file => $pid_file,
+ );
+
+}
+
+
+sub configure_hook {
+ my $self = shift;
+ my $app = $self->app;
+
+ # boot a client
+ OpenSRF::System->bootstrap_client( client_name => "system_client" );
+
+ $logger->debug( "Setting application implementation for $app", DEBUG );
+ my $client = OpenSRF::Utils::SettingsClient->new();
+ my $imp = $client->config_value("apps", $app, "implementation");
+ OpenSRF::Application::server_class($app);
+ OpenSRF::Application->application_implementation( $imp );
+ OpenSRF::Utils::JSON->register_class_hint( name => $imp, hint => $app, type => "hash" );
+ OpenSRF::Application->application_implementation->initialize()
+ if (OpenSRF::Application->application_implementation->can('initialize'));
+
+ if( $client->config_value("server_type") !~ /fork/i ) {
+ $self->child_init_hook();
+ }
+
+ my $con = OpenSRF::Transport::PeerHandle->retrieve;
+ if($con) {
+ $con->disconnect;
+ }
+
+ return OpenSRF::Application->application_implementation;
+}
+
+sub child_init_hook {
+
+ $0 =~ s/master/drone/g;
+
+ if ($ENV{OPENSRF_PROFILE}) {
+ my $file = $0;
+ $file =~ s/\W/_/go;
+ eval "use Devel::Profiler output_file => '/tmp/profiler_$file.out', buffer_size => 0;";
+ if ($@) {
+ $logger->debug("Could not load Devel::Profiler: $@",ERROR);
+ } else {
+ $0 .= ' [PROFILING]';
+ $logger->debug("Running under Devel::Profiler", INFO);
+ }
+ }
+
+ my $self = shift;
+
+# $logger->transport(
+# "Creating PeerHandle from UnixServer child_init_hook", INTERNAL );
+ OpenSRF::Transport::PeerHandle->construct( $self->app() );
+ $logger->transport( "PeerHandle Created from UnixServer child_init_hook", INTERNAL );
+
+ OpenSRF::Application->application_implementation->child_init
+ if (OpenSRF::Application->application_implementation->can('child_init'));
+
+ return OpenSRF::Transport::PeerHandle->retrieve;
+}
+
+sub child_finish_hook {
+ $logger->debug("attempting to call child exit handler...");
+ OpenSRF::Application->application_implementation->child_exit
+ if (OpenSRF::Application->application_implementation->can('child_exit'));
+}
+
+
+1;
+
--- /dev/null
+package OpenSRF::Utils;
+
+=head1 NAME
+
+OpenSRF::Utils
+
+=head1 DESCRIPTION
+
+This is a container package for methods that are useful to derived modules.
+It has no constructor, and is generally not useful by itself... but this
+is where most of the generic methods live.
+
+
+=head1 METHODS
+
+
+=cut
+
+use vars qw/@ISA $AUTOLOAD %EXPORT_TAGS @EXPORT_OK @EXPORT $VERSION/;
+push @ISA, 'Exporter';
+
+$VERSION = do { my @r=(q$Revision$=~/\d+/g); sprintf "%d."."%02d"x$#r,@r };
+
+use Time::Local;
+use Errno;
+use POSIX;
+use FileHandle;
+#use Cache::FileCache;
+#use Storable qw(dclone);
+use Digest::MD5 qw(md5 md5_hex md5_base64);
+use Exporter;
+use DateTime;
+use DateTime::Format::ISO8601;
+use DateTime::TimeZone;
+
+our $date_parser = DateTime::Format::ISO8601->new;
+
+# This turns errors into warnings, so daemons don't die.
+#$Storable::forgive_me = 1;
+
+%EXPORT_TAGS = (
+ common => [qw(interval_to_seconds seconds_to_interval sendmail tree_filter)],
+ daemon => [qw(safe_fork set_psname daemonize)],
+ datetime => [qw(clense_ISO8601 gmtime_ISO8601 interval_to_seconds seconds_to_interval)],
+);
+
+Exporter::export_ok_tags('common','daemon','datetime'); # add aa, cc and dd to @EXPORT_OK
+
+sub AUTOLOAD {
+ my $self = shift;
+ my $type = ref($self) or return undef;
+
+ my $name = $AUTOLOAD;
+ $name =~ s/.*://; # strip fully-qualified portion
+
+ if (defined($_[0])) {
+ return $self->{$name} = shift;
+ }
+ return $self->{$name};
+}
+
+
+sub _sub_builder {
+ my $self = shift;
+ my $class = ref($self) || $self;
+ my $part = shift;
+ unless ($class->can($part)) {
+ *{$class.'::'.$part} =
+ sub {
+ my $self = shift;
+ my $new_val = shift;
+ if ($new_val) {
+ $$self{$part} = $new_val;
+ }
+ return $$self{$part};
+ };
+ }
+}
+
+sub tree_filter {
+ my $tree = shift;
+ my $field = shift;
+ my $filter = shift;
+
+ my @things = $filter->($tree);
+ for my $v ( @{$tree->$field} ){
+ push @things, $filter->($v);
+ push @things, tree_filter($v, $field, $filter);
+ }
+ return @things
+}
+
+#sub standalone_ipc_cache {
+# my $self = shift;
+# my $class = ref($self) || $self;
+# my $uniquifier = shift || return undef;
+# my $expires = shift || 3600;
+
+# return new Cache::FileCache ( { namespace => $class.'::'.$uniquifier, default_expires_in => $expires } );
+#}
+
+sub sendmail {
+ my $self = shift;
+ my $message = shift || $self;
+
+ open SM, '|/usr/sbin/sendmail -U -t' or return 0;
+ print SM $message;
+ close SM or return 0;
+ return 1;
+}
+
+sub __strip_comments {
+ my $self = shift;
+ my $config_file = shift;
+ my ($line, @done);
+ while (<$config_file>) {
+ s/^\s*(.*)\s*$/$1/o if (lc($$self{keep_space}) ne 'true');
+ /^(.*)$/o;
+ $line .= $1;
+ # keep new lines if keep_space is true
+ if ($line =~ /^$/o && (lc($$self{keep_space}) ne 'true')) {
+ $line = '';
+ next;
+ }
+ if (/^([^<]+)\s*<<\s*(\w+)\s*$/o) {
+ $line = "$1 = ";
+ my $breaker = $2;
+ while (<$config_file>) {
+ chomp;
+ last if (/^$breaker/);
+ $line .= $_;
+ }
+ }
+
+ if ($line =~ /^#/ && $line !~ /^#\s*include\s+/o) {
+ $line = '';
+ next;
+ }
+ if ($line =~ /\\$/o) {
+ chomp $line;
+ $line =~ s/^\s*(.*)\s*\\$/$1/o;
+ next;
+ }
+ push @done, $line;
+ $line = '';
+ }
+ return @done;
+}
+
+
+=head2 $thing->encrypt(@stuff)
+
+Returns a one way hash (MD5) of the values appended together.
+
+=cut
+
+sub encrypt {
+ my $self = shift;
+ return md5_hex(join('',@_));
+}
+
+=head2 $utils_obj->es_time('field') OR noo_es_time($timestamp)
+
+Returns the epoch-second style timestamp for the value stored in
+$utils_obj->{field}. Returns B<0> for an empty or invalid date stamp, and
+assumes a PostgreSQL style datestamp to be supplied.
+
+=cut
+
+sub es_time {
+ my $self = shift;
+ my $part = shift;
+ my $es_part = $part.'_ES';
+ return $$self{$es_part} if (exists($$self{$es_part}) && defined($$self{$es_part}) && $$self{$es_part});
+ if (!$$self{$part} or $$self{$part} !~ /\d+/) {
+ return 0;
+
+ }
+ my @tm = reverse($$self{$part} =~ /([\d\.]+)/og);
+ if ($tm[5] > 0) {
+ $tm[5] -= 1;
+ }
+
+ return $$self{$es_part} = noo_es_time($$self{$part});
+}
+
+=head2 noo_es_time($timestamp) (non-OO es_time)
+
+Returns the epoch-second style timestamp for the B<$timestamp> passed
+in. Returns B<0> for an empty or invalid date stamp, and
+assumes a PostgreSQL style datestamp to be supplied.
+
+=cut
+
+sub noo_es_time {
+ my $timestamp = shift;
+
+ my @tm = reverse($timestamp =~ /([\d\.]+)/og);
+ if ($tm[5] > 0) {
+ $tm[5] -= 1;
+ }
+ return timelocal(int($tm[1]), int($tm[2]), int($tm[3]), int($tm[4]) || 1, int($tm[5]), int($tm[6]) || 2002 );
+}
+
+
+=head2 $thing->interval_to_seconds('interval') OR interval_to_seconds('interval')
+
+=head2 $thing->seconds_to_interval($seconds) OR seconds_to_interval($seconds)
+
+Returns the number of seconds for any interval passed, or the interval for the seconds.
+This is the generic version of B<interval> listed below.
+
+The interval must match the regex I</\s*\+?\s*(\d+)\s*(\w{1})\w*\s*/g>, for example
+B<2 weeks, 3 d and 1hour + 17 Months> or
+B<1 year, 5 Months, 2 weeks, 3 days and 1 hour of seconds> meaning 46148400 seconds.
+
+ my $expire_time = time() + $thing->interval_to_seconds('17h 9m');
+
+The time size indicator may be one of
+
+=over 2
+
+=item s[econd[s]]
+
+for seconds
+
+=item m[inute[s]]
+
+for minutes
+
+=item h[our[s]]
+
+for hours
+
+=item d[ay[s]]
+
+for days
+
+=item w[eek[s]]
+
+for weeks
+
+=item M[onth[s]]
+
+for months (really (365 * 1d)/12 ... that may get smarter, though)
+
+=item y[ear[s]]
+
+for years (this is 365 * 1d)
+
+=back
+
+=cut
+sub interval_to_seconds {
+ my $self = shift;
+ my $interval = shift || $self;
+
+ $interval =~ s/and/,/g;
+ $interval =~ s/,/ /g;
+
+ my $amount = 0;
+ while ($interval =~ /\s*\+?\s*(\d+)\s*(\w+)\s*/g) {
+ my ($count, $type) = ($1, $2);
+ $amount += $count if ($type eq 's');
+ $amount += 60 * $count if ($type =~ /^m(?!o)/oi);
+ $amount += 60 * 60 * $count if ($type =~ /^h/);
+ $amount += 60 * 60 * 24 * $count if ($type =~ /^d/oi);
+ $amount += 60 * 60 * 24 * 7 * $count if ($2 =~ /^w/oi);
+ $amount += ((60 * 60 * 24 * 365)/12) * $count if ($type =~ /^mo/io);
+ $amount += 60 * 60 * 24 * 365 * $count if ($type =~ /^y/oi);
+ }
+ return $amount;
+}
+
+sub seconds_to_interval {
+ my $self = shift;
+ my $interval = shift || $self;
+
+ my $limit = shift || 's';
+ $limit =~ s/^(.)/$1/o;
+
+ my ($y,$ym,$M,$Mm,$w,$wm,$d,$dm,$h,$hm,$m,$mm,$s,$string);
+ my ($year, $month, $week, $day, $hour, $minute, $second) =
+ ('year','Month','week','day', 'hour', 'minute', 'second');
+
+ if ($y = int($interval / (60 * 60 * 24 * 365))) {
+ $string = "$y $year". ($y > 1 ? 's' : '');
+ $ym = $interval % (60 * 60 * 24 * 365);
+ } else {
+ $ym = $interval;
+ }
+ return $string if ($limit eq 'y');
+
+ if ($M = int($ym / ((60 * 60 * 24 * 365)/12))) {
+ $string .= ($string ? ', ':'')."$M $month". ($M > 1 ? 's' : '');
+ $Mm = $ym % ((60 * 60 * 24 * 365)/12);
+ } else {
+ $Mm = $ym;
+ }
+ return $string if ($limit eq 'M');
+
+ if ($w = int($Mm / 604800)) {
+ $string .= ($string ? ', ':'')."$w $week". ($w > 1 ? 's' : '');
+ $wm = $Mm % 604800;
+ } else {
+ $wm = $Mm;
+ }
+ return $string if ($limit eq 'w');
+
+ if ($d = int($wm / 86400)) {
+ $string .= ($string ? ', ':'')."$d $day". ($d > 1 ? 's' : '');
+ $dm = $wm % 86400;
+ } else {
+ $dm = $wm;
+ }
+ return $string if ($limit eq 'd');
+
+ if ($h = int($dm / 3600)) {
+ $string .= ($string ? ', ' : '')."$h $hour". ($h > 1 ? 's' : '');
+ $hm = $dm % 3600;
+ } else {
+ $hm = $dm;
+ }
+ return $string if ($limit eq 'h');
+
+ if ($m = int($hm / 60)) {
+ $string .= ($string ? ', ':'')."$m $minute". ($m > 1 ? 's' : '');
+ $mm = $hm % 60;
+ } else {
+ $mm = $hm;
+ }
+ return $string if ($limit eq 'm');
+
+ if ($s = int($mm)) {
+ $string .= ($string ? ', ':'')."$s $second". ($s > 1 ? 's' : '');
+ } else {
+ $string = "0s" unless ($string);
+ }
+ return $string;
+}
+
+sub full {
+ my $self = shift;
+ $$self{empty} = 0;
+}
+
+=head2 $utils_obj->set_psname('string') OR set_psname('string')
+
+Sets the name of this process in a B<ps> listing to B<string>.
+
+
+=cut
+
+sub set_psname {
+ my $self = shift;
+ my $PS_NAME = shift || $self;
+ $0 = $PS_NAME if ($PS_NAME);
+}
+
+sub gmtime_ISO8601 {
+ my $self = shift;
+ my @date = gmtime;
+
+ my $y = $date[5] + 1900;
+ my $M = $date[4] + 1;
+ my $d = $date[3];
+ my $h = $date[2];
+ my $m = $date[1];
+ my $s = $date[0];
+
+ return sprintf('%d-%0.2d-%0.2dT%0.2d:%0.2d:%0.2d+00:00', $y, $M, $d, $h, $m, $s);
+}
+
+sub clense_ISO8601 {
+ my $self = shift;
+ my $date = shift || $self;
+ if ($date =~ /^\s*(\d{4})-?(\d{2})-?(\d{2})/o) {
+ my $new_date = "$1-$2-$3";
+
+ if ($date =~/(\d{2}):(\d{2}):(\d{2})/o) {
+ $new_date .= "T$1:$2:$3";
+
+ my $z;
+ if ($date =~ /([-+]{1})([0-9]{1,2})(?::?([0-9]{1,2}))*\s*$/o) {
+ $z = sprintf('%s%0.2d%0.2d',$1,$2,$3)
+ } else {
+ $z = DateTime::TimeZone::offset_as_string(
+ DateTime::TimeZone
+ ->new( name => 'local' )
+ ->offset_for_datetime(
+ $date_parser->parse_datetime($new_date)
+ )
+ );
+ }
+
+ if (length($z) > 3 && index($z, ':') == -1) {
+ substr($z,3,0) = ':';
+ substr($z,6,0) = ':' if (length($z) > 6);
+ }
+
+ $new_date .= $z;
+ } else {
+ $new_date .= "T00:00:00";
+ }
+
+ return $new_date;
+ }
+ return $date;
+}
+
+=head2 $utils_obj->daemonize('ps_name') OR daemonize('ps_name')
+
+Turns the current process into a daemon. B<ps_name> is optional, and is used
+as the argument to I<< set_psname() >> if passed.
+
+
+=cut
+
+sub daemonize {
+ my $self = shift;
+ my $PS_NAME = shift || $self;
+ my $pid;
+ if ($pid = safe_fork($self)) {
+ exit 0;
+ } elsif (defined($pid)) {
+ set_psname($PS_NAME);
+ chdir '/';
+ setsid;
+ return $$;
+ }
+}
+
+=head2 $utils_obj->safe_fork('ps_name') OR safe_fork('ps_name');
+
+Forks the current process in a retry loop. B<ps_name> is optional, and is used
+as the argument to I<< set_psname() >> if passed.
+
+
+=cut
+
+sub safe_fork {
+ my $self = shift;
+ my $pid;
+
+FORK:
+ {
+ if (defined($pid = fork())) {
+ srand(time ^ ($$ + ($$ << 15))) unless ($pid);
+ return $pid;
+ } elsif ($! == EAGAIN) {
+ $self->error("Can't fork()! $!, taking 5 and trying again.") if (ref $self);
+ sleep 5;
+ redo FORK;
+ } else {
+ $self->error("Can't fork()! $!") if ($! && ref($self));
+ exit $!;
+ }
+ }
+}
+
+#------------------------------------------------------------------------------------------------------------------------------------
+
+
+1;
--- /dev/null
+package OpenSRF::Utils::Cache;
+use strict; use warnings;
+use base qw/OpenSRF/;
+use Cache::Memcached;
+use OpenSRF::Utils::Logger qw/:level/;
+use OpenSRF::Utils::Config;
+use OpenSRF::Utils::SettingsClient;
+use OpenSRF::EX qw(:try);
+use OpenSRF::Utils::JSON;
+
+my $log = 'OpenSRF::Utils::Logger';
+
+=head1 NAME
+
+OpenSRF::Utils::Cache
+
+=head1 SYNOPSIS
+
+This class just subclasses Cache::Memcached.
+see Cache::Memcached for more options.
+
+The value passed to the call to current is the cache type
+you wish to access. The below example sets/gets data
+from the 'user' cache.
+
+my $cache = OpenSRF::Utils::Cache->current("user");
+$cache->set( "key1", "value1" [, $expire_secs ] );
+my $val = $cache->get( "key1" );
+
+
+=cut
+
+sub DESTROY {}
+
+my %caches;
+
+# ------------------------------------------------------
+# Persist methods and method names
+# ------------------------------------------------------
+my $persist_add_slot;
+my $persist_push_stack;
+my $persist_peek_stack;
+my $persist_destroy_slot;
+my $persist_slot_get_expire;
+my $persist_slot_find;
+
+my $max_persist_time;
+my $persist_add_slot_name = "opensrf.persist.slot.create_expirable";
+my $persist_push_stack_name = "opensrf.persist.stack.push";
+my $persist_peek_stack_name = "opensrf.persist.stack.peek";
+my $persist_destroy_slot_name = "opensrf.persist.slot.destroy";
+my $persist_slot_get_expire_name = "opensrf.persist.slot.get_expire";
+my $persist_slot_find_name = "opensrf.persist.slot.find";;
+
+# ------------------------------------------------------
+
+=head1 METHODS
+
+=head2 current
+
+Return a named cache if it exists
+
+=cut
+
+sub current {
+ my ( $class, $c_type ) = @_;
+ return undef unless $c_type;
+ return $caches{$c_type} if exists $caches{$c_type};
+ return $caches{$c_type} = $class->new( $c_type );
+}
+
+
+=head2 new
+
+Create a new named memcache object.
+
+=cut
+
+sub new {
+
+ my( $class, $cache_type, $persist ) = @_;
+ $cache_type ||= 'global';
+ $class = ref( $class ) || $class;
+
+ return $caches{$cache_type} if (defined $caches{$cache_type});
+
+ my $conf = OpenSRF::Utils::SettingsClient->new;
+ my $servers = $conf->config_value( cache => $cache_type => servers => 'server' );
+ $max_persist_time = $conf->config_value( cache => $cache_type => 'max_cache_time' );
+
+ $servers = [ $servers ] if(!ref($servers))
+
+ my $self = {};
+ $self->{persist} = $persist || 0;
+ $self->{memcache} = Cache::Memcached->new( { servers => $servers } );
+ if(!$self->{memcache}) {
+ throw OpenSRF::EX::PANIC ("Unable to create a new memcache object for $cache_type");
+ }
+
+ bless($self, $class);
+ $caches{$cache_type} = $self;
+ return $self;
+}
+
+
+=head2 put_cache
+
+=cut
+
+sub put_cache {
+ my($self, $key, $value, $expiretime ) = @_;
+ return undef unless( defined $key and defined $value );
+
+ $value = OpenSRF::Utils::JSON->perl2JSON($value);
+
+ if($self->{persist}){ _load_methods(); }
+
+ $expiretime ||= $max_persist_time;
+
+ unless( $self->{memcache}->set( $key, $value, $expiretime ) ) {
+ $log->error("Unable to store $key => [".length($value)." bytes] in memcached server" );
+ return undef;
+ }
+
+ $log->debug("Stored $key => $value in memcached server", INTERNAL);
+
+ if($self->{"persist"}) {
+
+ my ($slot) = $persist_add_slot->run("_CACHEVAL_$key", $expiretime . "s");
+
+ if(!$slot) {
+ # slot may already exist
+ ($slot) = $persist_slot_find->run("_CACHEVAL_$key");
+ if(!defined($slot)) {
+ throw OpenSRF::EX::ERROR ("Unable to create cache slot $key in persist server" );
+ } else {
+ #XXX destroy the slot and rebuild it to prevent DOS
+ }
+ }
+
+ ($slot) = $persist_push_stack->run("_CACHEVAL_$key", $value);
+
+ if(!$slot) {
+ throw OpenSRF::EX::ERROR ("Unable to push data onto stack in persist slot _CACHEVAL_$key" );
+ }
+ }
+
+ return $key;
+}
+
+
+=head2 delete_cache
+
+=cut
+
+sub delete_cache {
+ my( $self, $key ) = @_;
+ if(!$key) { return undef; }
+ if($self->{persist}){ _load_methods(); }
+ $self->{memcache}->delete($key);
+ if( $self->{persist} ) {
+ $persist_destroy_slot->run("_CACHEVAL_$key");
+ }
+ return $key;
+}
+
+
+=head2 get_cache
+
+=cut
+
+sub get_cache {
+ my($self, $key ) = @_;
+
+ my $val = $self->{memcache}->get( $key );
+ return OpenSRF::Utils::JSON->JSON2perl($val) if defined($val);
+
+ if($self->{persist}){ _load_methods(); }
+
+ # if not in memcache but we are persisting, the put it into memcache
+ if( $self->{"persist"} ) {
+ $val = $persist_peek_stack->( "_CACHEVAL_$key" );
+ if(defined($val)) {
+ my ($expire) = $persist_slot_get_expire->run("_CACHEVAL_$key");
+ if($expire) {
+ $self->{memcache}->set( $key, $val, $expire);
+ } else {
+ $self->{memcache}->set( $key, $val, $max_persist_time);
+ }
+ return OpenSRF::Utils::JSON->JSON2perl($val);
+ }
+ }
+ return undef;
+}
+
+
+=head2 _load_methods
+
+=cut
+
+sub _load_methods {
+
+ if(!$persist_add_slot) {
+ $persist_add_slot =
+ OpenSRF::Application->method_lookup($persist_add_slot_name);
+ if(!ref($persist_add_slot)) {
+ throw OpenSRF::EX::PANIC ("Unable to retrieve method $persist_add_slot_name");
+ }
+ }
+
+ if(!$persist_push_stack) {
+ $persist_push_stack =
+ OpenSRF::Application->method_lookup($persist_push_stack_name);
+ if(!ref($persist_push_stack)) {
+ throw OpenSRF::EX::PANIC ("Unable to retrieve method $persist_push_stack_name");
+ }
+ }
+
+ if(!$persist_peek_stack) {
+ $persist_peek_stack =
+ OpenSRF::Application->method_lookup($persist_peek_stack_name);
+ if(!ref($persist_peek_stack)) {
+ throw OpenSRF::EX::PANIC ("Unable to retrieve method $persist_peek_stack_name");
+ }
+ }
+
+ if(!$persist_destroy_slot) {
+ $persist_destroy_slot =
+ OpenSRF::Application->method_lookup($persist_destroy_slot_name);
+ if(!ref($persist_destroy_slot)) {
+ throw OpenSRF::EX::PANIC ("Unable to retrieve method $persist_destroy_slot_name");
+ }
+ }
+ if(!$persist_slot_get_expire) {
+ $persist_slot_get_expire =
+ OpenSRF::Application->method_lookup($persist_slot_get_expire_name);
+ if(!ref($persist_slot_get_expire)) {
+ throw OpenSRF::EX::PANIC ("Unable to retrieve method $persist_slot_get_expire_name");
+ }
+ }
+ if(!$persist_slot_find) {
+ $persist_slot_find =
+ OpenSRF::Application->method_lookup($persist_slot_find_name);
+ if(!ref($persist_slot_find)) {
+ throw OpenSRF::EX::PANIC ("Unable to retrieve method $persist_slot_find_name");
+ }
+ }
+}
+
+
+
+
+
+
+
+1;
+
--- /dev/null
+package OpenSRF::Utils::Config::Section;
+
+no strict 'refs';
+
+use vars qw/@ISA $AUTOLOAD $VERSION/;
+push @ISA, qw/OpenSRF::Utils/;
+
+use OpenSRF::Utils (':common');
+use Net::Domain qw/hostfqdn/;
+
+$VERSION = do { my @r=(q$Revision$=~/\d+/g); sprintf "%d."."%02d"x$#r,@r };
+
+my %SECTIONCACHE;
+my %SUBSECTION_FIXUP;
+
+#use overload '""' => \&OpenSRF::Utils::Config::dump_ini;
+
+sub SECTION {
+ my $sec = shift;
+ return $sec->__id(@_);
+}
+
+sub new {
+ my $self = shift;
+ my $class = ref($self) || $self;
+
+ $self = bless {}, $class;
+
+ $self->_sub_builder('__id');
+ # Hard-code this to match old bootstrap.conf section name
+ $self->__id('bootstrap');
+
+ my $bootstrap = shift;
+
+ foreach my $key (sort keys %$bootstrap) {
+ $self->_sub_builder($key);
+ $self->$key($bootstrap->{$key});
+ }
+
+ return $self;
+}
+
+package OpenSRF::Utils::Config;
+
+use vars qw/@ISA $AUTOLOAD $VERSION $OpenSRF::Utils::ConfigCache/;
+push @ISA, qw/OpenSRF::Utils/;
+
+use FileHandle;
+use XML::LibXML;
+use OpenSRF::Utils (':common');
+use OpenSRF::Utils::Logger;
+use Net::Domain qw/hostfqdn/;
+
+#use overload '""' => \&OpenSRF::Utils::Config::dump_ini;
+
+sub import {
+ my $class = shift;
+ my $config_file = shift;
+
+ return unless $config_file;
+
+ $class->load( config_file => $config_file);
+}
+
+sub dump_ini {
+ no warnings;
+ my $self = shift;
+ my $string;
+ my $included = 0;
+ if ($self->isa('OpenSRF::Utils::Config')) {
+ if (UNIVERSAL::isa(scalar(caller()), 'OpenSRF::Utils::Config' )) {
+ $included = 1;
+ } else {
+ $string = "# Main File: " . $self->FILE . "\n\n" . $string;
+ }
+ }
+ for my $section ( ('__id', grep { $_ ne '__id' } sort keys %$self) ) {
+ next if ($section eq 'env' && $self->isa('OpenSRF::Utils::Config'));
+ if ($section eq '__id') {
+ $string .= '['.$self->SECTION."]\n" if ($self->isa('OpenSRF::Utils::Config::Section'));
+ } elsif (ref($self->$section)) {
+ if (ref($self->$section) =~ /ARRAY/o) {
+ $string .= "list:$section = ". join(', ', @{$self->$section}) . "\n";
+ } elsif (UNIVERSAL::isa($self->$section,'OpenSRF::Utils::Config::Section')) {
+ if ($self->isa('OpenSRF::Utils::Config::Section')) {
+ $string .= "subsection:$section = " . $self->$section->SECTION . "\n";
+ next;
+ } else {
+ next if ($self->$section->{__sub} && !$included);
+ $string .= $self->$section . "\n";
+ }
+ } elsif (UNIVERSAL::isa($self->$section,'OpenSRF::Utils::Config')) {
+ $string .= $self->$section . "\n";
+ }
+ } else {
+ next if $section eq '__sub';
+ $string .= "$section = " . $self->$section . "\n";
+ }
+ }
+ if ($included) {
+ $string =~ s/^/## /gm;
+ $string = "# Subfile: " . $self->FILE . "\n#" . '-'x79 . "\n".'#include "'.$self->FILE."\"\n". $string;
+ }
+
+ return $string;
+}
+
+=head1 NAME
+
+OpenSRF::Utils::Config
+
+
+=head1 SYNOPSIS
+
+ use OpenSRF::Utils::Config;
+
+ my $config_obj = OpenSRF::Utils::Config->load( config_file => '/config/file.cnf' );
+
+ my $attrs_href = $config_obj->bootstrap();
+
+ $config_obj->bootstrap->loglevel(0);
+
+ open FH, '>'.$config_obj->FILE() . '.new';
+ print FH $config_obj;
+ close FH;
+
+=head1 DESCRIPTION
+
+This module is mainly used by other OpenSRF modules to load an OpenSRF
+configuration file. OpenSRF configuration files are XML files that
+contain a C<< <config> >> root element and an C<< <opensrf> >> child
+element (in XPath notation, C</config/opensrf/>). Each child element
+is converted into a hash key=>value pair. Elements that contain other
+XML elements are pushed into arrays and added as an array reference to
+the hash. Scalar values have whitespace trimmed from the left and
+right sides.
+
+Child elements of C<< <config> >> other than C<< <opensrf> >> are
+currently ignored by this module.
+
+=head1 EXAMPLE
+
+Given an OpenSRF configuration file named F<opensrf_core.xml> with the
+following content:
+
+ <?xml version='1.0'?>
+ <config>
+ <opensrf>
+ <router_name>router</router_name>
+
+ <routers>
+ <router>localhost</router>
+ <router>otherhost</router>
+ </routers>
+
+ <logfile>/var/log/osrfsys.log</logfile>
+ </opensrf>
+ </config>
+
+... calling C<< OpenSRF::Utils::Config->load(config_file =>
+'opensrf_core.xml') >> will create a hash with the following
+structure:
+
+ {
+ router_name => 'router',
+ routers => ['localhost', 'otherhost'],
+ logfile => '/var/log/osrfsys.log'
+ }
+
+You can retrieve any of these values by name from the bootstrap
+section of C<$config_obj>; for example:
+
+ $config_obj->bootstrap->router_name
+
+=head1 NOTES
+
+For compatibility with a previous version of OpenSRF configuration
+files, the F</config/opensrf/> section has a hardcoded name of
+B<bootstrap>. However, future iterations of this module may extend the
+ability of the module to parse the entire OpenSRF configuration file
+and provide sections named after the sibling elements of
+C</config/opensrf>.
+
+Hashrefs of sections can be returned by calling a method of the object
+of the same name as the section. They can be set by passing a hashref
+back to the same method. Sections will B<NOT> be autovivicated,
+though.
+
+
+=head1 METHODS
+
+
+=cut
+
+
+$VERSION = do { my @r=(q$Revision$=~/\d+/g); sprintf "%d."."%02d"x$#r,@r };
+
+
+=head2 OpenSRF::Utils::Config->load( config_file => '/some/config/file.cnf' )
+
+Returns a OpenSRF::Utils::Config object representing the config file
+that was loaded. The most recently loaded config file (hopefully the
+only one per app) is stored at $OpenSRF::Utils::ConfigCache. Use
+OpenSRF::Utils::Config::current() to get at it.
+
+=cut
+
+sub load {
+ my $pkg = shift;
+ $pkg = ref($pkg) || $pkg;
+
+ my %args = @_;
+
+ (my $new_pkg = $args{config_file}) =~ s/\W+/_/g;
+ $new_pkg .= "::$pkg";
+ $new_section_pkg .= "${new_pkg}::Section";
+
+ { eval <<" PERL";
+
+ package $new_pkg;
+ use base $pkg;
+ sub section_pkg { return '$new_section_pkg'; }
+
+ package $new_section_pkg;
+ use base "${pkg}::Section";
+
+ PERL
+ }
+
+ return $new_pkg->_load( %args );
+}
+
+sub _load {
+ my $pkg = shift;
+ $pkg = ref($pkg) || $pkg;
+ my $self = {@_};
+ bless $self, $pkg;
+
+ no warnings;
+ if ((exists $$self{config_file} and OpenSRF::Utils::Config->current) and (OpenSRF::Utils::Config->current->FILE eq $$self{config_file}) and (!$self->{force})) {
+ delete $$self{force};
+ return OpenSRF::Utils::Config->current();
+ }
+
+ $self->_sub_builder('__id');
+ $self->FILE($$self{config_file});
+ delete $$self{config_file};
+ return undef unless ($self->FILE);
+
+ $self->load_config();
+ $self->load_env();
+ $self->mangle_dirs();
+ $self->mangle_logs();
+
+ $OpenSRF::Utils::ConfigCache = $self unless $self->nocache;
+ delete $$self{nocache};
+ delete $$self{force};
+ return $self;
+}
+
+sub sections {
+ my $self = shift;
+ my %filters = @_;
+
+ my @parts = (grep { UNIVERSAL::isa($_,'OpenSRF::Utils::Config::Section') } values %$self);
+ if (keys %filters) {
+ my $must_match = scalar(keys %filters);
+ my @ok_parts;
+ foreach my $part (@parts) {
+ my $part_count = 0;
+ for my $fkey (keys %filters) {
+ $part_count++ if ($part->$key eq $filters{$key});
+ }
+ push @ok_parts, $part if ($part_count == $must_match);
+ }
+ return @ok_parts;
+ }
+ return @parts;
+}
+
+sub current {
+ return $OpenSRF::Utils::ConfigCache;
+}
+
+sub FILE {
+ return shift()->__id(@_);
+}
+
+sub load_env {
+ my $self = shift;
+ my $host = $ENV{'OSRF_HOSTNAME'} || hostfqdn();
+ chomp $host;
+ $$self{env} = $self->section_pkg->new;
+ $$self{env}{hostname} = $host;
+}
+
+sub mangle_logs {
+ my $self = shift;
+ return unless ($self->logs && $self->dirs && $self->dirs->log_dir);
+ for my $i ( keys %{$self->logs} ) {
+ next if ($self->logs->$i =~ /^\//);
+ $self->logs->$i($self->dirs->log_dir."/".$self->logs->$i);
+ }
+}
+
+sub mangle_dirs {
+ my $self = shift;
+ return unless ($self->dirs && $self->dirs->base_dir);
+ for my $i ( keys %{$self->dirs} ) {
+ if ( $i ne 'base_dir' ) {
+ next if ($self->dirs->$i =~ /^\//);
+ my $dir_tmp = $self->dirs->base_dir."/".$self->dirs->$i;
+ $dir_tmp =~ s#//#/#go;
+ $dir_tmp =~ s#/$##go;
+ $self->dirs->$i($dir_tmp);
+ }
+ }
+}
+
+sub load_config {
+ my $self = shift;
+ my $parser = XML::LibXML->new();
+
+ # Hash of config values
+ my %bootstrap;
+
+ # Return an XML::LibXML::Document object
+ my $config = $parser->parse_file($self->FILE);
+
+ unless ($config) {
+ OpenSRF::Utils::Logger->error("Could not open ".$self->FILE.": $!\n");
+ die "Could not open ".$self->FILE.": $!\n";
+ }
+
+ # Return an XML::LibXML::NodeList object matching all child elements
+ # of <config><opensrf>...
+ my $osrf_cfg = $config->findnodes('/config/opensrf/child::*');
+
+ # Iterate through the nodes to pull out key=>value pairs of config settings
+ foreach my $node ($osrf_cfg->get_nodelist()) {
+ my $child_state = 0;
+
+ # This will be overwritten if it's a scalar setting
+ $bootstrap{$node->nodeName()} = [];
+
+ foreach my $child_node ($node->childNodes) {
+ # from libxml/tree.h: nodeType 1 = ELEMENT_NODE
+ next if $child_node->nodeType() != 1;
+
+ # If the child node is an element, this element may
+ # have multiple values; therefore, push it into an array
+ my $content = OpenSRF::Utils::Config::extract_child($child_node);
+ push(@{$bootstrap{$node->nodeName()}}, $content) if $content;
+ $child_state = 1;
+ }
+ if (!$child_state) {
+ $bootstrap{$node->nodeName()} = OpenSRF::Utils::Config::extract_text($node->textContent);
+ }
+ }
+
+ my $section = $self->section_pkg->new(\%bootstrap);
+ my $sub_name = $section->SECTION;
+ $self->_sub_builder($sub_name);
+ $self->$sub_name($section);
+
+}
+sub extract_child {
+ my $node = shift;
+ use OpenSRF::Utils::SettingsParser;
+ return OpenSRF::Utils::SettingsParser::XML2perl($node);
+}
+
+sub extract_text {
+ my $self = shift;
+ $self =~ s/^\s*([.*?])\s*$//m;
+ return $self;
+}
+
+#------------------------------------------------------------------------------------------------------------------------------------
+
+=head1 SEE ALSO
+
+ OpenSRF::Utils
+
+=head1 LIMITATIONS
+
+Elements containing heterogeneous child elements are treated as though they have the same element name;
+for example:
+ <routers>
+ <router>localhost</router>
+ <furniture>chair</furniture>
+ </routers>
+
+... will simply generate a key=>value pair of C<< routers => ['localhost', 'chair'] >>.
+
+=head1 BUGS
+
+No known bugs, but report any to open-ils-dev@list.georgialibraries.org or mrylander@gmail.com.
+
+=head1 COPYRIGHT AND LICENSING
+
+Copyright (C) 2000-2007, Mike Rylander
+Copyright (C) 2007, Laurentian University, Dan Scott <dscott@laurentian.ca>
+
+The OpenSRF::Utils::Config module is free software. You may distribute under the terms
+of the GNU General Public License version 2 or greater.
+
+=cut
+
+
+1;
--- /dev/null
+package OpenSRF::Utils::JSON;
+use JSON::XS;
+use vars qw/%_class_map/;
+
+my $parser = JSON::XS->new;
+$parser->ascii(1); # output \u escaped strings
+$parser->allow_nonref(1);
+
+sub true {
+ return $parser->true();
+}
+
+sub false {
+ return $parser->false();
+}
+
+sub register_class_hint {
+ my $class = shift;
+ my %args = @_;
+ $_class_map{hints}{$args{hint}} = \%args;
+ $_class_map{classes}{$args{name}} = \%args;
+}
+
+sub lookup_class {
+ my $self = shift;
+ my $hint = shift;
+ return $_class_map{hints}{$hint}{name}
+}
+
+sub lookup_hint {
+ my $self = shift;
+ my $class = shift;
+ return $_class_map{classes}{$class}{hint}
+}
+
+sub _json_hint_to_class {
+ my $type = shift;
+ my $hint = shift;
+
+ return $_class_map{hints}{$hint}{name} if (exists $_class_map{hints}{$hint});
+
+ $type = 'hash' if ($type eq '}');
+ $type = 'array' if ($type eq ']');
+
+ OpenSRF::Utils::JSON->register_class_hint(name => $hint, hint => $hint, type => $type);
+
+ return $hint;
+}
+
+
+my $JSON_CLASS_KEY = '__c';
+my $JSON_PAYLOAD_KEY = '__p';
+
+sub JSON2perl {
+ my( $class, $string ) = @_;
+ my $perl = $class->rawJSON2perl($string);
+ return $class->JSONObject2Perl($perl);
+}
+
+sub perl2JSON {
+ my( $class, $obj ) = @_;
+ my $json = $class->perl2JSONObject($obj);
+ return $class->rawPerl2JSON($json);
+}
+
+sub JSONObject2Perl {
+ my $class = shift;
+ my $obj = shift;
+ my $ref = ref($obj);
+ if( $ref eq 'HASH' ) {
+ if( defined($obj->{$JSON_CLASS_KEY})) {
+ my $cls = $obj->{$JSON_CLASS_KEY};
+ $cls =~ s/^\s+//o;
+ $cls =~ s/\s+$//o;
+ if( $obj = $class->JSONObject2Perl($obj->{$JSON_PAYLOAD_KEY}) ) {
+ $cls = $class->lookup_class($cls) || $cls;
+ return bless(\$obj, $cls) unless ref($obj);
+ return bless($obj, $cls);
+ }
+ return undef;
+ }
+ $obj->{$_} = $class->JSONObject2Perl($obj->{$_}) for (keys %$obj);
+ } elsif( $ref eq 'ARRAY' ) {
+ $obj->[$_] = $class->JSONObject2Perl($obj->[$_]) for(0..scalar(@$obj) - 1);
+ }
+ return $obj;
+}
+
+sub perl2JSONObject {
+ my $class = shift;
+ my $obj = shift;
+ my $ref = ref($obj);
+
+ return $obj unless $ref;
+
+ return $obj if $ref eq 'JSON::XS::Boolean';
+ my $newobj;
+
+ if(UNIVERSAL::isa($obj, 'HASH')) {
+ $newobj = {};
+ $newobj->{$_} = $class->perl2JSONObject($obj->{$_}) for (keys %$obj);
+ } elsif(UNIVERSAL::isa($obj, 'ARRAY')) {
+ $newobj = [];
+ $newobj->[$_] = $class->perl2JSONObject($obj->[$_]) for(0..scalar(@$obj) - 1);
+ }
+
+ if($ref ne 'HASH' and $ref ne 'ARRAY') {
+ $ref = $class->lookup_hint($ref) || $ref;
+ $newobj = {$JSON_CLASS_KEY => $ref, $JSON_PAYLOAD_KEY => $newobj};
+ }
+
+ return $newobj;
+}
+
+
+sub rawJSON2perl {
+ my $class = shift;
+ my $json = shift;
+ return undef unless defined $json and $json !~ /^\s*$/o;
+ return $parser->decode($json);
+}
+
+sub rawPerl2JSON {
+ my ($class, $perl) = @_;
+ return $parser->encode($perl);
+}
+
+1;
--- /dev/null
+package OpenSRF::Utils::LogServer;
+use strict; use warnings;
+use base qw(OpenSRF);
+use IO::Socket::INET;
+use FileHandle;
+use OpenSRF::Utils::Config;
+use Fcntl;
+use Time::HiRes qw(gettimeofday);
+use OpenSRF::Utils::Logger;
+
+=head2 Name
+
+OpenSRF::Utils::LogServer
+
+=cut
+
+=head2 Synopsis
+
+Networ Logger
+
+=cut
+
+=head2 Description
+
+
+=cut
+
+
+
+our $config;
+our $port;
+our $bufsize = 4096;
+our $proto;
+our @file_info;
+
+
+sub DESTROY {
+ for my $file (@file_info) {
+ if( $file->handle ) {
+ close( $file->handle );
+ }
+ }
+}
+
+
+sub serve {
+
+ $config = OpenSRF::Utils::Config->current;
+
+ unless ($config) { throw OpenSRF::EX::Config ("No suitable config found"); }
+
+ $port = $config->system->log_port;
+ $proto = $config->system->log_proto;
+
+
+ my $server = IO::Socket::INET->new(
+ LocalPort => $port,
+ Proto => $proto )
+ or die "Error creating server socket : $@\n";
+
+
+
+ while ( 1 ) {
+ my $client = <$server>;
+ process( $client );
+ }
+
+ close( $server );
+}
+
+sub process {
+ my $client = shift;
+ my @params = split(/\|/,$client);
+ my $log = shift @params;
+
+ if( (!$log) || (!@params) ) {
+ warn "Invalid logging params: $log\n";
+ return;
+ }
+
+ # Put |'s back in since they are stripped
+ # from the message by 'split'
+ my $message;
+ if( @params > 1 ) {
+ foreach my $param (@params) {
+ if( $param ne $params[0] ) {
+ $message .= "|";
+ }
+ $message .= $param;
+ }
+ }
+ else{ $message = "@params"; }
+
+ my @lines = split( "\n", $message );
+ my $time = format_time();
+
+ my $fh;
+
+ my ($f_obj) = grep { $_->name eq $log } @file_info;
+
+ unless( $f_obj and ($fh=$f_obj->handle) ) {
+ my $file = $config->logs->$log;
+
+ sysopen( $fh, $file, O_WRONLY|O_APPEND|O_CREAT )
+ or warn "Cannot sysopen $log: $!";
+ $fh->autoflush(1);
+
+ my $obj = new OpenSRF::Utils::NetLogFile( $log, $file, $fh );
+ push @file_info, $obj;
+ }
+
+ foreach my $line (@lines) {
+ print $fh "$time $line\n" || die "$!";
+ }
+
+}
+
+sub format_time {
+ my ($s, $ms) = gettimeofday();
+ my @time = localtime( $s );
+ $ms = substr( $ms, 0, 3 );
+ my $year = $time[5] + 1900;
+ my $mon = $time[4] + 1;
+ my $day = $time[3];
+ my $hour = $time[2];
+ my $min = $time[1];
+ my $sec = $time[0];
+ $mon = "0" . "$mon" if ( length($mon) == 1 );
+ $day = "0" . "$day" if ( length($day) == 1 );
+ $hour = "0" . "$hour" if ( length($hour) == 1 );
+ $min = "0" . "$min" if (length($min) == 1 );
+ $sec = "0" . "$sec" if (length($sec) == 1 );
+
+ my $proc = $$;
+ while( length( $proc ) < 5 ) { $proc = "0" . "$proc"; }
+ return "[$year-$mon-$day $hour:$min:$sec.$ms $proc]";
+}
+
+
+package OpenSRF::Utils::NetLogFile;
+
+sub new{ return bless( [ $_[1], $_[2], $_[3] ], $_[0] ); }
+
+sub name { return $_[0]->[0]; }
+sub file { return $_[0]->[1]; }
+sub handle { return $_[0]->[2]; }
+
+
+1;
--- /dev/null
+package OpenSRF::Utils::Logger;
+# vim:ts=4:noet:
+use strict;
+use vars qw($AUTOLOAD @EXPORT_OK %EXPORT_TAGS);
+use Exporter;
+use Unix::Syslog qw(:macros :subs);
+use base qw/OpenSRF Exporter/;
+use FileHandle;
+use Time::HiRes qw(gettimeofday);
+use OpenSRF::Utils::Config;
+use Fcntl;
+
+=head1
+
+Logger code
+
+my $logger = OpenSRF::Utils::Logger;
+$logger->error( $msg );
+
+For backwards compability, a log level may also be provided to each log
+function thereby overriding the level defined by the function.
+
+i.e. $logger->error( $msg, WARN ); # logs at log level WARN
+
+=cut
+
+@EXPORT_OK = qw/ NONE ERROR WARN INFO DEBUG INTERNAL /;
+push @EXPORT_OK, '$logger';
+
+%EXPORT_TAGS = ( level => [ qw/ NONE ERROR WARN INFO DEBUG INTERNAL / ], logger => [ '$logger' ] );
+
+my $config; # config handle
+my $loglevel = INFO(); # global log level
+my $logfile; # log file
+my $facility; # syslog facility
+my $actfac; # activity log syslog facility
+my $actfile; # activity log file
+my $service = $0; # default service name
+my $syslog_enabled = 0; # is syslog enabled?
+my $act_syslog_enabled = 0; # is syslog enabled?
+my $logfile_enabled = 1; # are we logging to a file?
+my $act_logfile_enabled = 1; # are we logging to a file?
+
+our $logger = "OpenSRF::Utils::Logger";
+
+# log levels
+sub ACTIVITY { return -1; }
+sub NONE { return 0; }
+sub ERROR { return 1; }
+sub WARN { return 2; }
+sub INFO { return 3; }
+sub DEBUG { return 4; }
+sub INTERNAL { return 5; }
+sub ALL { return 100; }
+
+my $isclient; # true if we control the osrf_xid
+
+# load up our config options
+sub set_config {
+
+ return if defined $config;
+
+ $config = OpenSRF::Utils::Config->current;
+ if( !defined($config) ) {
+ $loglevel = INFO();
+ warn "*** Logger found no config. Using STDERR ***\n";
+ return;
+ }
+
+ $loglevel = $config->bootstrap->loglevel;
+
+ $logfile = $config->bootstrap->logfile;
+ if($logfile =~ /^syslog/) {
+ $syslog_enabled = 1;
+ $logfile_enabled = 0;
+ $logfile = $config->bootstrap->syslog;
+ $facility = $logfile;
+ $logfile = undef;
+ $facility = _fac_to_const($facility);
+ openlog($service, 0, $facility);
+
+ } else { $logfile = "$logfile"; }
+
+
+ if($syslog_enabled) {
+ # --------------------------------------------------------------
+ # if we're syslogging, see if we have a special syslog facility
+ # for activity logging. If not, use the syslog facility for
+ # standard logging
+ # --------------------------------------------------------------
+ $act_syslog_enabled = 1;
+ $act_logfile_enabled = 0;
+ $actfac = $config->bootstrap->actlog || $config->bootstrap->syslog;
+ $actfac = _fac_to_const($actfac);
+ $actfile = undef;
+ } else {
+ # --------------------------------------------------------------
+ # we're not syslogging, use any specified activity log file.
+ # Fall back to the standard log file otherwise
+ # --------------------------------------------------------------
+ $act_syslog_enabled = 0;
+ $act_logfile_enabled = 1;
+ $actfile = $config->bootstrap->actlog || $config->bootstrap->logfile;
+ }
+
+ my $client = OpenSRF::Utils::Config->current->bootstrap->client();
+ if (!$client) {
+ $isclient = 0;
+ return;
+ }
+ $isclient = ($client =~ /^true$/iog) ? 1 : 0;
+}
+
+sub _fac_to_const {
+ my $name = shift;
+ return LOG_LOCAL0 unless $name;
+ return LOG_LOCAL0 if $name =~ /local0/i;
+ return LOG_LOCAL1 if $name =~ /local1/i;
+ return LOG_LOCAL2 if $name =~ /local2/i;
+ return LOG_LOCAL3 if $name =~ /local3/i;
+ return LOG_LOCAL4 if $name =~ /local4/i;
+ return LOG_LOCAL5 if $name =~ /local5/i;
+ return LOG_LOCAL6 if $name =~ /local6/i;
+ return LOG_LOCAL7 if $name =~ /local7/i;
+ return LOG_LOCAL0;
+}
+
+sub is_syslog {
+ set_config();
+ return $syslog_enabled;
+}
+
+sub is_act_syslog {
+ set_config();
+ return $act_syslog_enabled;
+}
+
+sub is_filelog {
+ set_config();
+ return $logfile_enabled;
+}
+
+sub is_act_filelog {
+ set_config();
+ return $act_logfile_enabled;
+}
+
+sub set_service {
+ my( $self, $svc ) = @_;
+ $service = $svc;
+ if( is_syslog() ) {
+ closelog();
+ openlog($service, 0, $facility);
+ }
+}
+
+sub error {
+ my( $self, $msg, $level ) = @_;
+ $level = ERROR() unless defined ($level);
+ _log_message( $msg, $level );
+}
+
+sub warn {
+ my( $self, $msg, $level ) = @_;
+ $level = WARN() unless defined ($level);
+ _log_message( $msg, $level );
+}
+
+sub info {
+ my( $self, $msg, $level ) = @_;
+ $level = INFO() unless defined ($level);
+ _log_message( $msg, $level );
+}
+
+sub debug {
+ my( $self, $msg, $level ) = @_;
+ $level = DEBUG() unless defined ($level);
+ _log_message( $msg, $level );
+}
+
+sub internal {
+ my( $self, $msg, $level ) = @_;
+ $level = INTERNAL() unless defined ($level);
+ _log_message( $msg, $level );
+}
+
+sub activity {
+ my( $self, $msg ) = @_;
+ _log_message( $msg, ACTIVITY() );
+}
+
+# for backward compability
+sub transport {
+ my( $self, $msg, $level ) = @_;
+ $level = DEBUG() unless defined ($level);
+ _log_message( $msg, $level );
+}
+
+
+# ----------------------------------------------------------------------
+# creates a new xid if necessary
+# ----------------------------------------------------------------------
+my $osrf_xid = '';
+my $osrf_xid_inc = 0;
+sub mk_osrf_xid {
+ return unless $isclient;
+ $osrf_xid_inc++;
+ return $osrf_xid = "$^T${$}$osrf_xid_inc";
+}
+
+sub set_osrf_xid {
+ return if $isclient; # if we're a client, we control our xid
+ $osrf_xid = $_[1];
+}
+
+sub get_osrf_xid { return $osrf_xid; }
+# ----------------------------------------------------------------------
+
+
+sub _log_message {
+ my( $msg, $level ) = @_;
+ return if $level > $loglevel;
+
+ my $l; my $n;
+ my $fac = $facility;
+
+ if ($level == ERROR()) {$l = LOG_ERR; $n = "ERR "; }
+ elsif ($level == WARN()) {$l = LOG_WARNING; $n = "WARN"; }
+ elsif ($level == INFO()) {$l = LOG_INFO; $n = "INFO"; }
+ elsif ($level == DEBUG()) {$l = LOG_DEBUG; $n = "DEBG"; }
+ elsif ($level == INTERNAL()) {$l = LOG_DEBUG; $n = "INTL"; }
+ elsif ($level == ACTIVITY()) {$l = LOG_INFO; $n = "ACT"; $fac = $actfac; }
+
+ my( undef, $file, $line_no ) = caller(1);
+ $file =~ s#/.*/##og;
+
+ # help syslog with the formatting
+ $msg =~ s/\%/\%\%/gso if( is_act_syslog() or is_syslog() );
+
+ $msg = "[$n:"."$$".":$file:$line_no:$osrf_xid] $msg";
+
+ $msg = substr($msg, 0, 1536);
+
+ if( $level == ACTIVITY() ) {
+ if( is_act_syslog() ) { syslog( $fac | $l, $msg ); }
+ elsif( is_act_filelog() ) { _write_file( $msg, 1 ); }
+
+ } else {
+ if( is_syslog() ) { syslog( $fac | $l, $msg ); }
+ elsif( is_filelog() ) { _write_file($msg); }
+ }
+}
+
+
+sub _write_file {
+ my( $msg, $isact) = @_;
+ my $file = $logfile;
+ $file = $actfile if $isact;
+ my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime(time);
+ $year += 1900; $mon += 1;
+ sysopen( SINK, $file, O_NONBLOCK|O_WRONLY|O_APPEND|O_CREAT )
+ or die "Cannot sysopen $logfile: $!";
+ binmode(SINK, ':utf8');
+ printf SINK "[%04d-%02d-%02d %02d:%02d:%02d] %s %s\n", $year, $mon, $mday, $hour, $min, $sec, $service, $msg;
+ close( SINK );
+}
+
+
+
+1;
--- /dev/null
+use strict; use warnings;
+package OpenSRF::Utils::SettingsClient;
+use OpenSRF::Utils::SettingsParser;
+use OpenSRF::System;
+use OpenSRF::AppSession;
+use OpenSRF::Utils::Config;
+use OpenSRF::EX qw(:try);
+
+use vars qw/$host_config/;
+
+
+sub new {return bless({},shift());}
+my $session;
+$host_config = undef;
+
+my $we_cache = 1;
+sub set_cache {
+ my($self, $val) = @_;
+ if(defined($val)) { $we_cache = $val; }
+}
+
+sub has_config {
+ if($host_config) { return 1; }
+ return 0;
+}
+
+
+# ------------------------------------
+# utility method for grabbing config info
+sub config_value {
+ my($self,@keys) = @_;
+
+
+ my $bsconfig = OpenSRF::Utils::Config->current;
+ die "No bootstrap config exists. Have you bootstrapped?\n" unless $bsconfig;
+ my $host = $bsconfig->env->hostname;
+
+ if($we_cache) {
+ if(!$host_config) { grab_host_config($host); }
+ } else {
+ grab_host_config($host);
+ }
+
+ if(!$host_config) {
+ throw OpenSRF::EX::Config ("Unable to retrieve host config for $host" );
+ }
+
+ my $hash = $host_config;
+
+ # XXX TO DO, check local config 'version',
+ # call out to settings server when necessary....
+ try {
+ for my $key (@keys) {
+ if(!ref($hash) eq 'HASH'){
+ return undef;
+ }
+ $hash = $hash->{$key};
+ }
+
+ } catch Error with {
+ my $e = shift;
+ throw OpenSRF::EX::Config ("No Config information for @keys : $e : $@");
+ };
+
+ return $hash;
+
+}
+
+
+# XXX make smarter and more robust...
+sub grab_host_config {
+
+ my $host = shift;
+
+ $session = OpenSRF::AppSession->create( "opensrf.settings" ) unless $session;
+ my $bsconfig = OpenSRF::Utils::Config->current;
+
+ my $resp;
+ my $req;
+ try {
+
+ if( ! ($session->connect()) ) {die "Settings Connect timed out\n";}
+ $req = $session->request( "opensrf.settings.host_config.get", $host );
+ $resp = $req->recv( timeout => 10 );
+
+ } catch OpenSRF::EX with {
+
+ if( ! ($session->connect()) ) {die "Settings Connect timed out\n";}
+ $req = $session->request( "opensrf.settings.default_config.get" );
+ $resp = $req->recv( timeout => 10 );
+
+ } catch Error with {
+
+ my $e = shift;
+ warn "Connection to Settings Failed $e : $@ ***\n";
+ die $e;
+
+ } otherwise {
+
+ my $e = shift;
+ warn "Settings Retrieval Failed $e : $@ ***\n";
+ die $e;
+ };
+
+ if(!$resp) {
+ warn "No Response from settings server...going to sleep\n";
+ sleep;
+ }
+
+ if( $resp && UNIVERSAL::isa( $resp, "OpenSRF::EX" ) ) {
+ throw $resp;
+ }
+
+ $host_config = $resp->content();
+ $req->finish();
+ $session->disconnect();
+ $session->finish;
+ $session->kill_me();
+}
+
+
+
+1;
--- /dev/null
+use strict; use warnings;
+package OpenSRF::Utils::SettingsParser;
+use OpenSRF::Utils::Config;
+use OpenSRF::EX qw(:try);
+
+
+
+use XML::LibXML;
+
+sub DESTROY{}
+our $log = 'OpenSRF::Utils::Logger';
+my $parser;
+my $doc;
+
+sub new { return bless({},shift()); }
+
+
+# returns 0 if the config file could not be found or if there is a parse error
+# returns 1 if successful
+sub initialize {
+
+ my ($self,$bootstrap_config) = @_;
+ return 0 unless($self and $bootstrap_config);
+
+ $parser = XML::LibXML->new();
+ $parser->keep_blanks(0);
+ try {
+ $doc = $parser->parse_file( $bootstrap_config );
+ } catch Error with {
+ return 0;
+ };
+ return 1;
+}
+
+sub _get { _get_overlay(@_) }
+
+sub _get_overlay {
+ my( $self, $xpath ) = @_;
+ my @nodes = $doc->documentElement->findnodes( $xpath );
+
+ my $base = XML2perl(shift(@nodes));
+ my @overlays;
+ for my $node (@nodes) {
+ push @overlays, XML2perl($node);
+ }
+
+ for my $ol ( @overlays ) {
+ $base = merge_perl($base, $ol);
+ }
+
+ return $base;
+}
+
+sub _get_all {
+ my( $self, $xpath ) = @_;
+ my @nodes = $doc->documentElement->findnodes( $xpath );
+
+ my @overlays;
+ for my $node (@nodes) {
+ push @overlays, XML2perl($node);
+ }
+
+ return \@overlays;
+}
+
+sub merge_perl {
+ my $base = shift;
+ my $ol = shift;
+
+ if (ref($ol)) {
+ if (ref($ol) eq 'HASH') {
+ for my $key (keys %$ol) {
+ if (ref($$ol{$key}) and ref($$ol{$key}) eq ref($$base{$key})) {
+ merge_perl($$base{$key}, $$ol{$key});
+ } else {
+ $$base{$key} = $$ol{$key};
+ }
+ }
+ } else {
+ for my $key (0 .. scalar(@$ol) - 1) {
+ if (ref($$ol[$key]) and ref($$ol[$key]) eq ref($$base[$key])) {
+ merge_perl($$base[$key], $$ol[$key]);
+ } else {
+ $$base[$key] = $$ol[$key];
+ }
+ }
+ }
+ } else {
+ $base = $ol;
+ }
+
+ return $base;
+}
+
+sub _check_for_int {
+ my $value = shift;
+ return 0+$value if ($value =~ /^\d{1,10}$/o);
+ return $value;
+}
+
+sub XML2perl {
+ my $node = shift;
+ my %output;
+
+ return undef unless($node);
+
+ for my $attr ( ($node->attributes()) ) {
+ next unless($attr);
+ $output{$attr->nodeName} = _check_for_int($attr->value);
+ }
+
+ my @kids = $node->childNodes;
+ if (@kids == 1 && $kids[0]->nodeType == 3) {
+ return _check_for_int($kids[0]->textContent);
+ } else {
+ for my $kid ( @kids ) {
+ next if ($kid->nodeName eq 'comment');
+ if (exists $output{$kid->nodeName}) {
+ if (ref $output{$kid->nodeName} ne 'ARRAY') {
+ $output{$kid->nodeName} = [$output{$kid->nodeName}, XML2perl($kid)];
+ } else {
+ push @{$output{$kid->nodeName}}, XML2perl($kid);
+ }
+ next;
+ }
+ $output{$kid->nodeName} = XML2perl($kid);
+ }
+ }
+
+ return \%output;
+}
+
+
+# returns the full config hash for a given server
+sub get_server_config {
+ my( $self, $server ) = @_;
+ my $xpath = "/opensrf/default|/opensrf/hosts/$server";
+ return $self->_get( $xpath );
+}
+
+sub get_default_config {
+ my( $self, $server ) = @_;
+ my $xpath = "/opensrf/default";
+ return $self->_get( $xpath );
+}
+
+sub get_bootstrap_config {
+ my( $self ) = @_;
+ my $xpath = "/opensrf/bootstrap";
+ return $self->_get( $xpath );
+}
+
+sub get_router_config {
+ my( $self, $router ) = @_;
+ my $xpath = "/opensrf/routers/$router";
+ return $self->_get($xpath );
+}
+
+
+
+
+1;
--- /dev/null
+#!perl -T
+
+use Test::More tests => 1;
+
+BEGIN {
+ use_ok( 'OpenSRF' );
+}
+
+diag( "Testing OpenSRF $OpenSRF::VERSION, Perl $], $^X" );
--- /dev/null
+use strict;
+use warnings;
+use Test::More tests => 1;
+
+# FIXME SKIPPING POD COVERAGE TESTS FOR NOW
+ok(1);exit;
+
+# Ensure a recent version of Test::Pod::Coverage
+my $min_tpc = 1.08;
+eval "use Test::Pod::Coverage $min_tpc";
+plan skip_all => "Test::Pod::Coverage $min_tpc required for testing POD coverage"
+ if $@;
+
+# Test::Pod::Coverage doesn't require a minimum Pod::Coverage version,
+# but older versions don't recognize some common documentation styles
+my $min_pc = 0.18;
+eval "use Pod::Coverage $min_pc";
+plan skip_all => "Pod::Coverage $min_pc required for testing POD coverage"
+ if $@;
+
+all_pod_coverage_ok();
--- /dev/null
+#!perl -T
+
+use strict;
+use warnings;
+use Test::More;
+
+# Ensure a recent version of Test::Pod
+my $min_tp = 1.22;
+eval "use Test::Pod $min_tp";
+plan skip_all => "Test::Pod $min_tp required for testing POD" if $@;
+
+all_pod_files_ok();
+++ /dev/null
-package OpenSRF;
-use strict;
-use Error;
-require UNIVERSAL::require;
-use vars qw/$VERSION $AUTOLOAD/;
-$VERSION = do { my @r=(q$Revision$=~/\d+/g); sprintf "%d."."%02d"x$#r,@r };
-
-=head1 OpenSRF
-
-=cut
-
-=head2 Overview
-
- Top level class for OpenSRF perl modules.
-
-=cut
-
-# Exception base classes
-#use Exception::Class
-# ( OpenSRFException => { fields => [ 'errno' ] });
-#push @Exception::Class::ISA, 'Error';
-
-=head3 AUTOLOAD()
-
- Traps methods calls for methods that have not been defined so they
- don't propogate up the class hierarchy.
-
-=cut
-sub AUTOLOAD {
- my $self = shift;
- my $type = ref($self) || $self;
- my $name = $AUTOLOAD;
- my $otype = ref $self;
-
- my ($package, $filename, $line) = caller;
- my ($package1, $filename1, $line1) = caller(1);
- my ($package2, $filename2, $line2) = caller(2);
- my ($package3, $filename3, $line3) = caller(3);
- my ($package4, $filename4, $line4) = caller(4);
- my ($package5, $filename5, $line5) = caller(5);
- $name =~ s/.*://; # strip fully-qualified portion
- warn <<" WARN";
-****
-** ${name}() isn't there. Please create me somewhere (like in $type)!
-** Error at $package ($filename), line $line
-** Call Stack (5 deep):
-** $package1 ($filename1), line $line1
-** $package2 ($filename2), line $line2
-** $package3 ($filename3), line $line3
-** $package4 ($filename4), line $line4
-** $package5 ($filename5), line $line5
-** Object type was $otype
-****
- WARN
-}
-
-
-
-=head3 alert_abstract()
-
- This method is called by abstract methods to ensure that
- the process dies when an undefined abstract method is called
-
-=cut
-sub alert_abstract() {
- my $c = shift;
- my $class = ref( $c ) || $c;
- my ($file, $line, $method) = (caller(1))[1..3];
- die " * Call to abstract method $method at $file, line $line";
-}
-
-sub class { return scalar(caller); }
-
-1;
+++ /dev/null
-package OpenSRF::AppSession;
-use OpenSRF::DomainObject::oilsMessage;
-use OpenSRF::DomainObject::oilsMethod;
-use OpenSRF::DomainObject::oilsResponse qw/:status/;
-use OpenSRF::Transport::PeerHandle;
-use OpenSRF::Utils::JSON;
-use OpenSRF::Utils::Logger qw(:level);
-use OpenSRF::Utils::SettingsClient;
-use OpenSRF::Utils::Config;
-use OpenSRF::EX;
-use OpenSRF;
-use Exporter;
-use base qw/Exporter OpenSRF/;
-use Time::HiRes qw( time usleep );
-use warnings;
-use strict;
-
-our @EXPORT_OK = qw/CONNECTING INIT_CONNECTED CONNECTED DISCONNECTED CLIENT SERVER/;
-our %EXPORT_TAGS = ( state => [ qw/CONNECTING INIT_CONNECTED CONNECTED DISCONNECTED/ ],
- endpoint => [ qw/CLIENT SERVER/ ],
-);
-
-my $logger = "OpenSRF::Utils::Logger";
-my $_last_locale = 'en-US';
-
-our %_CACHE;
-our @_RESEND_QUEUE;
-
-sub CONNECTING { return 3 };
-sub INIT_CONNECTED { return 4 };
-sub CONNECTED { return 1 };
-sub DISCONNECTED { return 2 };
-
-sub CLIENT { return 2 };
-sub SERVER { return 1 };
-
-sub find {
- return undef unless (defined $_[1]);
- return $_CACHE{$_[1]} if (exists($_CACHE{$_[1]}));
-}
-
-sub transport_connected {
- my $self = shift;
- if( ! exists $self->{peer_handle} || ! $self->{peer_handle} ) {
- return 0;
- }
- return $self->{peer_handle}->tcp_connected();
-}
-
-sub connected {
- my $self = shift;
- return $self->state == CONNECTED;
-}
-# ----------------------------------------------------------------------------
-# Clears the transport buffers
-# call this if you are not through with the sesssion, but you want
-# to have a clean slate. You shouldn't have to call this if
-# you are correctly 'recv'ing all of the data from a request.
-# however, if you don't want all of the data, this will
-# slough off any excess
-# * * Note: This will delete data for all sessions using this transport
-# handle. For example, all client sessions use the same handle.
-# ----------------------------------------------------------------------------
-sub buffer_reset {
-
- my $self = shift;
- if( ! exists $self->{peer_handle} || ! $self->{peer_handle} ) {
- return 0;
- }
- $self->{peer_handle}->buffer_reset();
-}
-
-
-# when any incoming data is received, this method is called.
-sub server_build {
- my $class = shift;
- $class = ref($class) || $class;
-
- my $sess_id = shift;
- my $remote_id = shift;
- my $service = shift;
-
- warn "Missing args to server_build():\n" .
- "sess_id: $sess_id, remote_id: $remote_id, service: $service\n"
- unless ($sess_id and $remote_id and $service);
-
- return undef unless ($sess_id and $remote_id and $service);
-
- if ( my $thingy = $class->find($sess_id) ) {
- $thingy->remote_id( $remote_id );
- return $thingy;
- }
-
- if( $service eq "client" ) {
- #throw OpenSRF::EX::PANIC ("Attempting to build a client session as a server" .
- # " Session ID [$sess_id], remote_id [$remote_id]");
-
- warn "Attempting to build a client session as ".
- "a server Session ID [$sess_id], remote_id [$remote_id]";
-
- $logger->debug("Attempting to build a client session as ".
- "a server Session ID [$sess_id], remote_id [$remote_id]", ERROR );
-
- return undef;
- }
-
- my $config_client = OpenSRF::Utils::SettingsClient->new();
- my $stateless = $config_client->config_value("apps", $service, "stateless");
-
- #my $max_requests = $conf->$service->max_requests;
- my $max_requests = $config_client->config_value("apps",$service,"max_requests");
- $logger->debug( "Max Requests for $service is $max_requests", INTERNAL ) if (defined $max_requests);
-
- $logger->transport( "AppSession creating new session: $sess_id", INTERNAL );
-
- my $self = bless { recv_queue => [],
- request_queue => [],
- requests => 0,
- session_data => {},
- callbacks => {},
- endpoint => SERVER,
- state => CONNECTING,
- session_id => $sess_id,
- remote_id => $remote_id,
- peer_handle => OpenSRF::Transport::PeerHandle->retrieve($service),
- max_requests => $max_requests,
- session_threadTrace => 0,
- service => $service,
- stateless => $stateless,
- } => $class;
-
- return $_CACHE{$sess_id} = $self;
-}
-
-sub session_data {
- my $self = shift;
- my ($name, $datum) = @_;
-
- $self->{session_data}->{$name} = $datum if (defined $datum);
- return $self->{session_data}->{$name};
-}
-
-sub service { return shift()->{service}; }
-
-sub continue_request {
- my $self = shift;
- $self->{'requests'}++;
- return 1 if (!$self->{'max_requests'});
- return $self->{'requests'} <= $self->{'max_requests'} ? 1 : 0;
-}
-
-sub last_sent_payload {
- my( $self, $payload ) = @_;
- if( $payload ) {
- return $self->{'last_sent_payload'} = $payload;
- }
- return $self->{'last_sent_payload'};
-}
-
-sub session_locale {
- my( $self, $type ) = @_;
- if( $type ) {
- $_last_locale = $type if ($self->endpoint == SERVER);
- return $self->{'session_locale'} = $type;
- }
- return $self->{'session_locale'};
-}
-
-sub last_sent_type {
- my( $self, $type ) = @_;
- if( $type ) {
- return $self->{'last_sent_type'} = $type;
- }
- return $self->{'last_sent_type'};
-}
-
-sub get_app_targets {
- my $app = shift;
-
- my $conf = OpenSRF::Utils::Config->current;
- my $router_name = $conf->bootstrap->router_name || 'router';
- my $domain = $conf->bootstrap->domain;
- $logger->error("use of <domains/> is deprecated") if $conf->bootstrap->domains;
-
- unless($router_name and $domain) {
- throw OpenSRF::EX::Config
- ("Missing router config information 'router_name' and 'domain'");
- }
-
- return ("$router_name\@$domain/$app");
-}
-
-sub stateless {
- my $self = shift;
- my $state = shift;
- $self->{stateless} = $state if (defined $state);
- return $self->{stateless};
-}
-
-# When we're a client and we want to connect to a remote service
-sub create {
- my $class = shift;
- $class = ref($class) || $class;
-
- my $app = shift;
- my $api_level = shift;
- my $quiet = shift;
- my $locale = shift || $_last_locale;
-
- $api_level = 1 if (!defined($api_level));
-
- $logger->debug( "AppSession creating new client session for $app", DEBUG );
-
- my $stateless = 0;
- my $c = OpenSRF::Utils::SettingsClient->new();
- # we can get an infinite loop if we're grabbing the settings and we
- # need the settings to grab the settings...
- if($app ne "opensrf.settings" || $c->has_config()) {
- $stateless = $c->config_value("apps", $app, "stateless");
- }
-
- my $sess_id = time . rand( $$ );
- while ( $class->find($sess_id) ) {
- $sess_id = time . rand( $$ );
- }
-
-
- my ($r_id) = get_app_targets($app);
-
- my $peer_handle = OpenSRF::Transport::PeerHandle->retrieve("client");
- if( ! $peer_handle ) {
- $peer_handle = OpenSRF::Transport::PeerHandle->retrieve("system_client");
- }
-
- my $self = bless { app_name => $app,
- request_queue => [],
- endpoint => CLIENT,
- state => DISCONNECTED,#since we're init'ing
- session_id => $sess_id,
- remote_id => $r_id,
- raise_error => $quiet ? 0 : 1,
- session_locale => $locale,
- api_level => $api_level,
- orig_remote_id => $r_id,
- peer_handle => $peer_handle,
- session_threadTrace => 0,
- stateless => $stateless,
- } => $class;
-
- $logger->debug( "Created new client session $app : $sess_id" );
-
- return $_CACHE{$sess_id} = $self;
-}
-
-sub raise_remote_errors {
- my $self = shift;
- my $err = shift;
- $self->{raise_error} = $err if (defined $err);
- return $self->{raise_error};
-}
-
-sub api_level {
- return shift()->{api_level};
-}
-
-sub app {
- return shift()->{app_name};
-}
-
-sub reset {
- my $self = shift;
- $self->remote_id($$self{orig_remote_id});
-}
-
-# 'connect' can be used as a constructor if called as a class method,
-# or used to connect a session that has disconnectd if called against
-# an existing session that seems to be disconnected, or was just built
-# using 'create' above.
-
-# connect( $app, username => $user, secret => $passwd );
-# OR
-# connect( $app, sysname => $user, secret => $shared_secret );
-
-# --- Returns undef if the connect attempt times out.
-# --- Returns the OpenSRF::EX object if one is returned by the server
-# --- Returns self if connected
-sub connect {
- my $self = shift;
- my $class = ref($self) || $self;
-
-
- if ( ref( $self ) and $self->state && $self->state == CONNECTED ) {
- $logger->transport("AppSession already connected", DEBUG );
- } else {
- $logger->transport("AppSession not connected, connecting..", DEBUG );
- }
- return $self if ( ref( $self ) and $self->state && $self->state == CONNECTED );
-
-
- my $app = shift;
- my $api_level = shift;
- $api_level = 1 unless (defined $api_level);
-
- $self = $class->create($app, @_) if (!ref($self));
-
- return undef unless ($self);
-
- $self->{api_level} = $api_level;
-
- $self->reset;
- $self->state(CONNECTING);
- $self->send('CONNECT', "");
-
-
- # if we want to connect to settings, we may not have
- # any data for the settings client to work with...
- # just using a default for now XXX
-
- my $time_remaining = 5;
-
-=head blah
- my $client = OpenSRF::Utils::SettingsClient->new();
- my $trans = $client->config_value("client_connection","transport_host");
-
- if(!ref($trans)) {
- $time_remaining = $trans->{connect_timeout};
- } else {
- # XXX for now, just use the first
- $time_remaining = $trans->[0]->{connect_timeout};
- }
-=cut
-
- while ( $self->state != CONNECTED and $time_remaining > 0 ) {
- my $starttime = time;
- $self->queue_wait($time_remaining);
- my $endtime = time;
- $time_remaining -= ($endtime - $starttime);
- }
-
- return undef unless($self->state == CONNECTED);
-
- $self->stateless(0);
-
- return $self;
-}
-
-sub finish {
- my $self = shift;
- if( ! $self->session_id ) {
- return 0;
- }
-}
-
-sub unregister_callback {
- my $self = shift;
- my $type = shift;
- my $cb = shift;
- if (exists $self->{callbacks}{$type}) {
- delete $self->{callbacks}{$type}{$cb};
- return $cb;
- }
- return undef;
-}
-
-sub register_callback {
- my $self = shift;
- my $type = shift;
- my $cb = shift;
- my $cb_key = "$cb";
- $self->{callbacks}{$type}{$cb_key} = $cb;
- return $cb_key;
-}
-
-sub kill_me {
- my $self = shift;
- if( ! $self->session_id ) { return 0; }
-
- # run each 'death' callback;
- if (exists $self->{callbacks}{death}) {
- for my $sub (values %{$self->{callbacks}{death}}) {
- $sub->($self);
- }
- }
-
- $self->disconnect;
- $logger->transport( "AppSession killing self: " . $self->session_id(), DEBUG );
- delete $_CACHE{$self->session_id};
- delete($$self{$_}) for (keys %$self);
-}
-
-sub disconnect {
- my $self = shift;
-
- # run each 'disconnect' callback;
- if (exists $self->{callbacks}{disconnect}) {
- for my $sub (values %{$self->{callbacks}{disconnect}}) {
- $sub->($self);
- }
- }
-
- if ( !$self->stateless and $self->state != DISCONNECTED ) {
- $self->send('DISCONNECT', "") if ($self->endpoint == CLIENT);
- $self->state( DISCONNECTED );
- }
-
- $self->reset;
-}
-
-sub request {
- my $self = shift;
- my $meth = shift;
- return unless $self;
-
- # tell the logger to create a new xid - the logger will decide if it's really necessary
- $logger->mk_osrf_xid;
-
- my $method;
- if (!ref $meth) {
- $method = new OpenSRF::DomainObject::oilsMethod ( method => $meth );
- } else {
- $method = $meth;
- }
-
- $method->params( @_ );
-
- $self->send('REQUEST',$method);
-}
-
-sub full_request {
- my $self = shift;
- my $meth = shift;
-
- my $method;
- if (!ref $meth) {
- $method = new OpenSRF::DomainObject::oilsMethod ( method => $meth );
- } else {
- $method = $meth;
- }
-
- $method->params( @_ );
-
- $self->send(CONNECT => '', REQUEST => $method, DISCONNECT => '');
-}
-
-sub send {
- my $self = shift;
- my @payload_list = @_; # this is a Domain Object
-
- return unless ($self and $self->{peer_handle});
-
- $logger->debug( "In send", INTERNAL );
-
- my $tT;
-
- if( @payload_list % 2 ) { $tT = pop @payload_list; }
-
- if( ! @payload_list ) {
- $logger->debug( "payload_list param is incomplete in AppSession::send()", ERROR );
- return undef;
- }
-
- my @doc = ();
-
- my $disconnect = 0;
- my $connecting = 0;
-
- while( @payload_list ) {
-
- my ($msg_type, $payload) = ( shift(@payload_list), shift(@payload_list) );
-
- if ($msg_type eq 'DISCONNECT' ) {
- $disconnect++;
- if( $self->state == DISCONNECTED && !$connecting) {
- next;
- }
- }
-
- if( $msg_type eq "CONNECT" ) {
- $connecting++;
- }
-
- my $msg = OpenSRF::DomainObject::oilsMessage->new();
- $msg->type($msg_type);
-
- no warnings;
- $msg->threadTrace( $tT || int($self->session_threadTrace) || int($self->last_threadTrace) );
- use warnings;
-
- if ($msg->type eq 'REQUEST') {
- if ( !defined($tT) || $self->last_threadTrace != $tT ) {
- $msg->update_threadTrace;
- $self->session_threadTrace( $msg->threadTrace );
- $tT = $self->session_threadTrace;
- OpenSRF::AppRequest->new($self, $payload);
- }
- }
-
- $msg->api_level($self->api_level);
- $msg->payload($payload) if $payload;
-
- my $locale = $self->session_locale;
- $msg->sender_locale($locale) if ($locale);
-
- push @doc, $msg;
-
-
- $logger->info( "AppSession sending ".$msg->type." to ".$self->remote_id.
- " with threadTrace [".$msg->threadTrace."]");
-
- }
-
- if ($self->endpoint == CLIENT and ! $disconnect) {
- $self->queue_wait(0);
-
-
- if($self->stateless && $self->state != CONNECTED) {
- $self->reset;
- $logger->debug("AppSession is stateless in send", INTERNAL );
- }
-
- if( !$self->stateless and $self->state != CONNECTED ) {
-
- $logger->debug( "Sending connect before request 1", INTERNAL );
-
- unless (($self->state == CONNECTING && $connecting )) {
- $logger->debug( "Sending connect before request 2", INTERNAL );
- my $v = $self->connect();
- if( ! $v ) {
- $logger->debug( "Unable to connect to remote service in AppSession::send()", ERROR );
- return undef;
- }
- if( ref($v) and $v->can("class") and $v->class->isa( "OpenSRF::EX" ) ) {
- return $v;
- }
- }
- }
-
- }
- my $json = OpenSRF::Utils::JSON->perl2JSON(\@doc);
- $logger->internal("AppSession sending doc: $json");
-
- $self->{peer_handle}->send(
- to => $self->remote_id,
- thread => $self->session_id,
- body => $json );
-
- if( $disconnect) {
- $self->state( DISCONNECTED );
- }
-
- my $req = $self->app_request( $tT );
- $req->{_start} = time;
- return $req
-}
-
-sub app_request {
- my $self = shift;
- my $tT = shift;
-
- return undef unless (defined $tT);
- my ($req) = grep { $_->threadTrace == $tT } @{ $self->{request_queue} };
-
- return $req;
-}
-
-sub remove_app_request {
- my $self = shift;
- my $req = shift;
-
- my @list = grep { $_->threadTrace != $req->threadTrace } @{ $self->{request_queue} };
-
- $self->{request_queue} = \@list;
-}
-
-sub endpoint {
- return $_[0]->{endpoint};
-}
-
-
-sub session_id {
- my $self = shift;
- return $self->{session_id};
-}
-
-sub push_queue {
- my $self = shift;
- my $resp = shift;
- my $req = $self->app_request($resp->[1]);
- return $req->push_queue( $resp->[0] ) if ($req);
- push @{ $self->{recv_queue} }, $resp->[0];
-}
-
-sub last_threadTrace {
- my $self = shift;
- my $new_last_threadTrace = shift;
-
- my $old_last_threadTrace = $self->{last_threadTrace};
- if (defined $new_last_threadTrace) {
- $self->{last_threadTrace} = $new_last_threadTrace;
- return $new_last_threadTrace unless ($old_last_threadTrace);
- }
-
- return $old_last_threadTrace;
-}
-
-sub session_threadTrace {
- my $self = shift;
- my $new_last_threadTrace = shift;
-
- my $old_last_threadTrace = $self->{session_threadTrace};
- if (defined $new_last_threadTrace) {
- $self->{session_threadTrace} = $new_last_threadTrace;
- return $new_last_threadTrace unless ($old_last_threadTrace);
- }
-
- return $old_last_threadTrace;
-}
-
-sub last_message_type {
- my $self = shift;
- my $new_last_message_type = shift;
-
- my $old_last_message_type = $self->{last_message_type};
- if (defined $new_last_message_type) {
- $self->{last_message_type} = $new_last_message_type;
- return $new_last_message_type unless ($old_last_message_type);
- }
-
- return $old_last_message_type;
-}
-
-sub last_message_api_level {
- my $self = shift;
- my $new_last_message_api_level = shift;
-
- my $old_last_message_api_level = $self->{last_message_api_level};
- if (defined $new_last_message_api_level) {
- $self->{last_message_api_level} = $new_last_message_api_level;
- return $new_last_message_api_level unless ($old_last_message_api_level);
- }
-
- return $old_last_message_api_level;
-}
-
-sub remote_id {
- my $self = shift;
- my $new_remote_id = shift;
-
- my $old_remote_id = $self->{remote_id};
- if (defined $new_remote_id) {
- $self->{remote_id} = $new_remote_id;
- return $new_remote_id unless ($old_remote_id);
- }
-
- return $old_remote_id;
-}
-
-sub client_auth {
- return undef;
- my $self = shift;
- my $new_ua = shift;
-
- my $old_ua = $self->{client_auth};
- if (defined $new_ua) {
- $self->{client_auth} = $new_ua;
- return $new_ua unless ($old_ua);
- }
-
- return $old_ua->cloneNode(1);
-}
-
-sub state {
- my $self = shift;
- my $new_state = shift;
-
- my $old_state = $self->{state};
- if (defined $new_state) {
- $self->{state} = $new_state;
- return $new_state unless ($old_state);
- }
-
- return $old_state;
-}
-
-sub DESTROY {
- my $self = shift;
- delete $$self{$_} for keys %$self;
- return undef;
-}
-
-sub recv {
- my $self = shift;
- my @proto_args = @_;
- my %args;
-
- if ( @proto_args ) {
- if ( !(@proto_args % 2) ) {
- %args = @proto_args;
- } elsif (@proto_args == 1) {
- %args = ( timeout => @proto_args );
- }
- }
-
- #$logger->debug( ref($self). " recv_queue before wait: " . $self->_print_queue(), INTERNAL );
-
- if( exists( $args{timeout} ) ) {
- $args{timeout} = int($args{timeout});
- $self->{recv_timeout} = $args{timeout};
- }
-
- #$args{timeout} = 0 if ($self->complete);
-
- if(defined($args{timeout})) {
- $logger->debug( ref($self) ."->recv with timeout " . $args{timeout}, INTERNAL );
- }
-
- my $avail = @{ $self->{recv_queue} };
- $self->{remaining_recv_timeout} = $self->{recv_timeout};
-
- if (!$args{count}) {
- if (wantarray) {
- $args{count} = $avail;
- } else {
- $args{count} = 1;
- }
- }
-
- while ( $self->{remaining_recv_timeout} > 0 and $avail < $args{count} ) {
- last if $self->complete;
- my $starttime = time;
- $self->queue_wait($self->{remaining_recv_timeout});
- my $endtime = time;
- if ($self->{timeout_reset}) {
- $self->{timeout_reset} = 0;
- } else {
- $self->{remaining_recv_timeout} -= ($endtime - $starttime)
- }
- $avail = @{ $self->{recv_queue} };
- }
-
-
- my @list;
- while ( my $msg = shift @{ $self->{recv_queue} } ) {
- push @list, $msg;
- last if (scalar(@list) >= $args{count});
- }
-
- $logger->debug( "Number of matched responses: " . @list, DEBUG );
- $self->queue_wait(0); # check for statuses
-
- return $list[0] if (!wantarray);
- return @list;
-}
-
-sub push_resend {
- my $self = shift;
- push @OpenSRF::AppSession::_RESEND_QUEUE, @_;
-}
-
-sub flush_resend {
- my $self = shift;
- $logger->debug( "Resending..." . @_RESEND_QUEUE, INTERNAL );
- while ( my $req = shift @OpenSRF::AppSession::_RESEND_QUEUE ) {
- $req->resend unless $req->complete;
- }
-}
-
-
-sub queue_wait {
- my $self = shift;
- if( ! $self->{peer_handle} ) { return 0; }
- my $timeout = shift || 0;
- $logger->debug( "Calling queue_wait($timeout)" , INTERNAL );
- my $o = $self->{peer_handle}->process($timeout);
- $self->flush_resend;
- return $o;
-}
-
-sub _print_queue {
- my( $self ) = @_;
- my $string = "";
- foreach my $msg ( @{$self->{recv_queue}} ) {
- $string = $string . $msg->toString(1) . "\n";
- }
- return $string;
-}
-
-sub status {
- my $self = shift;
- return unless $self;
- $self->send( 'STATUS', @_ );
-}
-
-sub reset_request_timeout {
- my $self = shift;
- my $tt = shift;
- my $req = $self->app_request($tt);
- $req->{remaining_recv_timeout} = $req->{recv_timeout};
- $req->{timout_reset} = 1;
-}
-
-#-------------------------------------------------------------------------------
-
-package OpenSRF::AppRequest;
-use base qw/OpenSRF::AppSession/;
-use OpenSRF::Utils::Logger qw/:level/;
-use OpenSRF::DomainObject::oilsResponse qw/:status/;
-use Time::HiRes qw/time usleep/;
-
-sub new {
- my $class = shift;
- $class = ref($class) || $class;
-
- my $session = shift;
- my $threadTrace = $session->session_threadTrace || $session->last_threadTrace;
- my $payload = shift;
-
- my $self = { session => $session,
- threadTrace => $threadTrace,
- payload => $payload,
- complete => 0,
- timeout_reset => 0,
- recv_timeout => 30,
- remaining_recv_timeout => 30,
- recv_queue => [],
- };
-
- bless $self => $class;
-
- push @{ $self->session->{request_queue} }, $self;
-
- return $self;
-}
-
-sub recv_timeout {
- my $self = shift;
- my $timeout = shift;
- if (defined $timeout) {
- $self->{recv_timeout} = $timeout;
- $self->{remaining_recv_timeout} = $timeout;
- }
- return $self->{recv_timeout};
-}
-
-sub queue_size {
- my $size = @{$_[0]->{recv_queue}};
- return $size;
-}
-
-sub send {
- my $self = shift;
- return unless ($self and $self->session and !$self->complete);
- $self->session->send(@_);
-}
-
-sub finish {
- my $self = shift;
- return unless $self->session;
- $self->session->remove_app_request($self);
- delete($$self{$_}) for (keys %$self);
-}
-
-sub session {
- return shift()->{session};
-}
-
-sub complete {
- my $self = shift;
- my $complete = shift;
- return $self->{complete} if ($self->{complete});
- if (defined $complete) {
- $self->{complete} = $complete;
- $self->{_duration} = time - $self->{_start} if ($self->{complete});
- } else {
- $self->session->queue_wait(0);
- }
- return $self->{complete};
-}
-
-sub duration {
- my $self = shift;
- $self->wait_complete;
- return $self->{_duration};
-}
-
-sub wait_complete {
- my $self = shift;
- my $timeout = shift || 10;
- my $time_remaining = $timeout;
-
- while ( ! $self->complete and $time_remaining > 0 ) {
- my $starttime = time;
- $self->queue_wait($time_remaining);
- my $endtime = time;
- $time_remaining -= ($endtime - $starttime);
- }
-
- return $self->complete;
-}
-
-sub threadTrace {
- return shift()->{threadTrace};
-}
-
-sub push_queue {
- my $self = shift;
- my $resp = shift;
- if( !$resp ) { return 0; }
- if( UNIVERSAL::isa($resp, "Error")) {
- $self->{failed} = $resp;
- $self->complete(1);
- #return; eventually...
- }
- push @{ $self->{recv_queue} }, $resp;
-}
-
-sub failed {
- my $self = shift;
- return $self->{failed};
-}
-
-sub queue_wait {
- my $self = shift;
- return $self->session->queue_wait(@_)
-}
-
-sub payload { return shift()->{payload}; }
-
-sub resend {
- my $self = shift;
- return unless ($self and $self->session and !$self->complete);
- OpenSRF::Utils::Logger->debug( "I'm resending the request for threadTrace ". $self->threadTrace, DEBUG);
- return $self->session->send('REQUEST', $self->payload, $self->threadTrace );
-}
-
-sub status {
- my $self = shift;
- my $msg = shift;
- return unless ($self and $self->session and !$self->complete);
- $self->session->send( 'STATUS',$msg, $self->threadTrace );
-}
-
-sub stream_push {
- my $self = shift;
- my $msg = shift;
- $self->respond( $msg );
-}
-
-sub respond {
- my $self = shift;
- my $msg = shift;
- return unless ($self and $self->session and !$self->complete);
-
- my $response;
- if (ref($msg) && UNIVERSAL::isa($msg, 'OpenSRF::DomainObject::oilsResult')) {
- $response = $msg;
- } else {
- $response = new OpenSRF::DomainObject::oilsResult;
- $response->content($msg);
- }
-
- $self->session->send('RESULT', $response, $self->threadTrace);
-}
-
-sub respond_complete {
- my $self = shift;
- my $msg = shift;
- return unless ($self and $self->session and !$self->complete);
-
- my $response;
- if (ref($msg) && UNIVERSAL::isa($msg, 'OpenSRF::DomainObject::oilsResult')) {
- $response = $msg;
- } else {
- $response = new OpenSRF::DomainObject::oilsResult;
- $response->content($msg);
- }
-
- my $stat = OpenSRF::DomainObject::oilsConnectStatus->new(
- statusCode => STATUS_COMPLETE(),
- status => 'Request Complete' );
-
-
- $self->session->send( 'RESULT' => $response, 'STATUS' => $stat, $self->threadTrace);
- $self->complete(1);
-}
-
-sub register_death_callback {
- my $self = shift;
- my $cb = shift;
- $self->session->register_callback( death => $cb );
-}
-
-
-# utility method. checks to see of the request failed.
-# if so, throws an OpenSRF::EX::ERROR. if everything is
-# ok, it returns the content of the request
-sub gather {
- my $self = shift;
- my $finish = shift;
- $self->wait_complete;
- my $resp = $self->recv( timeout => 60 );
- if( $self->failed() ) {
- throw OpenSRF::EX::ERROR
- ($self->failed()->stringify());
- }
- if(!$resp) { return undef; }
- my $content = $resp->content;
- if($finish) { $self->finish();}
- return $content;
-}
-
-
-package OpenSRF::AppSubrequest;
-
-sub respond {
- my $self = shift;
- my $resp = shift;
- push @{$$self{resp}}, $resp if (defined $resp);
-}
-sub respond_complete { respond(@_); }
-
-sub new {
- my $class = shift;
- $class = ref($class) || $class;
- return bless({resp => [], @_}, $class);
-}
-
-sub responses { @{$_[0]->{resp}} }
-
-sub session {
- my $x = shift;
- my $s = shift;
- $x->{session} = $s if ($s);
- return $x->{session};
-}
-
-sub status {}
-
-
-1;
-
+++ /dev/null
-package OpenSRF::Application;
-# vim:noet:ts=4
-use vars qw/$_app $log @_METHODS $thunk $server_class/;
-
-use base qw/OpenSRF/;
-use OpenSRF::AppSession;
-use OpenSRF::DomainObject::oilsMethod;
-use OpenSRF::DomainObject::oilsResponse qw/:status/;
-use OpenSRF::Utils::Logger qw/:level $logger/;
-use Data::Dumper;
-use Time::HiRes qw/time/;
-use OpenSRF::EX qw/:try/;
-use Carp;
-use OpenSRF::Utils::JSON;
-#use OpenSRF::UnixServer; # to get the server class from UnixServer::App
-
-sub DESTROY{};
-
-use strict;
-use warnings;
-
-$log = 'OpenSRF::Utils::Logger';
-
-our $in_request = 0;
-our @pending_requests;
-
-sub package {
- my $self = shift;
- return 1 unless ref($self);
- return $self->{package};
-}
-
-sub signature {
- my $self = shift;
- return 0 unless ref($self);
- return $self->{signature};
-}
-
-sub argc {
- my $self = shift;
- return 0 unless ref($self);
- return $self->{argc};
-}
-
-sub strict {
- my $self = shift;
- return 0 unless ref($self);
- return $self->{strict};
-}
-
-sub api_name {
- my $self = shift;
- return 1 unless ref($self);
- return $self->{api_name};
-}
-
-sub api_level {
- my $self = shift;
- return 1 unless ref($self);
- return $self->{api_level};
-}
-
-sub session {
- my $self = shift;
- my $session = shift;
-
- if($session) {
- $self->{session} = $session;
- }
- return $self->{session};
-}
-
-sub server_class {
- my $class = shift;
- if($class) {
- $server_class = $class;
- }
- return $server_class;
-}
-
-sub thunk {
- my $self = shift;
- my $flag = shift;
- $thunk = $flag if (defined $flag);
- return $thunk;
-}
-
-sub application_implementation {
- my $self = shift;
- my $app = shift;
-
- if (defined $app) {
- $_app = $app;
- $_app->use;
- if( $@ ) {
- $log->error( "Error loading application_implementation: $app -> $@", ERROR);
- }
-
- }
-
- return $_app;
-}
-
-sub handler {
- my ($self, $session, $app_msg) = @_;
-
- if( ! $app_msg ) {
- return 1; # error?
- }
-
- my $app = $self->application_implementation;
-
- if ($session->last_message_type eq 'REQUEST') {
-
- my @p = $app_msg->params;
- my $method_name = $app_msg->method;
- my $method_proto = $session->last_message_api_level;
- $log->info("CALL: $method_name [". (@p ? join(', ',@p) : '') ."]");
-
- my $coderef = $app->method_lookup( $method_name, $method_proto, 1, 1 );
-
- unless ($coderef) {
- $session->status( OpenSRF::DomainObject::oilsMethodException->new(
- statusCode => STATUS_NOTFOUND(),
- status => "Method [$method_name] not found for $app"));
- return 1;
- }
-
- unless ($session->continue_request) {
- $session->status(
- OpenSRF::DomainObject::oilsConnectStatus->new(
- statusCode => STATUS_REDIRECTED(),
- status => 'Disconnect on max requests' ) );
- $session->kill_me;
- return 1;
- }
-
- if (ref $coderef) {
- my @args = $app_msg->params;
- my $appreq = OpenSRF::AppRequest->new( $session );
-
- $log->debug( "in_request = $in_request : [" . $appreq->threadTrace."]", INTERNAL );
- if( $in_request ) {
- $log->debug( "Pushing onto pending requests: " . $appreq->threadTrace, DEBUG );
- push @pending_requests, [ $appreq, \@args, $coderef ];
- return 1;
- }
-
-
- $in_request++;
-
- $log->debug( "Executing coderef for {$method_name}", INTERNAL );
-
- my $resp;
- try {
- if ($coderef->strict) {
- if (@args < $coderef->argc) {
- die "Not enough params passed to ".
- $coderef->api_name." : requires ". $coderef->argc
- }
- if (@args) {
- my $sig = $coderef->signature;
- if ($sig && exists $sig->{params}) {
- for my $p (0 .. scalar(@{ $sig->{params} }) - 1 ) {
- my $s = $sig->{params}->[$p];
- my $a = $args[$p];
- if ($s->{class} && OpenSRF::Utils::JSON->lookup_hint(ref $a) ne $s->{class}) {
- die "Incorrect param class at position $p : should be a '$$s{class}'";
- } elsif ($s->{type}) {
- if (lc($s->{type}) eq 'object' && $a !~ /HASH/o) {
- die "Incorrect param type at position $p : should be an 'object'";
- } elsif (lc($s->{type}) eq 'array' && $a !~ /ARRAY/o) {
- die "Incorrect param type at position $p : should be an 'array'";
- } elsif (lc($s->{type}) eq 'number' && (ref($a) || $a !~ /^-?\d+(?:\.\d+)?$/o)) {
- die "Incorrect param type at position $p : should be a 'number'";
- } elsif (lc($s->{type}) eq 'string' && ref($a)) {
- die "Incorrect param type at position $p : should be a 'string'";
- }
- }
- }
- }
- }
- }
-
- my $start = time();
- $resp = $coderef->run( $appreq, @args);
- my $time = sprintf '%.3f', time() - $start;
-
- $log->debug( "Method duration for [$method_name]: ". $time );
- if( defined( $resp ) ) {
- $appreq->respond_complete( $resp );
- } else {
- $appreq->status( OpenSRF::DomainObject::oilsConnectStatus->new(
- statusCode => STATUS_COMPLETE(),
- status => 'Request Complete' ) );
- }
- } catch Error with {
- my $e = shift;
- warn "Caught error from 'run' method: $e\n";
-
- if(UNIVERSAL::isa($e,"Error")) {
- $e = $e->stringify();
- }
- my $sess_id = $session->session_id;
- $session->status(
- OpenSRF::DomainObject::oilsMethodException->new(
- statusCode => STATUS_INTERNALSERVERERROR(),
- status => " *** Call to [$method_name] failed for session ".
- "[$sess_id], thread trace ".
- "[".$appreq->threadTrace."]:\n$e\n"
- )
- );
- };
-
-
-
- # ----------------------------------------------
-
-
- # XXX may need this later
- # $_->[1] = 1 for (@OpenSRF::AppSession::_CLIENT_CACHE);
-
- $in_request--;
-
- $log->debug( "Pending Requests: " . scalar(@pending_requests), INTERNAL );
-
- # cycle through queued requests
- while( my $aref = shift @pending_requests ) {
- $in_request++;
- my $resp;
- try {
- # un-if(0) this block to enable param checking based on signature and argc
- if (0) {
- if (@args < $aref->[2]->argc) {
- die "Not enough params passed to ".
- $aref->[2]->api_name." : requires ". $aref->[2]->argc
- }
- if (@args) {
- my $sig = $aref->[2]->signature;
- if ($sig && exists $sig->{params}) {
- for my $p (0 .. scalar(@{ $sig->{params} }) - 1 ) {
- my $s = $sig->{params}->[$p];
- my $a = $args[$p];
- if ($s->{class} && OpenSRF::Utils::JSON->lookup_hint(ref $a) ne $s->{class}) {
- die "Incorrect param class at position $p : should be a '$$s{class}'";
- } elsif ($s->{type}) {
- if (lc($s->{type}) eq 'object' && $a !~ /HASH/o) {
- die "Incorrect param type at position $p : should be an 'object'";
- } elsif (lc($s->{type}) eq 'array' && $a !~ /ARRAY/o) {
- die "Incorrect param type at position $p : should be an 'array'";
- } elsif (lc($s->{type}) eq 'number' && (ref($a) || $a !~ /^-?\d+(?:\.\d+)?$/o)) {
- die "Incorrect param type at position $p : should be a 'number'";
- } elsif (lc($s->{type}) eq 'string' && ref($a)) {
- die "Incorrect param type at position $p : should be a 'string'";
- }
- }
- }
- }
- }
- }
-
- my $start = time;
- my $response = $aref->[2]->run( $aref->[0], @{$aref->[1]} );
- my $time = sprintf '%.3f', time - $start;
- $log->debug( "Method duration for [".$aref->[2]->api_name." -> ".join(', ',@{$aref->[1]}).']: '.$time, DEBUG );
-
- $appreq = $aref->[0];
- if( ref( $response ) ) {
- $appreq->respond_complete( $response );
- } else {
- $appreq->status( OpenSRF::DomainObject::oilsConnectStatus->new(
- statusCode => STATUS_COMPLETE(),
- status => 'Request Complete' ) );
- }
- $log->debug( "Executed: " . $appreq->threadTrace, INTERNAL );
- } catch Error with {
- my $e = shift;
- if(UNIVERSAL::isa($e,"Error")) {
- $e = $e->stringify();
- }
- $session->status(
- OpenSRF::DomainObject::oilsMethodException->new(
- statusCode => STATUS_INTERNALSERVERERROR(),
- status => "Call to [".$aref->[2]->api_name."] faild: $e"
- )
- );
- };
- $in_request--;
- }
-
- return 1;
- }
-
- $log->info("Received non-REQUEST message in Application handler");
-
- my $res = OpenSRF::DomainObject::oilsMethodException->new(
- status => "Received non-REQUEST message in Application handler");
- $session->send('ERROR', $res);
- $session->kill_me;
- return 1;
-
- } else {
- $session->push_queue([ $app_msg, $session->last_threadTrace ]);
- }
-
- $session->last_message_type('');
- $session->last_message_api_level('');
-
- return 1;
-}
-
-sub is_registered {
- my $self = shift;
- my $api_name = shift;
- my $api_level = shift || 1;
- return exists($_METHODS[$api_level]{$api_name});
-}
-
-
-sub normalize_whitespace {
- my $txt = shift;
-
- $txt =~ s/^\s+//gso;
- $txt =~ s/\s+$//gso;
- $txt =~ s/\s+/ /gso;
- $txt =~ s/\n//gso;
- $txt =~ s/\. /\. /gso;
-
- return $txt;
-}
-
-sub parse_string_signature {
- my $string = shift;
- return [] unless $string;
- my @chunks = split(/\@/smo, $string);
-
- my @params;
- my $ret;
- my $desc = '';
- for (@chunks) {
- if (/^return (.+)$/so) {
- $ret = [normalize_whitespace($1)];
- } elsif (/^param (\w+) \b(.+)$/so) {
- push @params, [ $1, normalize_whitespace($2) ];
- } else {
- $desc .= '@' if $desc;
- $desc .= $_;
- }
- }
-
- return [normalize_whitespace($desc),\@params, $ret];
-}
-
-sub parse_array_signature {
- my $array = shift;
- my ($d,$p,$r) = @$array;
- return {} unless ($d or $p or $r);
-
- return {
- desc => $d,
- params => [
- map {
- { name => $$_[0],
- desc => $$_[1],
- type => $$_[2],
- class => $$_[3],
- }
- } @$p
- ],
- 'return'=>
- { desc => $$r[0],
- type => $$r[1],
- class => $$r[2],
- }
- };
-}
-
-sub register_method {
- my $self = shift;
- my $app = ref($self) || $self;
- my %args = @_;
-
-
- throw OpenSRF::DomainObject::oilsMethodException unless ($args{method});
-
- $args{api_level} = 1 unless(defined($args{api_level}));
- $args{stream} ||= 0;
- $args{remote} ||= 0;
- $args{argc} ||= 0;
- $args{package} ||= $app;
- $args{server_class} = server_class();
- $args{api_name} ||= $args{server_class} . '.' . $args{method};
-
- # un-if(0) this block to enable signature parsing
- if (!$args{signature}) {
- if ($args{notes} && !ref($args{notes})) {
- $args{signature} =
- parse_array_signature( parse_string_signature( $args{notes} ) );
- }
- } elsif( !ref($args{signature}) ) {
- $args{signature} =
- parse_array_signature( parse_string_signature( $args{signature} ) );
- } elsif( ref($args{signature}) eq 'ARRAY') {
- $args{signature} =
- parse_array_signature( $args{signature} );
- }
-
- unless ($args{object_hint}) {
- ($args{object_hint} = $args{package}) =~ s/::/_/go;
- }
-
- OpenSRF::Utils::JSON->register_class_hint( name => $args{package}, hint => $args{object_hint}, type => "hash" );
-
- $_METHODS[$args{api_level}]{$args{api_name}} = bless \%args => $app;
-
- __PACKAGE__->register_method(
- stream => 0,
- argc => $args{argc},
- api_name => $args{api_name}.'.atomic',
- method => 'make_stream_atomic',
- notes => "This is a system generated method. Please see the definition for $args{api_name}",
- ) if ($args{stream});
-}
-
-sub retrieve_remote_apis {
- my $method = shift;
- my $session = OpenSRF::AppSession->create('router');
- try {
- $session->connect or OpenSRF::EX::WARN->throw("Connection to router timed out");
- } catch Error with {
- my $e = shift;
- $log->debug( "Remote subrequest returned an error:\n". $e );
- return undef;
- } finally {
- return undef unless ($session->state == $session->CONNECTED);
- };
-
- my $req = $session->request( 'opensrf.router.info.class.list' );
- my $list = $req->recv;
-
- if( UNIVERSAL::isa($list,"Error") ) {
- throw $list;
- }
-
- my $content = $list->content;
-
- $req->finish;
- $session->finish;
- $session->disconnect;
-
- my %u_list = map { ($_ => 1) } @$content;
-
- for my $class ( keys %u_list ) {
- next if($class eq $server_class);
- populate_remote_method_cache($class, $method);
- }
-}
-
-sub populate_remote_method_cache {
- my $class = shift;
- my $meth = shift;
-
- my $session = OpenSRF::AppSession->create($class);
- try {
- $session->connect or OpenSRF::EX::WARN->throw("Connection to $class timed out");
-
- my $call = 'opensrf.system.method.all' unless (defined $meth);
- $call = 'opensrf.system.method' if (defined $meth);
-
- my $req = $session->request( $call, $meth );
-
- while (my $method = $req->recv) {
- next if (UNIVERSAL::isa($method, 'Error'));
-
- $method = $method->content;
- next if ( exists($_METHODS[$$method{api_level}]) &&
- exists($_METHODS[$$method{api_level}]{$$method{api_name}}) );
- $method->{remote} = 1;
- bless($method, __PACKAGE__ );
- $_METHODS[$$method{api_level}]{$$method{api_name}} = $method;
- }
-
- $req->finish;
- $session->finish;
- $session->disconnect;
-
- } catch Error with {
- my $e = shift;
- $log->debug( "Remote subrequest returned an error:\n". $e );
- return undef;
- };
-}
-
-sub method_lookup {
- my $self = shift;
- my $method = shift;
- my $proto = shift;
- my $no_recurse = shift || 0;
- my $no_remote = shift || 0;
-
- # this instead of " || 1;" above to allow api_level 0
- $proto = $self->api_level unless (defined $proto);
-
- my $class = ref($self) || $self;
-
- $log->debug("Lookup of [$method] by [$class] in api_level [$proto]", DEBUG);
- $log->debug("Available methods\n\t".join("\n\t", keys %{ $_METHODS[$proto] }), INTERNAL);
-
- my $meth;
- if (__PACKAGE__->thunk) {
- for my $p ( reverse(1 .. $proto) ) {
- if (exists $_METHODS[$p]{$method}) {
- $meth = $_METHODS[$p]{$method};
- }
- }
- } else {
- if (exists $_METHODS[$proto]{$method}) {
- $meth = $_METHODS[$proto]{$method};
- }
- }
-
- if (defined $meth) {
- if($no_remote and $meth->{remote}) {
- $log->debug("OH CRAP We're not supposed to return remote methods", WARN);
- return undef;
- }
-
- } elsif (!$no_recurse) {
- $log->debug("We didn't find [$method], asking everyone else.", DEBUG);
- retrieve_remote_apis($method);
- $meth = $self->method_lookup($method,$proto,1);
- }
-
- return $meth;
-}
-
-sub run {
- my $self = shift;
- my $req = shift;
-
- my $resp;
- my @params = @_;
-
- if ( !UNIVERSAL::isa($req, 'OpenSRF::AppRequest') ) {
- $log->debug("Creating a SubRequest object", DEBUG);
- unshift @params, $req;
- $req = OpenSRF::AppSubrequest->new;
- $req->session( $self->session ) if ($self->session);
-
- } else {
- $log->debug("This is a top level request", DEBUG);
- }
-
- if (!$self->{remote}) {
- my $code = \&{$self->{package} . '::' . $self->{method}};
- my $err = undef;
-
- try {
- $resp = $code->($self, $req, @params);
-
- } catch Error with {
- $err = shift;
-
- if( ref($self) eq 'HASH') {
- $log->error("Sub $$self{package}::$$self{method} DIED!!!\n\t$err\n", ERROR);
- }
- };
-
- if($err) {
- if(UNIVERSAL::isa($err,"Error")) {
- throw $err;
- } else {
- die $err->stringify;
- }
- }
-
-
- $log->debug("Coderef for [$$self{package}::$$self{method}] has been run", DEBUG);
-
- if ( ref($req) and UNIVERSAL::isa($req, 'OpenSRF::AppSubrequest') ) {
- $req->respond($resp) if (defined $resp);
- $log->debug("SubRequest object is responding with : " . join(" ",$req->responses), DEBUG);
- return $req->responses;
- } else {
- $log->debug("A top level Request object is responding $resp", DEBUG) if (defined $resp);
- return $resp;
- }
- } else {
- my $session = OpenSRF::AppSession->create($self->{server_class});
- try {
- #$session->connect or OpenSRF::EX::WARN->throw("Connection to [$$self{server_class}] timed out");
- my $remote_req = $session->request( $self->{api_name}, @params );
- while (my $remote_resp = $remote_req->recv) {
- OpenSRF::Utils::Logger->debug("Remote Subrequest Received " . $remote_resp, INTERNAL );
- if( UNIVERSAL::isa($remote_resp,"Error") ) {
- throw $remote_resp;
- }
- $req->respond( $remote_resp->content );
- }
- $remote_req->finish();
-
- } catch Error with {
- my $e = shift;
- $log->debug( "Remote subrequest returned an error:\n". $e );
- return undef;
- };
-
- if ($session) {
- $session->disconnect();
- $session->finish();
- }
-
- $log->debug( "Remote Subrequest Responses " . join(" ", $req->responses), INTERNAL );
-
- return $req->responses;
- }
- # huh? how'd we get here...
- return undef;
-}
-
-sub introspect {
- my $self = shift;
- my $client = shift;
- my $method = shift;
- my $limit = shift;
- my $offset = shift;
-
- if ($self->api_name =~ /all$/o) {
- $offset = $limit;
- $limit = $method;
- $method = undef;
- }
-
- my ($seen,$returned) = (0,0);
- for my $api_level ( reverse(1 .. $#_METHODS) ) {
- for my $api_name ( sort keys %{$_METHODS[$api_level]} ) {
- if (!$offset || $offset <= $seen) {
- if (!$_METHODS[$api_level]{$api_name}{remote}) {
- if (defined($method)) {
- if ($api_name =~ $method) {
- if (!$limit || $returned < $limit) {
- $client->respond( $_METHODS[$api_level]{$api_name} );
- $returned++;
- }
- }
- } else {
- if (!$limit || $returned < $limit) {
- $client->respond( $_METHODS[$api_level]{$api_name} );
- $returned++;
- }
- }
- }
- }
- $seen++;
- }
- }
-
- return undef;
-}
-__PACKAGE__->register_method(
- stream => 1,
- method => 'introspect',
- api_name => 'opensrf.system.method.all',
- argc => 0,
- signature => {
- desc => q/This method is used to introspect an entire OpenSRF Application/,
- return => {
- desc => q/A stream of objects describing the methods available via this OpenSRF Application/,
- type => 'object'
- }
- },
-);
-__PACKAGE__->register_method(
- stream => 1,
- method => 'introspect',
- argc => 1,
- api_name => 'opensrf.system.method',
- argc => 1,
- signature => {
- desc => q/Use this method to get the definition of a single OpenSRF Method/,
- params => [
- { desc => q/The method to introspect/,
- type => 'string' },
- ],
- return => { desc => q/An object describing the method requested, or an error if it can't be found/,
- type => 'object' }
- },
-);
-
-sub echo_method {
- my $self = shift;
- my $client = shift;
- my @args = @_;
-
- $client->respond( $_ ) for (@args);
- return undef;
-}
-__PACKAGE__->register_method(
- stream => 1,
- method => 'echo_method',
- argc => 1,
- api_name => 'opensrf.system.echo',
- signature => {
- desc => q/A test method that will echo back it's arguments in a streaming response/,
- params => [
- { desc => q/One or more arguments to echo back/ }
- ],
- return => { desc => q/A stream of the arguments passed/ }
- },
-);
-
-sub time_method {
- my( $self, $conn ) = @_;
- return CORE::time;
-}
-__PACKAGE__->register_method(
- method => 'time_method',
- argc => 0,
- api_name => 'opensrf.system.time',
- signature => {
- desc => q/Returns the current system time as epoch seconds/,
- return => { desc => q/epoch seconds/ }
- }
-);
-
-sub make_stream_atomic {
- my $self = shift;
- my $req = shift;
- my @args = @_;
-
- (my $m_name = $self->api_name) =~ s/\.atomic$//o;
- my $m = $self->method_lookup($m_name);
-
- $m->session( $req->session );
- my @results = $m->run(@args);
- $m->session('');
-
- return \@results;
-}
-
-
-1;
-
-
+++ /dev/null
-package OpenSRF::App::Client;
-use base 'OpenSRF::Application';
-use OpenSRF::Utils::Logger qw/:level/;
-
-
-1;
+++ /dev/null
-package OpenSRF::Application::Demo::Math;
-use base qw/OpenSRF::Application/;
-use OpenSRF::Application;
-use OpenSRF::Utils::Logger qw/:level/;
-use OpenSRF::DomainObject::oilsResponse;
-use OpenSRF::EX qw/:try/;
-use strict;
-use warnings;
-
-
-sub DESTROY{}
-
-our $log = 'OpenSRF::Utils::Logger';
-
-sub send_request {
- my $self = shift;
- my $client = shift;
-
- my $method_name = shift;
- my @params = @_;
-
- my $session = OpenSRF::AppSession->create( "opensrf.dbmath" );
- my $request = $session->request( "dbmath.$method_name", @params );
- my $response = $request->recv();
- if(!$response) { return undef; }
- if($response->isa("Error")) {throw $response ($response->stringify);}
- $session->finish();
-
- return $response->content;
-
-}
-__PACKAGE__->register_method( method => 'send_request', api_name => '_send_request' );
-
-__PACKAGE__->register_method( method => 'add_1', api_name => 'add' );
-sub add_1 {
- my $self = shift;
- my $client = shift;
- my @args = @_;
-
- my $meth = $self->method_lookup('_send_request');
- my ($result) = $meth->run('add',@args);
-
- return $result;
-}
-
-__PACKAGE__->register_method( method => 'sub_1', api_name => 'sub' );
-sub sub_1 {
- my $self = shift;
- my $client = shift;
- my @args = @_;
-
- my $meth = $self->method_lookup('_send_request');
- my ($result) = $meth->run('sub',@args);
-
- return $result;
-}
-
-__PACKAGE__->register_method( method => 'mult_1', api_name => 'mult' );
-sub mult_1 {
- my $self = shift;
- my $client = shift;
- my @args = @_;
-
- my $meth = $self->method_lookup('_send_request');
- my ($result) = $meth->run('mult',@args);
-
- return $result;
-}
-
-__PACKAGE__->register_method( method => 'div_1', api_name => 'div' );
-sub div_1 {
- my $self = shift;
- my $client = shift;
- my @args = @_;
-
- my $meth = $self->method_lookup('_send_request');
- my ($result) = $meth->run('div',@args);
-
- return $result;
-}
-
-
-1;
+++ /dev/null
-package OpenSRF::Application::Demo::MathDB;
-use OpenSRF::Utils::JSON;
-use base qw/OpenSRF::Application/;
-use OpenSRF::Application;
-use OpenSRF::DomainObject::oilsResponse qw/:status/;
-use OpenSRF::Utils::Logger qw/:level/;
-use strict;
-use warnings;
-
-sub DESTROY{}
-our $log = 'OpenSRF::Utils::Logger';
-sub initialize {}
-
-__PACKAGE__->register_method( method => 'add_1', api_name => 'dbmath.add' );
-sub add_1 {
- my $self = shift;
- my $client = shift;
-
- my $n1 = shift;
- my $n2 = shift;
- my $a = $n1 + $n2;
- return OpenSRF::Utils::JSON::number->new($a);
-}
-
-__PACKAGE__->register_method( method => 'sub_1', api_name => 'dbmath.sub' );
-sub sub_1 {
- my $self = shift;
- my $client = shift;
-
- my $n1 = shift;
- my $n2 = shift;
- my $a = $n1 - $n2;
- return OpenSRF::Utils::JSON::number->new($a);
-}
-
-__PACKAGE__->register_method( method => 'mult_1', api_name => 'dbmath.mult' );
-sub mult_1 {
- my $self = shift;
- my $client = shift;
-
- my $n1 = shift;
- my $n2 = shift;
- my $a = $n1 * $n2;
- return OpenSRF::Utils::JSON::number->new($a);
-}
-
-__PACKAGE__->register_method( method => 'div_1', api_name => 'dbmath.div' );
-sub div_1 {
- my $self = shift;
- my $client = shift;
-
- my $n1 = shift;
- my $n2 = shift;
- my $a = $n1 / $n2;
- return OpenSRF::Utils::JSON::number->new($a);
-}
-
-1;
+++ /dev/null
-package OpenSRF::Application::Persist;
-use base qw/OpenSRF::Application/;
-use OpenSRF::Application;
-
-use OpenSRF::Utils::SettingsClient;
-use OpenSRF::EX qw/:try/;
-use OpenSRF::Utils qw/:common/;
-use OpenSRF::Utils::Logger;
-use OpenSRF::Utils::JSON;
-use DBI;
-
-use vars qw/$dbh $log $default_expire_time/;
-
-sub initialize {
- $log = 'OpenSRF::Utils::Logger';
-
- $sc = OpenSRF::Utils::SettingsClient->new;
-
- my $dbfile = $sc->config_value( apps => 'opensrf.persist' => app_settings => 'dbfile');
- unless ($dbfile) {
- throw OpenSRF::EX::PANIC ("Can't find my dbfile for SQLite!");
- }
-
- my $init_dbh = DBI->connect("dbi:SQLite:dbname=$dbfile","","");
- $init_dbh->{AutoCommit} = 1;
- $init_dbh->{RaiseError} = 0;
-
- $init_dbh->do( <<" SQL" );
- CREATE TABLE storage (
- id INTEGER PRIMARY KEY,
- name_id INTEGER,
- value TEXT
- );
- SQL
-
- $init_dbh->do( <<" SQL" );
- CREATE TABLE store_name (
- id INTEGER PRIMARY KEY,
- name TEXT UNIQUE
- );
- SQL
-
- $init_dbh->do( <<" SQL" );
- CREATE TABLE store_expire (
- id INTEGER PRIMARY KEY,
- atime INTEGER,
- expire_interval INTEGER
- );
- SQL
-
-}
-
-sub child_init {
- my $sc = OpenSRF::Utils::SettingsClient->new;
-
- $default_expire_time = $sc->config_value( apps => 'opensrf.persist' => app_settings => 'default_expire_time' );
- $default_expire_time ||= 300;
-
- my $dbfile = $sc->config_value( apps => 'opensrf.persist' => app_settings => 'dbfile');
- unless ($dbfile) {
- throw OpenSRF::EX::PANIC ("Can't find my dbfile for SQLite!");
- }
-
- $dbh = DBI->connect("dbi:SQLite:dbname=$dbfile","","");
- $dbh->{AutoCommit} = 1;
- $dbh->{RaiseError} = 0;
-
-}
-
-sub create_store {
- my $self = shift;
- my $client = shift;
-
- my $name = shift || '';
-
- try {
-
- my $continue = 0;
- try {
- _get_name_id($name);
-
- } catch Error with {
- $continue++;
- };
-
- throw OpenSRF::EX::WARN ("Duplicate key: object name [$name] already exists! " . $dbh->errstr)
- unless ($continue);
-
- my $sth = $dbh->prepare("INSERT INTO store_name (name) VALUES (?);");
- $sth->execute($name);
- $sth->finish;
-
- unless ($name) {
- my $last_id = $dbh->last_insert_id(undef, undef, 'store_name', 'id');
- $name = 'AUTOGENERATED!!'.$last_id;
- $dbh->do("UPDATE store_name SET name = '$name' WHERE id = '$last_id';");
- }
-
- _flush_by_name($name);
- return $name;
- } catch Error with {
- return undef;
- };
-}
-__PACKAGE__->register_method(
- api_name => 'opensrf.persist.slot.create',
- method => 'create_store',
- argc => 1,
-);
-
-
-sub create_expirable_store {
- my $self = shift;
- my $client = shift;
- my $name = shift || do { throw OpenSRF::EX::InvalidArg ("Expirable slots must be given a name!") };
- my $time = shift || $default_expire_time;
-
- try {
- ($name) = $self->method_lookup( 'opensrf.persist.slot.create' )->run( $name );
- return undef unless $name;
-
- $self->method_lookup('opensrf.persist.slot.set_expire')->run($name, $time);
- return $name;
- } catch Error with {
- return undef;
- };
-
-}
-__PACKAGE__->register_method(
- api_name => 'opensrf.persist.slot.create_expirable',
- method => 'create_expirable_store',
- argc => 2,
-);
-
-sub _update_expire_atime {
- my $id = shift;
- $dbh->do('UPDATE store_expire SET atime = ? WHERE id = ?', {}, time(), $id);
-}
-
-sub set_expire_interval {
- my $self = shift;
- my $client = shift;
- my $slot = shift;
- my $new_interval = shift;
-
- try {
- my $etime = interval_to_seconds($new_interval);
- my $sid = _get_name_id($slot);
-
- $dbh->do('DELETE FROM store_expire where id = ?', {}, $sid);
- return 0 if ($etime == 0);
-
- $dbh->do('INSERT INTO store_expire (id, atime, expire_interval) VALUES (?,?,?);',{},$sid,time(),$etime);
- return $etime;
- }
-}
-__PACKAGE__->register_method(
- api_name => 'opensrf.persist.slot.set_expire',
- method => 'set_expire_interval',
- argc => 2,
-);
-
-sub find_slot {
- my $self = shift;
- my $client = shift;
- my $slot = shift;
-
- my $sid = _get_name_id($slot);
- return $slot if ($sid);
- return undef;
-}
-__PACKAGE__->register_method(
- api_name => 'opensrf.persist.slot.find',
- method => 'find_slot',
- argc => 2,
-);
-
-sub get_expire_interval {
- my $self = shift;
- my $client = shift;
- my $slot = shift;
-
- my $sid = _get_name_id($slot);
- my ($int) = $dbh->selectrow_array('SELECT expire_interval FROM store_expire WHERE id = ?;',{},$sid);
- return undef unless ($int);
-
- my ($future) = $dbh->selectrow_array('SELECT atime + expire_interval FROM store_expire WHERE id = ?;',{},$sid);
- return $future - time();
-}
-__PACKAGE__->register_method(
- api_name => 'opensrf.persist.slot.get_expire',
- method => 'get_expire_interval',
- argc => 2,
-);
-
-
-sub _sweep_expired_slots {
- return if (shift());
-
- my $expired_slots = $dbh->selectcol_arrayref(<<" SQL", {}, time() );
- SELECT id FROM store_expire WHERE (atime + expire_interval) <= ?;
- SQL
-
- return unless ($expired_slots);
-
- $dbh->do('DELETE FROM storage WHERE name_id IN ('.join(',', map { '?' } @$expired_slots).');', {}, @$expired_slots);
- $dbh->do('DELETE FROM store_expire WHERE id IN ('.join(',', map { '?' } @$expired_slots).');', {}, @$expired_slots);
- for my $id (@$expired_slots) {
- _flush_by_name(_get_id_name($id), 1);
- }
-}
-
-sub add_item {
- my $self = shift;
- my $client = shift;
-
- my $name = shift or do {
- throw OpenSRF::EX::WARN ("No name specified!");
- };
-
- my $value = shift || '';
-
- try {
- my $name_id = _get_name_id($name);
-
- if ($self->api_name =~ /object/) {
- $dbh->do('DELETE FROM storage WHERE name_id = ?;', {}, $name_id);
- }
-
- $dbh->do('INSERT INTO storage (name_id,value) VALUES (?,?);', {}, $name_id, OpenSRF::Utils::JSON->perl2JSON($value));
-
- _flush_by_name($name);
-
- return $name;
- } catch Error with {
- return undef;
- };
-}
-__PACKAGE__->register_method(
- api_name => 'opensrf.persist.object.set',
- method => 'add_item',
- argc => 2,
-);
-__PACKAGE__->register_method(
- api_name => 'opensrf.persist.queue.push',
- method => 'add_item',
- argc => 2,
-);
-__PACKAGE__->register_method(
- api_name => 'opensrf.persist.stack.push',
- method => 'add_item',
- argc => 2,
-);
-
-sub _get_id_name {
- my $name = shift or do {
- throw OpenSRF::EX::WARN ("No slot id specified!");
- };
-
-
- my $name_id = $dbh->selectcol_arrayref("SELECT name FROM store_name WHERE id = ?;", {}, $name);
-
- if (!ref($name_id) || !defined($name_id->[0])) {
- throw OpenSRF::EX::WARN ("Slot id [$name] does not exist!");
- }
-
- return $name_id->[0];
-}
-
-sub _get_name_id {
- my $name = shift or do {
- throw OpenSRF::EX::WARN ("No slot name specified!");
- };
-
-
- my $name_id = $dbh->selectrow_arrayref("SELECT id FROM store_name WHERE name = ?;", {}, $name);
-
- if (!ref($name_id) || !defined($name_id->[0])) {
- throw OpenSRF::EX::WARN ("Slot name [$name] does not exist!");
- }
-
- return $name_id->[0];
-}
-
-sub destroy_store {
- my $self = shift;
- my $client = shift;
-
- my $name = shift;
-
- my $problem = 0;
- try {
- my $name_id = _get_name_id($name);
-
- $dbh->do("DELETE FROM storage WHERE name_id = ?;", {}, $name_id);
- $dbh->do("DELETE FROM store_name WHERE id = ?;", {}, $name_id);
- $dbh->do("DELETE FROM store_expire WHERE id = ?;", {}, $name_id);
-
- _sweep_expired_slots();
- return $name;
- } catch Error with {
- return undef;
- };
-
-}
-__PACKAGE__->register_method(
- api_name => 'opensrf.persist.slot.destroy',
- method => 'destroy_store',
- argc => 1,
-);
-
-sub _flush_by_name {
- my $name = shift;
- my $no_sweep = shift;
-
- my $name_id = _get_name_id($name);
-
- unless ($no_sweep) {
- _update_expire_atime($name);
- _sweep_expired_slots();
- }
-
- if ($name =~ /^AUTOGENERATED!!/) {
- my $count = $dbh->selectcol_arrayref("SELECT COUNT(*) FROM storage WHERE name_id = ?;", {}, $name_id);
- if (!ref($count) || $$count[0] == 0) {
- $dbh->do("DELETE FROM store_name WHERE name = ?;", {}, $name);
- }
- }
-}
-
-sub pop_queue {
- my $self = shift;
- my $client = shift;
-
- my $name = shift or do {
- throw OpenSRF::EX::WARN ("No queue name specified!");
- };
-
- try {
- my $name_id = _get_name_id($name);
-
- my $value = $dbh->selectrow_arrayref('SELECT id, value FROM storage WHERE name_id = ? ORDER BY id ASC LIMIT 1;', {}, $name_id);
- $dbh->do('DELETE FROM storage WHERE id = ?;',{}, $value->[0]) unless ($self->api_name =~ /peek$/);
-
- _flush_by_name($name);
-
- return OpenSRF::Utils::JSON->JSON2perl( $value->[1] );
- } catch Error with {
- #my $e = shift;
- #return $e;
- return undef;
- };
-}
-__PACKAGE__->register_method(
- api_name => 'opensrf.persist.queue.peek',
- method => 'pop_queue',
- argc => 1,
-);
-__PACKAGE__->register_method(
- api_name => 'opensrf.persist.queue.pop',
- method => 'pop_queue',
- argc => 1,
-);
-
-
-sub peek_slot {
- my $self = shift;
- my $client = shift;
-
- my $name = shift or do {
- throw OpenSRF::EX::WARN ("No slot name specified!");
- };
- my $name_id = _get_name_id($name);
-
- my $order = 'ASC';
- $order = 'DESC' if ($self->api_name =~ /stack/o);
-
- my $values = $dbh->selectall_arrayref("SELECT value FROM storage WHERE name_id = ? ORDER BY id $order;", {}, $name_id);
-
- $client->respond( OpenSRF::Utils::JSON->JSON2perl( $_->[0] ) ) for (@$values);
-
- _flush_by_name($name);
- return undef;
-}
-__PACKAGE__->register_method(
- api_name => 'opensrf.persist.queue.peek.all',
- method => 'peek_slot',
- argc => 1,
- stream => 1,
-);
-__PACKAGE__->register_method(
- api_name => 'opensrf.persist.stack.peek.all',
- method => 'peek_slot',
- argc => 1,
- stream => 1,
-);
-
-
-sub store_size {
- my $self = shift;
- my $client = shift;
-
- my $name = shift or do {
- throw OpenSRF::EX::WARN ("No queue name specified!");
- };
- my $name_id = _get_name_id($name);
-
- my $value = $dbh->selectcol_arrayref('SELECT SUM(LENGTH(value)) FROM storage WHERE name_id = ?;', {}, $name_id);
-
- return OpenSRF::Utils::JSON->JSON2perl( $value->[0] );
-}
-__PACKAGE__->register_method(
- api_name => 'opensrf.persist.queue.size',
- method => 'shift_stack',
- argc => 1,
-);
-__PACKAGE__->register_method(
- api_name => 'opensrf.persist.stack.size',
- method => 'shift_stack',
- argc => 1,
-);
-__PACKAGE__->register_method(
- api_name => 'opensrf.persist.object.size',
- method => 'shift_stack',
- argc => 1,
-);
-
-sub store_depth {
- my $self = shift;
- my $client = shift;
-
- my $name = shift or do {
- throw OpenSRF::EX::WARN ("No queue name specified!");
- };
- my $name_id = _get_name_id($name);
-
- my $value = $dbh->selectcol_arrayref('SELECT COUNT(*) FROM storage WHERE name_id = ?;', {}, $name_id);
-
- return OpenSRF::Utils::JSON->JSON2perl( $value->[0] );
-}
-__PACKAGE__->register_method(
- api_name => 'opensrf.persist.queue.length',
- method => 'shift_stack',
- argc => 1,
-);
-__PACKAGE__->register_method(
- api_name => 'opensrf.persist.stack.depth',
- method => 'shift_stack',
- argc => 1,
-);
-
-sub shift_stack {
- my $self = shift;
- my $client = shift;
-
- my $name = shift or do {
- throw OpenSRF::EX::WARN ("No slot name specified!");
- };
-
- try {
- my $name_id = _get_name_id($name);
-
- my $value = $dbh->selectrow_arrayref('SELECT id, value FROM storage WHERE name_id = ? ORDER BY id DESC LIMIT 1;', {}, $name_id);
- $dbh->do('DELETE FROM storage WHERE id = ?;',{}, $value->[0]) unless ($self->api_name =~ /peek$/);
-
- _flush_by_name($name);
-
- return OpenSRF::Utils::JSON->JSON2perl( $value->[1] );
- } catch Error with {
- my $e = shift;
- return undef;
- };
-}
-__PACKAGE__->register_method(
- api_name => 'opensrf.persist.stack.peek',
- method => 'shift_stack',
- argc => 1,
-);
-__PACKAGE__->register_method(
- api_name => 'opensrf.persist.stack.pop',
- method => 'shift_stack',
- argc => 1,
-);
-
-sub get_object {
- my $self = shift;
- my $client = shift;
-
- my $name = shift or do {
- throw OpenSRF::EX::WARN ("No object name specified!");
- };
-
- try {
- my $name_id = _get_name_id($name);
-
- my $value = $dbh->selectrow_arrayref('SELECT name_id, value FROM storage WHERE name_id = ? ORDER BY id DESC LIMIT 1;', {}, $name_id);
- $dbh->do('DELETE FROM storage WHERE name_id = ?',{}, $value->[0]) unless ($self->api_name =~ /peek$/);
-
- _flush_by_name($name);
-
- return OpenSRF::Utils::JSON->JSON2perl( $value->[1] );
- } catch Error with {
- return undef;
- };
-}
-__PACKAGE__->register_method(
- api_name => 'opensrf.persist.object.peek',
- method => 'shift_stack',
- argc => 1,
-);
-__PACKAGE__->register_method(
- api_name => 'opensrf.persist.object.get',
- method => 'shift_stack',
- argc => 1,
-);
-
-1;
+++ /dev/null
-package OpenSRF::Application::Settings;
-use OpenSRF::Application;
-use OpenSRF::Utils::SettingsParser;
-use OpenSRF::Utils::Logger qw/$logger/;
-use base 'OpenSRF::Application';
-
-sub child_exit {
- $logger->debug("settings server child exiting...$$");
-}
-
-
-__PACKAGE__->register_method( method => 'get_host_config', api_name => 'opensrf.settings.host_config.get' );
-sub get_host_config {
- my( $self, $client, $host ) = @_;
- my $parser = OpenSRF::Utils::SettingsParser->new();
- return $parser->get_server_config($host);
-}
-
-__PACKAGE__->register_method( method => 'get_default_config', api_name => 'opensrf.settings.default_config.get' );
-sub get_default_config {
- my( $self, $client ) = @_;
- my $parser = OpenSRF::Utils::SettingsParser->new();
- return $parser->get_default_config();
-}
-
-
-
-
-__PACKAGE__->register_method( method => 'xpath_get', api_name => 'opensrf.settings.xpath.get' );
-
-__PACKAGE__->register_method(
- method => 'xpath_get',
- api_name => 'opensrf.settings.xpath.get.raw' );
-
-sub xpath_get {
- my($self, $client, $xpath) = @_;
- warn "*************** Received XPATH $xpath\n";
- return OpenSRF::Utils::SettingsParser->new()->_get_all( $xpath );
-}
-
-
-1;
+++ /dev/null
-package OpenSRF::DomainObject::oilsMessage;
-use OpenSRF::Utils::JSON;
-use OpenSRF::AppSession;
-use OpenSRF::DomainObject::oilsResponse qw/:status/;
-use OpenSRF::Utils::Logger qw/:level/;
-use warnings; use strict;
-use OpenSRF::EX qw/:try/;
-
-OpenSRF::Utils::JSON->register_class_hint(hint => 'osrfMessage', name => 'OpenSRF::DomainObject::oilsMessage', type => 'hash');
-
-sub toString {
- my $self = shift;
- my $pretty = shift;
- return OpenSRF::Utils::JSON->perl2prettyJSON($self) if ($pretty);
- return OpenSRF::Utils::JSON->perl2JSON($self);
-}
-
-sub new {
- my $self = shift;
- my $class = ref($self) || $self;
- my %args = @_;
- return bless \%args => $class;
-}
-
-
-=head1 NAME
-
-OpenSRF::DomainObject::oilsMessage
-
-=head1
-
-use OpenSRF::DomainObject::oilsMessage;
-
-my $msg = OpenSRF::DomainObject::oilsMessage->new( type => 'CONNECT' );
-
-$msg->payload( $domain_object );
-
-=head1 ABSTRACT
-
-OpenSRF::DomainObject::oilsMessage is used internally to wrap data sent
-between client and server. It provides the structure needed to authenticate
-session data, and also provides the logic needed to unwrap session data and
-pass this information along to the Application Layer.
-
-=cut
-
-my $log = 'OpenSRF::Utils::Logger';
-
-=head1 METHODS
-
-=head2 OpenSRF::DomainObject::oilsMessage->type( [$new_type] )
-
-=over 4
-
-Used to specify the type of message. One of
-B<CONNECT, REQUEST, RESULT, STATUS, ERROR, or DISCONNECT>.
-
-=back
-
-=cut
-
-sub type {
- my $self = shift;
- my $val = shift;
- $self->{type} = $val if (defined $val);
- return $self->{type};
-}
-
-=head2 OpenSRF::DomainObject::oilsMessage->api_level( [$new_api_level] )
-
-=over 4
-
-Used to specify the api_level of message. Currently, only api_level C<1> is
-supported. This will be used to check that messages are well-formed, and as
-a hint to the Application as to which version of a method should fulfill a
-REQUEST message.
-
-=back
-
-=cut
-
-sub api_level {
- my $self = shift;
- my $val = shift;
- $self->{api_level} = $val if (defined $val);
- return $self->{api_level};
-}
-
-=head2 OpenSRF::DomainObject::oilsMessage->sender_locale( [$locale] );
-
-=over 4
-
-Sets or gets the current message locale hint. Useful for telling the
-server how you see the world.
-
-=back
-
-=cut
-
-sub sender_locale {
- my $self = shift;
- my $val = shift;
- $self->{locale} = $val if (defined $val);
- return $self->{locale};
-}
-
-=head2 OpenSRF::DomainObject::oilsMessage->threadTrace( [$new_threadTrace] );
-
-=over 4
-
-Sets or gets the current message sequence identifier, or thread trace number,
-for a message. Useful as a debugging aid, but that's about it.
-
-=back
-
-=cut
-
-sub threadTrace {
- my $self = shift;
- my $val = shift;
- $self->{threadTrace} = $val if (defined $val);
- return $self->{threadTrace};
-}
-
-=head2 OpenSRF::DomainObject::oilsMessage->update_threadTrace
-
-=over 4
-
-Increments the threadTrace component of a message. This is automatic when
-using the normal session processing stack.
-
-=back
-
-=cut
-
-sub update_threadTrace {
- my $self = shift;
- my $tT = $self->threadTrace;
-
- $tT ||= 0;
- $tT++;
-
- $log->debug("Setting threadTrace to $tT",DEBUG);
-
- $self->threadTrace($tT);
-
- return $tT;
-}
-
-=head2 OpenSRF::DomainObject::oilsMessage->payload( [$new_payload] )
-
-=over 4
-
-Sets or gets the payload of a message. This should be exactly one object
-of (sub)type domainObject or domainObjectCollection.
-
-=back
-
-=cut
-
-sub payload {
- my $self = shift;
- my $val = shift;
- $self->{payload} = $val if (defined $val);
- return $self->{payload};
-}
-
-=head2 OpenSRF::DomainObject::oilsMessage->handler( $session_id )
-
-=over 4
-
-Used by the message processing stack to set session state information from the current
-message, and then sends control (via the payload) to the Application layer.
-
-=back
-
-=cut
-
-sub handler {
- my $self = shift;
- my $session = shift;
-
- my $mtype = $self->type;
- my $locale = $self->sender_locale || '';
- my $api_level = $self->api_level || 1;
- my $tT = $self->threadTrace;
-
- $log->debug("Message locale is $locale", DEBUG);
-
- $session->last_message_type($mtype);
- $session->last_message_api_level($api_level);
- $session->last_threadTrace($tT);
- $session->session_locale($locale);
-
- $log->debug(" Received api_level => [$api_level], MType => [$mtype], ".
- "from [".$session->remote_id."], threadTrace[".$self->threadTrace."]");
-
- my $val;
- if ( $session->endpoint == $session->SERVER() ) {
- $val = $self->do_server( $session, $mtype, $api_level, $tT );
-
- } elsif ($session->endpoint == $session->CLIENT()) {
- $val = $self->do_client( $session, $mtype, $api_level, $tT );
- }
-
- if( $val ) {
- return OpenSRF::Application->handler($session, $self->payload);
- } else {
- $log->debug("Request was handled internally", DEBUG);
- }
-
- return 1;
-
-}
-
-
-
-# handle server side message processing
-
-# !!! Returning 0 means that we don't want to pass ourselves up to the message layer !!!
-sub do_server {
- my( $self, $session, $mtype, $api_level, $tT ) = @_;
-
- # A Server should never receive STATUS messages. If so, we drop them.
- # This is to keep STATUS's from dead client sessions from creating new server
- # sessions which send mangled session exceptions to backends for messages
- # that they are not aware of any more.
- if( $mtype eq 'STATUS' ) { return 0; }
-
-
- if ($mtype eq 'DISCONNECT') {
- $session->disconnect;
- $session->kill_me;
- return 0;
- }
-
- if ($session->state == $session->CONNECTING()) {
-
- if($mtype ne "CONNECT" and $session->stateless) {
- return 1; #pass the message up the stack
- }
-
- # the transport layer thinks this is a new connection. is it?
- unless ($mtype eq 'CONNECT') {
- $log->error("Connection seems to be mangled: Got $mtype instead of CONNECT");
-
- my $res = OpenSRF::DomainObject::oilsBrokenSession->new(
- status => "Connection seems to be mangled: Got $mtype instead of CONNECT",
- );
-
- $session->status($res);
- $session->kill_me;
- return 0;
-
- }
-
- my $res = OpenSRF::DomainObject::oilsConnectStatus->new;
- $session->status($res);
- $session->state( $session->CONNECTED );
-
- return 0;
- }
-
-
- return 1;
-
-}
-
-
-# Handle client side message processing. Return 1 when the the message should be pushed
-# up to the application layer. return 0 otherwise.
-sub do_client {
-
- my( $self, $session , $mtype, $api_level, $tT) = @_;
-
-
- if ($mtype eq 'STATUS') {
-
- if ($self->payload->statusCode == STATUS_OK) {
- $session->state($session->CONNECTED);
- $log->debug("We connected successfully to ".$session->app);
- return 0;
- }
-
- if ($self->payload->statusCode == STATUS_TIMEOUT) {
- $session->state( $session->DISCONNECTED );
- $session->reset;
- $session->connect;
- $session->push_resend( $session->app_request($self->threadTrace) );
- $log->debug("Disconnected because of timeout");
- return 0;
-
- } elsif ($self->payload->statusCode == STATUS_REDIRECTED) {
- $session->state( $session->DISCONNECTED );
- $session->reset;
- $session->connect;
- $session->push_resend( $session->app_request($self->threadTrace) );
- $log->debug("Disconnected because of redirect", WARN);
- return 0;
-
- } elsif ($self->payload->statusCode == STATUS_EXPFAILED) {
- $session->state( $session->DISCONNECTED );
- $log->debug("Disconnected because of mangled session", WARN);
- $session->reset;
- $session->push_resend( $session->app_request($self->threadTrace) );
- return 0;
-
- } elsif ($self->payload->statusCode == STATUS_CONTINUE) {
- $session->reset_request_timeout($self->threadTrace);
- return 0;
-
- } elsif ($self->payload->statusCode == STATUS_COMPLETE) {
- my $req = $session->app_request($self->threadTrace);
- $req->complete(1) if ($req);
- return 0;
- }
-
- # add more STATUS handling code here (as 'elsif's), for Message layer status stuff
-
- #$session->state( $session->DISCONNECTED() );
- #$session->reset;
-
- } elsif ($session->state == $session->CONNECTING()) {
- # This should be changed to check the type of response (is it a connectException?, etc.)
- }
-
- if( $self->payload and $self->payload->isa( "ERROR" ) ) {
- if ($session->raise_remote_errors) {
- $self->payload->throw();
- }
- }
-
- $log->debug("oilsMessage passing to Application: " . $self->type." : ".$session->remote_id );
-
- return 1;
-
-}
-
-1;
+++ /dev/null
-package OpenSRF::DomainObject::oilsMethod;
-
-use OpenSRF::Utils::JSON;
-OpenSRF::Utils::JSON->register_class_hint(hint => 'osrfMethod', name => 'OpenSRF::DomainObject::oilsMethod', type => 'hash');
-
-sub toString {
- my $self = shift;
- my $pretty = shift;
- return OpenSRF::Utils::JSON->perl2prettyJSON($self) if ($pretty);
- return OpenSRF::Utils::JSON->perl2JSON($self);
-}
-
-sub new {
- my $self = shift;
- my $class = ref($self) || $self;
- my %args = @_;
- return bless \%args => $class;
-}
-
-
-=head1 NAME
-
-OpenSRF::DomainObject::oilsMethod
-
-=head1 SYNOPSIS
-
-use OpenSRF::DomainObject::oilsMethod;
-
-my $method = OpenSRF::DomainObject::oilsMethod->new( method => 'search' );
-
-$method->return_type( 'mods' );
-
-$method->params( 'title:harry potter' );
-
-$client->send( 'REQUEST', $method );
-
-=head1 METHODS
-
-=head2 OpenSRF::DomainObject::oilsMethod->method( [$new_method_name] )
-
-=over 4
-
-Sets or gets the method name that will be called on the server. As above,
-this can be specified as a build attribute as well as added to a prebuilt
-oilsMethod object.
-
-=back
-
-=cut
-
-sub method {
- my $self = shift;
- my $val = shift;
- $self->{method} = $val if (defined $val);
- return $self->{method};
-}
-
-=head2 OpenSRF::DomainObject::oilsMethod->return_type( [$new_return_type] )
-
-=over 4
-
-Sets or gets the return type for this method call. This can also be supplied as
-a build attribute.
-
-This option does not require that the server return the type you request. It is
-used as a suggestion when more than one return type or format is possible.
-
-=back
-
-=cut
-
-
-sub return_type {
- my $self = shift;
- my $val = shift;
- $self->{return_type} = $val if (defined $val);
- return $self->{return_type};
-}
-
-=head2 OpenSRF::DomainObject::oilsMethod->params( @new_params )
-
-=over 4
-
-Sets or gets the parameters for this method call. Just pass in either text
-parameters, or DOM nodes of any type.
-
-=back
-
-=cut
-
-
-sub params {
- my $self = shift;
- my @args = @_;
- $self->{params} = \@args if (@args);
- return @{ $self->{params} };
-}
-
-1;
+++ /dev/null
-package OpenSRF::DomainObject::oilsResponse;
-use vars qw/@EXPORT_OK %EXPORT_TAGS/;
-use Exporter;
-use OpenSRF::Utils::JSON;
-use base qw/Exporter/;
-use OpenSRF::Utils::Logger qw/:level/;
-
-OpenSRF::Utils::JSON->register_class_hint( hint => 'osrfResponse', name => 'OpenSRF::DomainObject::oilsResponse', type => 'hash' );
-
-BEGIN {
-@EXPORT_OK = qw/STATUS_CONTINUE STATUS_OK STATUS_ACCEPTED
- STATUS_BADREQUEST STATUS_UNAUTHORIZED STATUS_FORBIDDEN
- STATUS_NOTFOUND STATUS_NOTALLOWED STATUS_TIMEOUT
- STATUS_INTERNALSERVERERROR STATUS_NOTIMPLEMENTED
- STATUS_VERSIONNOTSUPPORTED STATUS_REDIRECTED
- STATUS_EXPFAILED STATUS_COMPLETE/;
-
-%EXPORT_TAGS = (
- status => [ qw/STATUS_CONTINUE STATUS_OK STATUS_ACCEPTED
- STATUS_BADREQUEST STATUS_UNAUTHORIZED STATUS_FORBIDDEN
- STATUS_NOTFOUND STATUS_NOTALLOWED STATUS_TIMEOUT
- STATUS_INTERNALSERVERERROR STATUS_NOTIMPLEMENTED
- STATUS_VERSIONNOTSUPPORTED STATUS_REDIRECTED
- STATUS_EXPFAILED STATUS_COMPLETE/ ],
-);
-
-}
-
-=head1 NAME
-
-OpenSRF::DomainObject::oilsResponse
-
-=head1 SYNOPSIS
-
-use OpenSRF::DomainObject::oilsResponse qw/:status/;
-
-my $resp = OpenSRF::DomainObject::oilsResponse->new;
-
-$resp->status( 'a status message' );
-
-$resp->statusCode( STATUS_CONTINUE );
-
-$client->respond( $resp );
-
-=head1 ABSTRACT
-
-OpenSRF::DomainObject::oilsResponse implements the base class for all Application
-layer messages send between the client and server.
-
-=cut
-
-sub STATUS_CONTINUE { return 100 }
-
-sub STATUS_OK { return 200 }
-sub STATUS_ACCEPTED { return 202 }
-sub STATUS_COMPLETE { return 205 }
-
-sub STATUS_REDIRECTED { return 307 }
-
-sub STATUS_BADREQUEST { return 400 }
-sub STATUS_UNAUTHORIZED { return 401 }
-sub STATUS_FORBIDDEN { return 403 }
-sub STATUS_NOTFOUND { return 404 }
-sub STATUS_NOTALLOWED { return 405 }
-sub STATUS_TIMEOUT { return 408 }
-sub STATUS_EXPFAILED { return 417 }
-
-sub STATUS_INTERNALSERVERERROR { return 500 }
-sub STATUS_NOTIMPLEMENTED { return 501 }
-sub STATUS_VERSIONNOTSUPPORTED { return 505 }
-
-my $log = 'OpenSRF::Utils::Logger';
-
-sub toString {
- my $self = shift;
- my $pretty = shift;
- return OpenSRF::Utils::JSON->perl2prettyJSON($self) if ($pretty);
- return OpenSRF::Utils::JSON->perl2JSON($self);
-}
-
-sub new {
- my $class = shift;
- $class = ref($class) || $class;
-
- my $default_status = eval "\$${class}::status";
- my $default_statusCode = eval "\$${class}::statusCode";
-
- my %args = ( status => $default_status,
- statusCode => $default_statusCode,
- @_ );
-
- return bless( \%args => $class );
-}
-
-sub status {
- my $self = shift;
- my $val = shift;
- $self->{status} = $val if (defined $val);
- return $self->{status};
-}
-
-sub statusCode {
- my $self = shift;
- my $val = shift;
- $self->{statusCode} = $val if (defined $val);
- return $self->{statusCode};
-}
-
-#-------------------------------------------------------------------------------
-
-package OpenSRF::DomainObject::oilsStatus;
-use OpenSRF::DomainObject::oilsResponse qw/:status/;
-use base 'OpenSRF::DomainObject::oilsResponse';
-use vars qw/$status $statusCode/;
-OpenSRF::Utils::JSON->register_class_hint( hint => 'osrfStatus', name => 'OpenSRF::DomainObject::oilsStatus', type => 'hash' );
-
-=head1 NAME
-
-OpenSRF::DomainObject::oilsException
-
-=head1 SYNOPSIS
-
-use OpenSRF::DomainObject::oilsResponse;
-
-...
-
-# something happens.
-
-$client->status( OpenSRF::DomainObject::oilsStatus->new );
-
-=head1 ABSTRACT
-
-The base class for Status messages sent between client and server. This
-is implemented on top of the C<OpenSRF::DomainObject::oilsResponse> class, and
-sets the default B<status> to C<Status> and B<statusCode> to C<STATUS_OK>.
-
-=cut
-
-$status = 'Status';
-$statusCode = STATUS_OK;
-
-#-------------------------------------------------------------------------------
-
-package OpenSRF::DomainObject::oilsConnectStatus;
-use OpenSRF::DomainObject::oilsResponse qw/:status/;
-use base 'OpenSRF::DomainObject::oilsStatus';
-use vars qw/$status $statusCode/;
-OpenSRF::Utils::JSON->register_class_hint( hint => 'osrfConnectStatus', name => 'OpenSRF::DomainObject::oilsConnectStatus', type => 'hash' );
-
-=head1 NAME
-
-OpenSRF::DomainObject::oilsConnectStatus
-
-=head1 SYNOPSIS
-
-use OpenSRF::DomainObject::oilsResponse;
-
-...
-
-# something happens.
-
-$client->status( new OpenSRF::DomainObject::oilsConnectStatus );
-
-=head1 ABSTRACT
-
-The class for Stati relating to the connection status of a session. This
-is implemented on top of the C<OpenSRF::DomainObject::oilsStatus> class, and
-sets the default B<status> to C<Connection Successful> and B<statusCode> to C<STATUS_OK>.
-
-=head1 SEE ALSO
-
-B<OpenSRF::DomainObject::oilsStatus>
-
-=cut
-
-$status = 'Connection Successful';
-$statusCode = STATUS_OK;
-
-#-------------------------------------------------------------------------------
-
-package OpenSRF::DomainObject::oilsContinueStatus;
-use OpenSRF::DomainObject::oilsResponse qw/:status/;
-use base 'OpenSRF::DomainObject::oilsStatus';
-use vars qw/$status $statusCode/;
-OpenSRF::Utils::JSON->register_class_hint( hint => 'osrfContinueStatus', name => 'OpenSRF::DomainObject::oilsContinueStatus', type => 'hash' );
-
-=head1 NAME
-
-OpenSRF::DomainObject::oilsContinueStatus
-
-=head1 SYNOPSIS
-
-use OpenSRF::DomainObject::oilsResponse;
-
-...
-
-# something happens.
-
-$client->status( new OpenSRF::DomainObject::oilsContinueStatus );
-
-=head1 ABSTRACT
-
-Implements the STATUS_CONTINUE message, informing the client that it should
-continue to wait for a response to its request.
-
-=head1 SEE ALSO
-
-B<OpenSRF::DomainObject::oilsStatus>
-
-=cut
-
-$status = 'Please hold. Creating response...';
-$statusCode = STATUS_CONTINUE;
-
-1;
-
-#-------------------------------------------------------------------------------
-
-package OpenSRF::DomainObject::oilsResult;
-use OpenSRF::DomainObject::oilsResponse qw/:status/;
-use base 'OpenSRF::DomainObject::oilsResponse';
-use vars qw/$status $statusCode/;
-OpenSRF::Utils::JSON->register_class_hint( hint => 'osrfResult', name => 'OpenSRF::DomainObject::oilsResult', type => 'hash' );
-
-
-$status = 'OK';
-$statusCode = STATUS_OK;
-
-=head1 NAME
-
-OpenSRF::DomainObject::oilsResult
-
-=head1 SYNOPSIS
-
-use OpenSRF::DomainObject::oilsResponse;
-
- .... do stuff, create $object ...
-
-my $res = OpenSRF::DomainObject::oilsResult->new;
-
-$res->content($object)
-
-$session->respond( $res );
-
-=head1 ABSTRACT
-
-This is the base class for encapuslating RESULT messages send from the server
-to a client. It is a subclass of B<OpenSRF::DomainObject::oilsResponse>, and
-sets B<status> to C<OK> and B<statusCode> to C<STATUS_OK>.
-
-=head1 METHODS
-
-=head2 OpenSRF::DomainObject::oilsMessage->content( [$new_content] )
-
-=over 4
-
-Sets or gets the content of the response. This should be exactly one object
-of (sub)type domainObject or domainObjectCollection.
-
-=back
-
-=cut
-
-sub content {
- my $self = shift;
- my $val = shift;
-
- $self->{content} = $val if (defined $val);
- return $self->{content};
-}
-
-=head1 SEE ALSO
-
-B<OpenSRF::DomainObject::oilsResponse>
-
-=cut
-
-1;
-
-#-------------------------------------------------------------------------------
-
-package OpenSRF::DomainObject::oilsException;
-use OpenSRF::DomainObject::oilsResponse qw/:status/;
-use OpenSRF::EX;
-use base qw/OpenSRF::EX OpenSRF::DomainObject::oilsResponse/;
-use vars qw/$status $statusCode/;
-use Error;
-OpenSRF::Utils::JSON->register_class_hint( hint => 'osrfException', name => 'OpenSRF::DomainObject::oilsException', type => 'hash' );
-
-sub message {
- my $self = shift;
- return '<' . $self->statusCode . '> ' . $self->status;
-}
-
-sub new {
- my $class = shift;
- return $class->OpenSRF::DomainObject::oilsResponse::new( @_ );
-}
-
-
-=head1 NAME
-
-OpenSRF::DomainObject::oilsException
-
-=head1 SYNOPSIS
-
-use OpenSRF::DomainObject::oilsResponse;
-
-...
-
-# something breaks.
-
-$client->send( 'ERROR', OpenSRF::DomainObject::oilsException->new( status => "ARRRRRRG!" ) );
-
-=head1 ABSTRACT
-
-The base class for Exception messages sent between client and server. This
-is implemented on top of the C<OpenSRF::DomainObject::oilsResponse> class, and
-sets the default B<status> to C<Exception occurred> and B<statusCode> to C<STATUS_BADREQUEST>.
-
-=cut
-
-$status = 'Exception occurred';
-$statusCode = STATUS_INTERNALSERVERERROR;
-
-#-------------------------------------------------------------------------------
-
-package OpenSRF::DomainObject::oilsConnectException;
-use OpenSRF::DomainObject::oilsResponse qw/:status/;
-use OpenSRF::EX;
-use base qw/OpenSRF::DomainObject::oilsException OpenSRF::EX::ERROR/;
-use vars qw/$status $statusCode/;
-OpenSRF::Utils::JSON->register_class_hint( hint => 'osrfConnectException', name => 'OpenSRF::DomainObject::oilsConnectException', type => 'hash' );
-
-=head1 NAME
-
-OpenSRF::DomainObject::oilsConnectException
-
-=head1 SYNOPSIS
-
-use OpenSRF::DomainObject::oilsResponse;
-
-...
-
-# something breaks while connecting.
-
-$client->send( 'ERROR', new OpenSRF::DomainObject::oilsConnectException );
-
-=head1 ABSTRACT
-
-The class for Exceptions that occur durring the B<CONNECT> phase of a session. This
-is implemented on top of the C<OpenSRF::DomainObject::oilsException> class, and
-sets the default B<status> to C<Connect Request Failed> and B<statusCode> to C<STATUS_FORBIDDEN>.
-
-=head1 SEE ALSO
-
-B<OpenSRF::DomainObject::oilsException>
-
-=cut
-
-
-$status = 'Connect Request Failed';
-$statusCode = STATUS_FORBIDDEN;
-
-#-------------------------------------------------------------------------------
-
-package OpenSRF::DomainObject::oilsMethodException;
-use OpenSRF::DomainObject::oilsResponse qw/:status/;
-use base 'OpenSRF::DomainObject::oilsException';
-use vars qw/$status $statusCode/;
-OpenSRF::Utils::JSON->register_class_hint( hint => 'osrfMethodException', name => 'OpenSRF::DomainObject::oilsMethodException', type => 'hash' );
-
-=head1 NAME
-
-OpenSRF::DomainObject::oilsMethodException
-
-=head1 SYNOPSIS
-
-use OpenSRF::DomainObject::oilsResponse;
-
-...
-
-# something breaks while looking up or starting
-# a method call.
-
-$client->send( 'ERROR', new OpenSRF::DomainObject::oilsMethodException );
-
-=head1 ABSTRACT
-
-The class for Exceptions that occur during the B<CONNECT> phase of a session. This
-is implemented on top of the C<OpenSRF::DomainObject::oilsException> class, and
-sets the default B<status> to C<Connect Request Failed> and B<statusCode> to C<STATUS_NOTFOUND>.
-
-=head1 SEE ALSO
-
-B<OpenSRF::DomainObject::oilsException>
-
-=cut
-
-
-$status = 'A server error occurred during method execution';
-$statusCode = STATUS_INTERNALSERVERERROR;
-
-# -------------------------------------------
-
-package OpenSRF::DomainObject::oilsServerError;
-use OpenSRF::DomainObject::oilsResponse qw/:status/;
-use base 'OpenSRF::DomainObject::oilsException';
-use vars qw/$status $statusCode/;
-OpenSRF::Utils::JSON->register_class_hint( hint => 'osrfServerError', name => 'OpenSRF::DomainObject::oilsServerError', type => 'hash' );
-
-$status = 'Internal Server Error';
-$statusCode = STATUS_INTERNALSERVERERROR;
-
-# -------------------------------------------
-
-package OpenSRF::DomainObject::oilsBrokenSession;
-use OpenSRF::DomainObject::oilsResponse qw/:status/;
-use OpenSRF::EX;
-use base qw/OpenSRF::DomainObject::oilsException OpenSRF::EX::ERROR/;
-use vars qw/$status $statusCode/;
-OpenSRF::Utils::JSON->register_class_hint( hint => 'osrfBrokenSession', name => 'OpenSRF::DomainObject::oilsBrokenSession', type => 'hash' );
-$status = "Request on Disconnected Session";
-$statusCode = STATUS_EXPFAILED;
-
-#-------------------------------------------------------------------------------
-
-package OpenSRF::DomainObject::oilsXMLParseError;
-use OpenSRF::DomainObject::oilsResponse qw/:status/;
-use OpenSRF::EX;
-use base qw/OpenSRF::DomainObject::oilsException OpenSRF::EX::ERROR/;
-use vars qw/$status $statusCode/;
-OpenSRF::Utils::JSON->register_class_hint( hint => 'osrfXMLParseError', name => 'OpenSRF::DomainObject::oilsXMLParseError', type => 'hash' );
-$status = "XML Parse Error";
-$statusCode = STATUS_EXPFAILED;
-
-#-------------------------------------------------------------------------------
-
-package OpenSRF::DomainObject::oilsAuthException;
-use OpenSRF::DomainObject::oilsResponse qw/:status/;
-use OpenSRF::EX;
-use base qw/OpenSRF::DomainObject::oilsException OpenSRF::EX::ERROR/;
-OpenSRF::Utils::JSON->register_class_hint( hint => 'osrfAuthException', name => 'OpenSRF::DomainObject::oilsAuthException', type => 'hash' );
-use vars qw/$status $statusCode/;
-$status = "Authentication Failure";
-$statusCode = STATUS_FORBIDDEN;
-
-1;
+++ /dev/null
-package OpenSRF::EX;
-use Error qw(:try);
-use base qw( OpenSRF Error );
-use OpenSRF::Utils::Logger;
-
-my $log = "OpenSRF::Utils::Logger";
-$Error::Debug = 1;
-
-sub new {
- my( $class, $message ) = @_;
- $class = ref( $class ) || $class;
- my $self = {};
- $self->{'msg'} = ${$class . '::ex_msg_header'} .": $message";
- return bless( $self, $class );
-}
-
-sub message() { return $_[0]->{'msg'}; }
-
-sub DESTROY{}
-
-
-=head1 OpenSRF::EX
-
-Top level exception. This class logs an exception when it is thrown. Exception subclasses
-should subclass one of OpenSRF::EX::INFO, NOTICE, WARN, ERROR, CRITICAL, and PANIC and provide
-a new() method that takes a message and a message() method that returns that message.
-
-=cut
-
-=head2 Synopsis
-
-
- throw OpenSRF::EX::Jabber ("I Am Dying");
-
- OpenSRF::EX::InvalidArg->throw( "Another way" );
-
- my $je = OpenSRF::EX::Jabber->new( "I Cannot Connect" );
- $je->throw();
-
-
- See OpenSRF/EX.pm for example subclasses.
-
-=cut
-
-# Log myself and throw myself
-
-#sub message() { shift->alert_abstract(); }
-
-#sub new() { shift->alert_abstract(); }
-
-sub throw() {
-
- my $self = shift;
-
- if( ! ref( $self ) || scalar( @_ ) ) {
- $self = $self->new( @_ );
- }
-
- if( $self->class->isa( "OpenSRF::EX::INFO" ) ||
- $self->class->isa( "OpenSRF::EX::NOTICE" ) ||
- $self->class->isa( "OpenSRF::EX::WARN" ) ) {
-
- $log->debug( $self->stringify(), $log->DEBUG );
- }
-
- else{ $log->debug( $self->stringify(), $log->ERROR ); }
-
- $self->SUPER::throw;
-}
-
-
-sub stringify() {
- my $self = shift;
- my($package, $file, $line) = get_caller();
- my $name = ref($self);
- my $msg = $self->message();
-
- my ($sec,$min,$hour,$mday,$mon,$year) = localtime();
- $year += 1900; $mon += 1;
- my $date = sprintf(
- '%s-%0.2d-%0.2dT%0.2d:%0.2d:%0.2d',
- $year, $mon, $mday, $hour, $min, $sec);
-
- return "Exception: $name $date $package $file:$line $msg\n";
-}
-
-
-# --- determine the originating caller of this exception
-sub get_caller() {
-
- my $package = caller();
- my $x = 0;
- while( $package->isa( "Error" ) || $package =~ /^Error::/ ) {
- $package = caller( ++$x );
- }
- return (caller($x));
-}
-
-
-
-
-# -------------------------------------------------------------------
-# -------------------------------------------------------------------
-
-# Top level exception subclasses defining the different exception
-# levels.
-
-# -------------------------------------------------------------------
-
-package OpenSRF::EX::INFO;
-use base qw(OpenSRF::EX);
-our $ex_msg_header = "System INFO";
-
-# -------------------------------------------------------------------
-
-package OpenSRF::EX::NOTICE;
-use base qw(OpenSRF::EX);
-our $ex_msg_header = "System NOTICE";
-
-# -------------------------------------------------------------------
-
-package OpenSRF::EX::WARN;
-use base qw(OpenSRF::EX);
-our $ex_msg_header = "System WARNING";
-
-# -------------------------------------------------------------------
-
-package OpenSRF::EX::ERROR;
-use base qw(OpenSRF::EX);
-our $ex_msg_header = "System ERROR";
-
-# -------------------------------------------------------------------
-
-package OpenSRF::EX::CRITICAL;
-use base qw(OpenSRF::EX);
-our $ex_msg_header = "System CRITICAL";
-
-# -------------------------------------------------------------------
-
-package OpenSRF::EX::PANIC;
-use base qw(OpenSRF::EX);
-our $ex_msg_header = "System PANIC";
-
-# -------------------------------------------------------------------
-# -------------------------------------------------------------------
-
-# Some basic exceptions
-
-# -------------------------------------------------------------------
-package OpenSRF::EX::Jabber;
-use base 'OpenSRF::EX::ERROR';
-our $ex_msg_header = "Jabber Exception";
-
-package OpenSRF::EX::JabberDisconnected;
-use base 'OpenSRF::EX::ERROR';
-our $ex_msg_header = "JabberDisconnected Exception";
-
-=head2 OpenSRF::EX::Jabber
-
-Thrown when there is a problem using the Jabber service
-
-=cut
-
-package OpenSRF::EX::Transport;
-use base 'OpenSRF::EX::ERROR';
-our $ex_msg_header = "Transport Exception";
-
-
-
-# -------------------------------------------------------------------
-package OpenSRF::EX::InvalidArg;
-use base 'OpenSRF::EX::ERROR';
-our $ex_msg_header = "Invalid Arg Exception";
-
-=head2 OpenSRF::EX::InvalidArg
-
-Thrown where an argument to a method was invalid or not provided
-
-=cut
-
-
-# -------------------------------------------------------------------
-package OpenSRF::EX::Socket;
-use base 'OpenSRF::EX::ERROR';
-our $ex_msg_header = "Socket Exception";
-
-=head2 OpenSRF::EX::Socket
-
-Thrown when there is a network layer exception
-
-=cut
-
-
-
-# -------------------------------------------------------------------
-package OpenSRF::EX::Config;
-use base 'OpenSRF::EX::PANIC';
-our $ex_msg_header = "Config Exception";
-
-=head2 OpenSRF::EX::Config
-
-Thrown when a package requires a config option that it cannot retrieve
-or the config file itself cannot be loaded
-
-=cut
-
-
-# -------------------------------------------------------------------
-package OpenSRF::EX::User;
-use base 'OpenSRF::EX::ERROR';
-our $ex_msg_header = "User Exception";
-
-=head2 OpenSRF::EX::User
-
-Thrown when an error occurs due to user identification information
-
-=cut
-
-package OpenSRF::EX::Session;
-use base 'OpenSRF::EX::ERROR';
-our $ex_msg_header = "Session Error";
-
-
-1;
+++ /dev/null
-package OpenSRF::MultiSession;
-use OpenSRF::AppSession;
-use OpenSRF::Utils::Logger;
-use Time::HiRes qw/time usleep/;
-
-my $log = 'OpenSRF::Utils::Logger';
-
-sub new {
- my $class = shift;
- $class = ref($class) || $class;
-
- my $self = bless {@_} => $class;
-
- $self->{api_level} = 1 if (!defined($self->{api_level}));
- $self->{session_hash_function} = \&_dummy_session_hash_function
- if (!defined($self->{session_hash_function}));
-
- if ($self->{cap}) {
- $self->session_cap($self->{cap}) if (!$self->session_cap);
- $self->request_cap($self->{cap}) if (!$self->request_cap);
- }
-
- if (!$self->session_cap) {
- # XXX make adaptive the default once the logic is in place
- #$self->adaptive(1);
-
- $self->session_cap(10);
- }
- if (!$self->request_cap) {
- # XXX make adaptive the default once the logic is in place
- #$self->adaptive(1);
-
- $self->request_cap(10);
- }
-
- $self->{sessions} = [];
- $self->{running} = [];
- $self->{completed} = [];
- $self->{failed} = [];
-
- for ( 1 .. $self->session_cap) {
- push @{ $self->{sessions} },
- OpenSRF::AppSession->create(
- $self->{app},
- $self->{api_level},
- 1
- );
- #print "Creating connection ".$self->{sessions}->[-1]->session_id." ...\n";
- $log->debug("Creating connection ".$self->{sessions}->[-1]->session_id." ...");
- }
-
- return $self;
-}
-
-sub _dummy_session_hash_function {
- my $self = shift;
- $self->{_dummy_hash_counter} = 1 if (!exists($self->{_dummy_hash_counter}));
- return $self->{_dummy_hash_counter}++;
-}
-
-sub connect {
- my $self = shift;
- for my $ses (@{$self->{sessions}}) {
- $ses->connect unless ($ses->connected);
- }
-}
-
-sub finish {
- my $self = shift;
- $_->finish for (@{$self->{sessions}});
-}
-
-sub disconnect {
- my $self = shift;
- $_->disconnect for (@{$self->{sessions}});
-}
-
-sub session_hash_function {
- my $self = shift;
- my $session_hash_function = shift;
- return unless (ref $self);
-
- $self->{session_hash_function} = $session_hash_function if (defined $session_hash_function);
- return $self->{session_hash_function};
-}
-
-sub failure_handler {
- my $self = shift;
- my $failure_handler = shift;
- return unless (ref $self);
-
- $self->{failure_handler} = $failure_handler if (defined $failure_handler);
- return $self->{failure_handler};
-}
-
-sub success_handler {
- my $self = shift;
- my $success_handler = shift;
- return unless (ref $self);
-
- $self->{success_handler} = $success_handler if (defined $success_handler);
- return $self->{success_handler};
-}
-
-sub session_cap {
- my $self = shift;
- my $cap = shift;
- return unless (ref $self);
-
- $self->{session_cap} = $cap if (defined $cap);
- return $self->{session_cap};
-}
-
-sub request_cap {
- my $self = shift;
- my $cap = shift;
- return unless (ref $self);
-
- $self->{request_cap} = $cap if (defined $cap);
- return $self->{request_cap};
-}
-
-sub adaptive {
- my $self = shift;
- my $adapt = shift;
- return unless (ref $self);
-
- $self->{adaptive} = $adapt if (defined $adapt);
- return $self->{adaptive};
-}
-
-sub completed {
- my $self = shift;
- my $count = shift;
- return unless (ref $self);
-
-
- if (wantarray) {
- $count ||= scalar @{$self->{completed}};
- }
-
- if (defined $count) {
- return () unless (@{$self->{completed}});
- return splice @{$self->{completed}}, 0, $count;
- }
-
- return scalar @{$self->{completed}};
-}
-
-sub failed {
- my $self = shift;
- my $count = shift;
- return unless (ref $self);
-
-
- if (wantarray) {
- $count ||= scalar @{$self->{failed}};
- }
-
- if (defined $count) {
- return () unless (@{$self->{failed}});
- return splice @{$self->{failed}}, 0, $count;
- }
-
- return scalar @{$self->{failed}};
-}
-
-sub running {
- my $self = shift;
- return unless (ref $self);
- return scalar(@{ $self->{running} });
-}
-
-
-sub request {
- my $self = shift;
- my $hash_param;
-
- my $method = shift;
- if (ref $method) {
- $hash_param = $method;
- $method = shift;
- }
-
- my @params = @_;
-
- $self->session_reap;
- if ($self->running < $self->request_cap ) {
- my $index = $self->session_hash_function->($self, (defined $hash_param ? $hash_param : ()), $method, @params);
- my $ses = $self->{sessions}->[$index % $self->session_cap];
-
- #print "Running $method using session ".$ses->session_id."\n";
-
- my $req = $ses->request( $method, @params );
-
- push @{ $self->{running} },
- { req => $req,
- meth => $method,
- hash => $hash_param,
- params => [@params]
- };
-
- $log->debug("Making request [$method] ".$self->running."...");
-
- return $req;
- } elsif (!$self->adaptive) {
- #print "Oops. Too many running: ".$self->running."\n";
- $self->session_wait;
- return $self->request((defined $hash_param ? $hash_param : ()), $method => @params);
- } else {
- # XXX do addaptive stuff ...
- }
-}
-
-sub session_wait {
- my $self = shift;
- my $all = shift;
-
- my $count;
- if ($all) {
- $count = $self->running;
- while ($self->running) {
- $self->session_reap;
- }
- return $count;
- } else {
- while(($count = $self->session_reap) == 0 && $self->running) {
- usleep 100;
- }
- return $count;
- }
-}
-
-sub session_reap {
- my $self = shift;
-
- my @done;
- my @running;
- while ( my $req = shift @{ $self->{running} } ) {
- if ($req->{req}->complete) {
- #print "Currently running: ".$self->running."\n";
-
- $req->{response} = [ $req->{req}->recv ];
- $req->{duration} = $req->{req}->duration;
-
- #print "Completed ".$req->{meth}." in session ".$req->{req}->session->session_id." [$req->{duration}]\n";
-
- if ($req->{req}->failed) {
- #print "ARG!!!! Failed command $req->{meth} in session ".$req->{req}->session->session_id."\n";
- $req->{error} = $req->{req}->failed;
- push @{ $self->{failed} }, $req;
- } else {
- push @{ $self->{completed} }, $req;
- }
-
- push @done, $req;
-
- } else {
- #$log->debug("Still running ".$req->{meth}." in session ".$req->{req}->session->session_id);
- push @running, $req;
- }
- }
- push @{ $self->{running} }, @running;
-
- for my $req ( @done ) {
- my $handler = $req->{error} ? $self->failure_handler : $self->success_handler;
- $handler->($self, $req) if ($handler);
-
- $req->{req}->finish;
- delete $$req{$_} for (keys %$req);
-
- }
-
- my $complete = scalar @done;
- my $incomplete = scalar @running;
-
- #$log->debug("Still running $incomplete, completed $complete");
-
- return $complete;
-}
-
-1;
-
+++ /dev/null
-package OpenSRF::System;
-use strict; use warnings;
-use OpenSRF;
-use base 'OpenSRF';
-use OpenSRF::Utils::Logger qw(:level);
-use OpenSRF::Transport::Listener;
-use OpenSRF::Transport;
-use OpenSRF::UnixServer;
-use OpenSRF::Utils;
-use OpenSRF::Utils::LogServer;
-use OpenSRF::EX qw/:try/;
-use POSIX qw/setsid :sys_wait_h/;
-use OpenSRF::Utils::Config;
-use OpenSRF::Utils::SettingsParser;
-use OpenSRF::Utils::SettingsClient;
-use OpenSRF::Application;
-use Net::Server::PreFork;
-use strict;
-
-my $bootstrap_config_file;
-sub import {
- my( $self, $config ) = @_;
- $bootstrap_config_file = $config;
-}
-
-=head2 Name/Description
-
-OpenSRF::System
-
-To start the system: OpenSRF::System->bootstrap();
-
-Simple system process management and automation. After instantiating the class, simply call
-bootstrap() to launch the system. Each launched process is stored as a process-id/method-name
-pair in a local hash. When we receive a SIG{CHILD}, we loop through this hash and relaunch
-any child processes that may have terminated.
-
-Currently automated processes include launching the internal Unix Servers, launching the inbound
-connections for each application, and starting the system shell.
-
-
-Note: There should be only one instance of this class
-alive at any given time. It is designed as a globel process handler and, hence, will cause much
-oddness if you call the bootstrap() method twice or attempt to create two of these by trickery.
-There is a single instance of the class created on the first call to new(). This same instance is
-returned on subsequent calls to new().
-
-=cut
-
-$| = 1;
-
-sub DESTROY {}
-
-# ----------------------------------------------
-
-$SIG{INT} = sub { instance()->killall(); };
-
-$SIG{HUP} = sub{ instance()->hupall(); };
-
-#$SIG{CHLD} = \&process_automation;
-
-
-{
- # ---
- # put $instance in a closure and return it for requests to new()
- # since there should only be one System instance running
- # -----
- my $instance;
- sub instance { return __PACKAGE__->new(); }
- sub new {
- my( $class ) = @_;
-
- if( ! $instance ) {
- $class = ref( $class ) || $class;
- my $self = {};
- $self->{'pid_hash'} = {};
- bless( $self, $class );
- $instance = $self;
- }
- return $instance;
- }
-}
-
-# ----------------------------------------------
-# Commands to execute at system launch
-
-sub _unixserver {
- my( $app ) = @_;
- return "OpenSRF::UnixServer->new( '$app')->serve()";
-}
-
-sub _listener {
- my( $app ) = @_;
- return "OpenSRF::Transport::Listener->new( '$app' )->initialize()->listen()";
-}
-
-
-# ----------------------------------------------
-# Boot up the system
-
-sub load_bootstrap_config {
-
- if(OpenSRF::Utils::Config->current) {
- return;
- }
-
- if(!$bootstrap_config_file) {
- die "Please provide a bootstrap config file to OpenSRF::System!\n" .
- "use OpenSRF::System qw(/path/to/bootstrap_config);";
- }
-
- OpenSRF::Utils::Config->load( config_file => $bootstrap_config_file );
-
- OpenSRF::Utils::JSON->register_class_hint( name => "OpenSRF::Application", hint => "method", type => "hash" );
-
- OpenSRF::Transport->message_envelope( "OpenSRF::Transport::SlimJabber::MessageWrapper" );
- OpenSRF::Transport::PeerHandle->set_peer_client( "OpenSRF::Transport::SlimJabber::PeerConnection" );
- OpenSRF::Transport::Listener->set_listener( "OpenSRF::Transport::SlimJabber::Inbound" );
- OpenSRF::Application->server_class('client');
-}
-
-sub bootstrap {
-
- my $self = __PACKAGE__->instance();
- load_bootstrap_config();
- OpenSRF::Utils::Logger::set_config();
- my $bsconfig = OpenSRF::Utils::Config->current;
-
- # Start a process group and make me the captain
- exit if (OpenSRF::Utils::safe_fork());
- chdir('/');
- setsid();
- close STDIN;
- close STDOUT;
- close STDERR;
-
- $0 = "OpenSRF System";
-
- # -----------------------------------------------
- # Launch the settings sever if necessary...
- my $are_settings_server = 0;
- if( (my $cfile = $bsconfig->bootstrap->settings_config) ) {
- my $parser = OpenSRF::Utils::SettingsParser->new();
-
- # since we're (probably) the settings server, we can go ahead and load the real config file
- $parser->initialize( $cfile );
- $OpenSRF::Utils::SettingsClient::host_config =
- $parser->get_server_config($bsconfig->env->hostname);
-
- my $client = OpenSRF::Utils::SettingsClient->new();
- my $apps = $client->config_value("activeapps", "appname");
- if(ref($apps) ne "ARRAY") { $apps = [$apps]; }
-
- if(!defined($apps) || @$apps == 0) {
- print "No apps to load, exiting...";
- return;
- }
-
- for my $app (@$apps) {
- # verify we are a settings server and launch
- if( $app eq "opensrf.settings" and
- $client->config_value("apps","opensrf.settings", "language") =~ /perl/i ) {
-
- $are_settings_server = 1;
- $self->launch_settings();
- sleep 1;
- $self->launch_settings_listener();
- last;
- }
- }
- }
-
- # Launch everything else
- OpenSRF::System->bootstrap_client(client_name => "system_client");
- my $client = OpenSRF::Utils::SettingsClient->new();
- my $apps = $client->config_value("activeapps", "appname" );
- if(!ref($apps)) { $apps = [$apps]; }
-
- if(!defined($apps) || @$apps == 0) {
- print "No apps to load, exiting...";
- return;
- }
-
- my $server_type = $client->config_value("server_type");
- $server_type ||= "basic";
-
- my $con = OpenSRF::Transport::PeerHandle->retrieve;
- if($con) {
- $con->disconnect;
- }
-
-
-
- if( $server_type eq "prefork" ) {
- $server_type = "Net::Server::PreFork";
- } else {
- $server_type = "Net::Server::Single";
- }
-
- _log( " * Server type: $server_type", INTERNAL );
-
- $server_type->use;
-
- if( $@ ) {
- throw OpenSRF::EX::PANIC ("Cannot set $server_type: $@" );
- }
-
- push @OpenSRF::UnixServer::ISA, $server_type;
-
- _log( " * System bootstrap" );
-
- # --- Boot the Unix servers
- $self->launch_unix($apps);
-
- sleep 2;
-
- # --- Boot the listeners
- $self->launch_listener($apps);
-
- sleep 1;
-
- _log( " * System is ready..." );
-
-# sleep 1;
-# my $ps = `ps ax | grep " Open" | grep -v grep | sort -r -k5`;
-# print "\n --- PS --- \n$ps --- PS ---\n\n";
-
- while( 1 ) { sleep; }
- exit;
-}
-
-
-
-# ----------------------------------------------
-# Bootstraps a single client connection.
-
-# named params are 'config_file' and 'client_name'
-#
-sub bootstrap_client {
- my $self = shift;
-
- my $con = OpenSRF::Transport::PeerHandle->retrieve;
-
- if($con and $con->tcp_connected) {
- return;
- }
-
- my %params = @_;
-
- $bootstrap_config_file =
- $params{config_file} || $bootstrap_config_file;
-
- my $app = $params{client_name} || "client";
-
-
- load_bootstrap_config();
- OpenSRF::Utils::Logger::set_config();
- OpenSRF::Transport::PeerHandle->construct( $app );
-
-}
-
-sub connected {
- if (my $con = OpenSRF::Transport::PeerHandle->retrieve) {
- return 1 if ($con->tcp_connected);
- }
- return 0;
-}
-
-sub bootstrap_logger {
- $0 = "Log Server";
- OpenSRF::Utils::LogServer->serve();
-}
-
-
-# ----------------------------------------------
-# Cycle through the known processes, reap the dead child
-# and put a new child in its place. (MMWWAHAHHAHAAAA!)
-
-sub process_automation {
-
- my $self = __PACKAGE__->instance();
-
- foreach my $pid ( keys %{$self->pid_hash} ) {
-
- if( waitpid( $pid, WNOHANG ) == $pid ) {
-
- my $method = $self->pid_hash->{$pid};
- delete $self->pid_hash->{$pid};
-
- my $newpid = OpenSRF::Utils::safe_fork();
-
- OpenSRF::Utils::Logger->debug( "Relaunching $method", ERROR );
- _log( "Relaunching => $method" );
-
- if( $newpid ) {
- $self->pid_hash( $newpid, $method );
- }
- else { eval $method; exit; }
- }
- }
-
- $SIG{CHLD} = \&process_automation;
-}
-
-
-
-sub launch_settings {
-
- # XXX the $self like this and pid automation will not work with this setup....
- my($self) = @_;
- @OpenSRF::UnixServer::ISA = qw(OpenSRF Net::Server::PreFork);
-
- my $pid = OpenSRF::Utils::safe_fork();
- if( $pid ) {
- $self->pid_hash( $pid , "launch_settings()" );
- }
- else {
- my $apname = "opensrf.settings";
- #$0 = "OpenSRF App [$apname]";
- eval _unixserver( $apname );
- if($@) { die "$@\n"; }
- exit;
- }
-
- @OpenSRF::UnixServer::ISA = qw(OpenSRF);
-
-}
-
-
-sub launch_settings_listener {
-
- my $self = shift;
- my $app = "opensrf.settings";
- my $pid = OpenSRF::Utils::safe_fork();
- if ( $pid ) {
- $self->pid_hash( $pid , _listener( $app ) );
- }
- else {
- my $apname = $app;
- $0 = "OpenSRF listener [$apname]";
- eval _listener( $app );
- exit;
- }
-
-}
-
-# ----------------------------------------------
-# Launch the Unix Servers
-
-sub launch_unix {
- my( $self, $apps ) = @_;
-
- my $client = OpenSRF::Utils::SettingsClient->new();
-
- foreach my $app ( @$apps ) {
-
- next unless $app;
- my $lang = $client->config_value( "apps", $app, "language");
- next unless $lang =~ /perl/i;
- next if $app eq "opensrf.settings";
-
- _log( " * Starting UnixServer for $app..." );
-
- my $pid = OpenSRF::Utils::safe_fork();
- if( $pid ) {
- $self->pid_hash( $pid , _unixserver( $app ) );
- }
- else {
- my $apname = $app;
- $0 = "OpenSRF App ($apname)";
- eval _unixserver( $app );
- exit;
- }
- }
-}
-
-# ----------------------------------------------
-# Launch the inbound clients
-
-sub launch_listener {
-
- my( $self, $apps ) = @_;
- my $client = OpenSRF::Utils::SettingsClient->new();
-
- foreach my $app ( @$apps ) {
-
- next unless $app;
- my $lang = $client->config_value( "apps", $app, "language");
- next unless $lang =~ /perl/i;
- next if $app eq "opensrf.settings";
-
- _log( " * Starting Listener for $app..." );
-
- my $pid = OpenSRF::Utils::safe_fork();
- if ( $pid ) {
- $self->pid_hash( $pid , _listener( $app ) );
- }
- else {
- my $apname = $app;
- $0 = "OpenSRF listener [$apname]";
- eval _listener( $app );
- exit;
- }
- }
-}
-
-
-# ----------------------------------------------
-
-sub pid_hash {
- my( $self, $pid, $method ) = @_;
- $self->{'pid_hash'}->{$pid} = $method
- if( $pid and $method );
- return $self->{'pid_hash'};
-}
-
-# ----------------------------------------------
-# If requested, the System can shut down.
-
-sub killall {
-
- $SIG{CHLD} = 'IGNORE';
- $SIG{INT} = 'IGNORE';
- kill( 'INT', -$$ ); #kill all in process group
- exit;
-
-}
-
-# ----------------------------------------------
-# Handle $SIG{HUP}
-sub hupall {
-
- _log( "HUPping brood" );
- $SIG{CHLD} = 'IGNORE';
- $SIG{HUP} = 'IGNORE';
- kill( 'HUP', -$$ );
-# $SIG{CHLD} = \&process_automation;
- $SIG{HUP} = sub{ instance()->hupall(); };
-}
-
-
-# ----------------------------------------------
-# Log to debug, and stdout
-
-sub _log {
- my $string = shift;
- OpenSRF::Utils::Logger->debug( $string, INFO );
- print $string . "\n";
-}
-
-# ----------------------------------------------
-
-
-1;
-
-
+++ /dev/null
-package OpenSRF::Transport;
-use strict; use warnings;
-use base 'OpenSRF';
-use Time::HiRes qw/time/;
-use OpenSRF::AppSession;
-use OpenSRF::Utils::JSON;
-use OpenSRF::Utils::Logger qw(:level);
-use OpenSRF::DomainObject::oilsResponse qw/:status/;
-use OpenSRF::EX qw/:try/;
-use OpenSRF::Transport::SlimJabber::MessageWrapper;
-
-#------------------
-# --- These must be implemented by all Transport subclasses
-# -------------------------------------------
-
-=head2 get_listener
-
-Returns the package name of the package the system will use to
-gather incoming requests
-
-=cut
-
-sub get_listener { shift()->alert_abstract(); }
-
-=head2 get_peer_client
-
-Returns the name of the package responsible for client communication
-
-=cut
-
-sub get_peer_client { shift()->alert_abstract(); }
-
-=head2 get_msg_envelope
-
-Returns the name of the package responsible for parsing incoming messages
-
-=cut
-
-sub get_msg_envelope { shift()->alert_abstract(); }
-
-# -------------------------------------------
-
-our $message_envelope;
-my $logger = "OpenSRF::Utils::Logger";
-
-
-
-=head2 message_envelope( [$envelope] );
-
-Sets the message envelope class that will allow us to extract
-information from the messages we receive from the low
-level transport
-
-=cut
-
-sub message_envelope {
- my( $class, $envelope ) = @_;
- if( $envelope ) {
- $message_envelope = $envelope;
- $envelope->use;
- if( $@ ) {
- $logger->error(
- "Error loading message_envelope: $envelope -> $@", ERROR);
- }
- }
- return $message_envelope;
-}
-
-=head2 handler( $data )
-
-Creates a new MessageWrapper, extracts the remote_id, session_id, and message body
-from the message. Then, creates or retrieves the AppSession object with the session_id and remote_id.
-Finally, creates the message document from the body of the message and calls
-the handler method on the message document.
-
-=cut
-
-sub handler {
- my $start_time = time();
- my( $class, $service, $data ) = @_;
-
- $logger->transport( "Transport handler() received $data", INTERNAL );
-
- my $remote_id = $data->from;
- my $sess_id = $data->thread;
- my $body = $data->body;
- my $type = $data->type;
-
- $logger->set_osrf_xid($data->osrf_xid);
-
-
- if (defined($type) and $type eq 'error') {
- throw OpenSRF::EX::Session ("$remote_id IS NOT CONNECTED TO THE NETWORK!!!");
-
- }
-
- # See if the app_session already exists. If so, make
- # sure the sender hasn't changed if we're a server
- my $app_session = OpenSRF::AppSession->find( $sess_id );
- if( $app_session and $app_session->endpoint == $app_session->SERVER() and
- $app_session->remote_id ne $remote_id ) {
-
- my $c = OpenSRF::Utils::SettingsClient->new();
- if($c->config_value("apps", $app_session->service, "migratable")) {
- $logger->debug("service is migratable, new client is $remote_id");
- } else {
-
- $logger->warn("Backend Gone or invalid sender");
- my $res = OpenSRF::DomainObject::oilsBrokenSession->new();
- $res->status( "Backend Gone or invalid sender, Reconnect" );
- $app_session->status( $res );
- return 1;
- }
- }
-
- # Retrieve or build the app_session as appropriate (server_build decides which to do)
- $logger->transport( "AppSession is valid or does not exist yet", INTERNAL );
- $app_session = OpenSRF::AppSession->server_build( $sess_id, $remote_id, $service );
-
- if( ! $app_session ) {
- throw OpenSRF::EX::Session ("Transport::handler(): No AppSession object returned from server_build()");
- }
-
- # Create a document from the JSON contained within the message
- my $doc;
- eval { $doc = OpenSRF::Utils::JSON->JSON2perl($body); };
- if( $@ ) {
-
- $logger->warn("Received bogus JSON: $@");
- $logger->warn("Bogus JSON data: $body");
- my $res = OpenSRF::DomainObject::oilsXMLParseError->new( status => "JSON Parse Error --- $body\n\n$@" );
-
- $app_session->status($res);
- #$app_session->kill_me;
- return 1;
- }
-
- $logger->transport( "Transport::handler() creating \n$body", INTERNAL );
-
- # We need to disconnect the session if we got a jabber error on the client side. For
- # server side, we'll just tear down the session and go away.
- if (defined($type) and $type eq 'error') {
- # If we're a server
- if( $app_session->endpoint == $app_session->SERVER() ) {
- $app_session->kill_me;
- return 1;
- } else {
- $app_session->reset;
- $app_session->state( $app_session->DISCONNECTED );
- # below will lead to infinite looping, should return an exception
- #$app_session->push_resend( $app_session->app_request(
- # $doc->documentElement->firstChild->threadTrace ) );
- $logger->debug(
- "Got Jabber error on client connection $remote_id, nothing we can do..", ERROR );
- return 1;
- }
- }
-
- # cycle through and pass each oilsMessage contained in the message
- # up to the message layer for processing.
- for my $msg (@$doc) {
-
- next unless ( $msg && UNIVERSAL::isa($msg => 'OpenSRF::DomainObject::oilsMessage'));
-
- if( $app_session->endpoint == $app_session->SERVER() ) {
-
- try {
-
- if( ! $msg->handler( $app_session ) ) { return 0; }
-
- $logger->debug("Successfully handled message", DEBUG);
-
- } catch Error with {
-
- my $e = shift;
- my $res = OpenSRF::DomainObject::oilsServerError->new();
- $res->status( $res->status . "\n$e");
- $app_session->status($res) if $res;
- $app_session->kill_me;
- return 0;
-
- };
-
- } else {
-
- if( ! $msg->handler( $app_session ) ) { return 0; }
- $logger->info("Successfully handled message", DEBUG);
-
- }
-
- }
-
- $logger->debug(sprintf("Message processing duration: %.3fs",(time() - $start_time)), DEBUG);
-
- return $app_session;
-}
-
-1;
+++ /dev/null
-package OpenSRF::Transport::Jabber;
-use base qw/OpenSRF::Transport/;
-
-
-sub get_listener { return "OpenSRF::Transport::Jabber::JInbound"; }
-
-sub get_peer_client { return "OpenSRF::Transport::Jabber::JPeerConnection"; }
-
-sub get_msg_envelope { return "OpenSRF::Transport::Jabber::JMessageWrapper"; }
-
-1;
+++ /dev/null
-package OpenSRF::Transport::Jabber::JInbound;
-use strict;use warnings;
-use base qw/OpenSRF::Transport::Jabber::JabberClient/;
-use OpenSRF::EX;
-use OpenSRF::Utils::Config;
-use OpenSRF::Utils::Logger qw(:level);
-
-my $logger = "OpenSRF::Utils::Logger";
-
-=head1 Description
-
-This is the jabber connection where all incoming client requests will be accepted.
-This connection takes the data, passes it off to the system then returns to take
-more data. Connection params are all taken from the config file and the values
-retreived are based on the $app name passed into new().
-
-This service should be loaded at system startup.
-
-=cut
-
-# XXX This will be overhauled to connect as a component instead of as
-# a user. all in good time, though.
-
-{
- my $unix_sock;
- sub unix_sock { return $unix_sock; }
- my $instance;
-
- sub new {
- my( $class, $app ) = @_;
- $class = ref( $class ) || $class;
- if( ! $instance ) {
- my $app_state = $app . "_inbound";
- my $config = OpenSRF::Utils::Config->current;
-
- if( ! $config ) {
- throw OpenSRF::EX::Jabber( "No suitable config found" );
- }
-
- my $host = $config->transport->server->primary;
- my $username = $config->transport->users->$app;
- my $password = $config->transport->auth->password;
- my $debug = $config->transport->llevel->$app_state;
- my $log = $config->transport->log->$app_state;
- my $resource = "system";
-
-
- my $self = __PACKAGE__->SUPER::new(
- username => $username,
- host => $host,
- resource => $resource,
- password => $password,
- log_file => $log,
- debug => $debug,
- );
-
-
- my $f = $config->dirs->sock_dir;
- $unix_sock = join( "/", $f, $config->unix_sock->$app );
- bless( $self, $class );
- $instance = $self;
- }
- $instance->SetCallBacks( message => \&handle_message );
- return $instance;
- }
-
-}
-
-# ---
-# All incoming messages are passed untouched to the Unix Server for processing. The
-# Unix socket is closed by the Unix Server as soon as it has received all of the
-# data. This means we can go back to accepting more incoming connection.
-# -----
-sub handle_message {
- my $sid = shift;
- my $message = shift;
-
- my $packet = $message->GetXML();
-
- $logger->transport( "JInbound $$ received $packet", INTERNAL );
-
- # Send the packet to the unix socket for processing.
- my $sock = unix_sock();
- my $socket;
- my $x = 0;
- for( ;$x != 5; $x++ ) { #try 5 times
- if( $socket = IO::Socket::UNIX->new( Peer => $sock ) ) {
- last;
- }
- }
- if( $x == 5 ) {
- throw OpenSRF::EX::Socket(
- "Unable to connect to UnixServer: socket-file: $sock \n :=> $! " );
- }
- print $socket $packet;
- close( $socket );
-}
-
-
-1;
-
+++ /dev/null
-package OpenSRF::Transport::Jabber::JMessageWrapper;
-use Jabber::NodeFactory;
-use Net::Jabber qw(Client);
-use Net::Jabber::Message;
-use base qw/ Net::Jabber::Message OpenSRF /;
-use OpenSRF::Utils::Logger qw(:level);
-use strict; use warnings;
-
-=head1 Description
-
-OpenSRF::Transport::Jabber::JMessageWrapper
-
-Provides a means to extract information about a Jabber
-message when all you have is the raw XML. The API
-implemented here should be implemented by any Transport
-helper/MessageWrapper class.
-
-=cut
-
-sub DESTROY{}
-
-my $logger = "OpenSRF::Utils::Logger";
-my $_node_factory = Jabber::NodeFactory->new( fromstr => 1 );
-
-
-=head2 new( Net::Jabber::Message/$raw_xml )
-
-Pass in the raw Jabber message as XML and create a new
-JMessageWrapper
-
-=cut
-
-sub new {
- my( $class, $xml ) = @_;
- $class = ref( $class ) || $class;
-
- return undef unless( $xml );
-
- my $self;
-
- if( ref( $xml ) ) {
- $self = $xml;
- } else {
- $logger->transport( "MWrapper got: " . $xml, INTERNAL );
- my $node = $_node_factory->newNodeFromStr( $xml );
- $self = $class->SUPER::new();
- $self->SetFrom( $node->attr('from') );
- $self->SetThread( $node->getTag('thread')->data );
- $self->SetBody( $node->getTag('body')->data );
- }
-
- bless( $self, $class );
-
- $logger->transport( "MessageWrapper $self after blessing", INTERNAL );
-
- return $self;
-
-}
-
-=head2 get_remote_id
-
-Returns the JID (user@host/resource) of the remote user
-
-=cut
-sub get_remote_id {
- my( $self ) = @_;
- return $self->GetFrom();
-}
-
-=head2 get_sess_id
-
-Returns the Jabber thread associated with this message
-
-=cut
-sub get_sess_id {
- my( $self ) = @_;
- return $self->GetThread();
-}
-
-=head2 get_body
-
-Returns the message body of the Jabber message
-
-=cut
-sub get_body {
- my( $self ) = @_;
- return $self->GetBody();
-}
-
-
-1;
+++ /dev/null
-package OpenSRF::Transport::Jabber::JPeerConnection;
-use strict;
-use base qw/OpenSRF::Transport::Jabber::JabberClient/;
-use OpenSRF::Utils::Config;
-use OpenSRF::Utils::Logger qw(:level);
-
-=head1 Description
-
-Represents a single connection to a remote peer. The
-Jabber values are loaded from the config file.
-
-Subclasses OpenSRF::Transport::JabberClient.
-
-=cut
-
-=head2 new()
-
- new( $appname );
-
- The $appname parameter tells this class how to find the correct
- Jabber username, password, etc to connect to the server.
-
-=cut
-
-our $main_instance;
-our %apps_hash;
-
-sub retrieve {
- my( $class, $app ) = @_;
- my @keys = keys %apps_hash;
- OpenSRF::Utils::Logger->transport(
- "Requesting peer for $app and we have @keys", INTERNAL );
- return $apps_hash{$app};
-}
-
-
-
-sub new {
- my( $class, $app ) = @_;
- my $config = OpenSRF::Utils::Config->current;
-
- if( ! $config ) {
- throw OpenSRF::EX::Config( "No suitable config found" );
- }
-
- my $app_stat = $app . "_peer";
- my $host = $config->transport->server->primary;
- my $username = $config->transport->users->$app;
- my $password = $config->transport->auth->password;
- my $debug = $config->transport->llevel->$app_stat;
- my $log = $config->transport->log->$app_stat;
- my $resource = $config->env->hostname . "_$$";
-
- OpenSRF::EX::Config->throw( "JPeer could not load all necesarry values from config" )
- unless ( $host and $username and $password and $resource );
-
-
- my $self = __PACKAGE__->SUPER::new(
- username => $username,
- host => $host,
- resource => $resource,
- password => $password,
- log_file => $log,
- debug => $debug,
- );
-
- bless( $self, $class );
-
- $self->SetCallBacks( message => sub {
- my $msg = $_[1];
- OpenSRF::Utils::Logger->transport(
- "JPeer passing \n$msg \n to Transport->handler for $app", INTERNAL );
- OpenSRF::Transport->handler( $app, $msg ); } );
-
- $apps_hash{$app} = $self;
- return $apps_hash{$app};
-}
-
-1;
-
+++ /dev/null
-package OpenSRF::Transport::Jabber::JabberClient;
-use strict; use warnings;
-use OpenSRF::EX;
-use Net::Jabber qw( Client );
-use base qw( OpenSRF Net::Jabber::Client );
-use OpenSRF::Utils::Logger qw(:level);
-
-=head1 Description
-
-OpenSRF::Transport::Jabber::JabberClient
-
-Subclasses Net::Jabber::Client and, hence, provides the same
-functionality. What it provides in addition is mainly some logging
-and exception throwing on the call to 'initialize()', which sets
-up the connection and authentication.
-
-=cut
-
-my $logger = "OpenSRF::Utils::Logger";
-
-sub DESTROY{};
-
-
-=head2 new()
-
-Creates a new JabberClient object. The parameters should be self explanatory.
-If not, see Net::Jabber::Client for more.
-
-debug and log_file are not required if you don't care to log the activity,
-however all other parameters are.
-
-%params:
-
- host
- username
- resource
- password
- debug
- log_file
-
-=cut
-
-sub new {
-
- my( $class, %params ) = @_;
-
- $class = ref( $class ) || $class;
-
- my $host = $params{'host'} || return undef;
- my $username = $params{'username'} || return undef;
- my $resource = $params{'resource'} || return undef;
- my $password = $params{'password'} || return undef;
- my $debug = $params{'debug'};
- my $log_file = $params{'log_file'};
-
- my $self;
-
- if( $debug and $log_file ) {
- $self = Net::Jabber::Client->new(
- debuglevel => $debug, debugfile => $log_file );
- }
- else { $self = Net::Jabber::Client->new(); }
-
- bless( $self, $class );
-
- $self->host( $host );
- $self->username( $username );
- $self->resource( $resource );
- $self->password( $password );
-
- $logger->transport( "Creating Jabber instance: $host, $username, $resource",
- $logger->INFO );
-
- $self->SetCallBacks( send =>
- sub { $logger->transport( "JabberClient in 'send' callback: @_", INTERNAL ); } );
-
-
- return $self;
-}
-
-# -------------------------------------------------
-
-=head2 gather()
-
-Gathers all Jabber messages sitting in the collection queue
-and hands them each to their respective callbacks. This call
-does not block (calls Process(0))
-
-=cut
-
-sub gather { my $self = shift; $self->Process( 0 ); }
-
-# -------------------------------------------------
-
-=head2 listen()
-
-Blocks and gathers incoming messages as they arrive. Does not return
-unless an error occurs.
-
-Throws an OpenSRF::EX::JabberException if the call to Process ever fails.
-
-=cut
-sub listen {
- my $self = shift;
- while(1) {
- my $o = $self->process( -1 );
- if( ! defined( $o ) ) {
- throw OpenSRF::EX::Jabber( "Listen Loop failed at 'Process()'" );
- }
- }
-}
-
-# -------------------------------------------------
-
-sub password {
- my( $self, $password ) = @_;
- $self->{'oils:password'} = $password if $password;
- return $self->{'oils:password'};
-}
-
-# -------------------------------------------------
-
-sub username {
- my( $self, $username ) = @_;
- $self->{'oils:username'} = $username if $username;
- return $self->{'oils:username'};
-}
-
-# -------------------------------------------------
-
-sub resource {
- my( $self, $resource ) = @_;
- $self->{'oils:resource'} = $resource if $resource;
- return $self->{'oils:resource'};
-}
-
-# -------------------------------------------------
-
-sub host {
- my( $self, $host ) = @_;
- $self->{'oils:host'} = $host if $host;
- return $self->{'oils:host'};
-}
-
-# -------------------------------------------------
-
-=head2 send()
-
- Sends a Jabber message.
-
- %params:
- to - The JID of the recipient
- thread - The Jabber thread
- body - The body of the message
-
-=cut
-
-sub send {
- my( $self, %params ) = @_;
-
- my $to = $params{'to'} || return undef;
- my $body = $params{'body'} || return undef;
- my $thread = $params{'thread'};
-
- my $msg = Net::Jabber::Message->new();
-
- $msg->SetTo( $to );
- $msg->SetThread( $thread ) if $thread;
- $msg->SetBody( $body );
-
- $logger->transport(
- "JabberClient Sending message to $to with thread $thread and body: \n$body", INTERNAL );
-
- $self->Send( $msg );
-}
-
-
-=head2 inintialize()
-
-Connect to the server and log in.
-
-Throws an OpenSRF::EX::JabberException if we cannot connect
-to the server or if the authentication fails.
-
-=cut
-
-# --- The logging lines have been commented out until we decide
-# on which log files we're using.
-
-sub initialize {
-
- my $self = shift;
-
- my $host = $self->host;
- my $username = $self->username;
- my $resource = $self->resource;
- my $password = $self->password;
-
- my $jid = "$username\@$host\/$resource";
-
- # --- 5 tries to connect to the jabber server
- my $x = 0;
- for( ; $x != 5; $x++ ) {
- $logger->transport( "$jid: Attempting to connecto to server...$x", WARN );
- if( $self->Connect( 'hostname' => $host ) ) {
- last;
- }
- else { sleep 3; }
- }
-
- if( $x == 5 ) {
- die "could not connect to server $!\n";
- throw OpenSRF::EX::Jabber( " Could not connect to Jabber server" );
- }
-
- $logger->transport( "Logging into jabber as $jid " .
- "from " . ref( $self ), DEBUG );
-
- # --- Log in
- my @a = $self->AuthSend( 'username' => $username,
- 'password' => $password, 'resource' => $resource );
-
- if( $a[0] eq "ok" ) {
- $logger->transport( " * $jid: Jabber authenticated and connected", DEBUG );
- }
- else {
- throw OpenSRF::EX::Jabber( " * $jid: Unable to authenticate: @a" );
- }
-
- return $self;
-}
-
-sub construct {
- my( $class, $app ) = @_;
- $logger->transport("Constructing new Jabber connection for $app", INTERNAL );
- $class->peer_handle(
- $class->new( $app )->initialize() );
-}
-
-sub process {
-
- my( $self, $timeout ) = @_;
- if( ! $timeout ) { $timeout = 0; }
-
- unless( $self->Connected() ) {
- OpenSRF::EX::Jabber->throw(
- "This JabberClient instance is no longer connected to the server", ERROR );
- }
-
- my $val;
-
- if( $timeout eq "-1" ) {
- $val = $self->Process();
- }
- else { $val = $self->Process( $timeout ); }
-
- if( $timeout eq "-1" ) { $timeout = " "; }
-
- if( ! defined( $val ) ) {
- OpenSRF::EX::Jabber->throw(
- "Call to Net::Jabber::Client->Process( $timeout ) failed", ERROR );
- }
- elsif( ! $val ) {
- $logger->transport(
- "Call to Net::Jabber::Client->Process( $timeout ) returned 0 bytes of data", DEBUG );
- }
- elsif( $val ) {
- $logger->transport(
- "Call to Net::Jabber::Client->Process( $timeout ) successfully returned data", INTERNAL );
- }
-
- return $val;
-
-}
-
-
-1;
+++ /dev/null
-package OpenSRF::Transport::Listener;
-use base 'OpenSRF';
-use OpenSRF::Utils::Logger qw(:level);
-use OpenSRF::Transport::SlimJabber::Inbound;
-use base 'OpenSRF::Transport::SlimJabber::Inbound';
-
-=head1 Description
-
-This is the empty class that acts as the subclass of the transport listener. My API
-includes
-
-new( $app )
- create a new Listener with appname $app
-
-initialize()
- Perform any transport layer connections/authentication.
-
-listen()
- Block, wait for, and process incoming messages
-
-=cut
-
-=head2 set_listener()
-
-Sets my superclass. Pass in a string representing the perl module
-(e.g. OpenSRF::Transport::Jabber::JInbound) to be used as the
-superclass and it will be pushed onto @ISA.
-
-=cut
-
-sub set_listener {
- my( $class, $listener ) = @_;
- OpenSRF::Utils::Logger->transport("Loading Listener $listener", INFO );
- if( $listener ) {
- $listener->use;
- if( $@ ) {
- OpenSRF::Utils::Logger->error(
- "Unable to set transport listener: $@", ERROR );
- }
- unshift @ISA, $listener;
- }
-}
-
-
-1;
+++ /dev/null
-package OpenSRF::Transport::PeerHandle;
-use OpenSRF::Utils::Logger qw(:level);
-use OpenSRF::EX;
-use base qw/OpenSRF::Transport::SlimJabber::PeerConnection/;
-use vars '@ISA';
-
-my $peer;
-
-=head2 peer_handle( $handle )
-
-Assigns the object that will act as the peer connection handle.
-
-=cut
-sub peer_handle {
- my( $class, $handle ) = @_;
- if( $handle ) { $peer = $handle; }
- return $peer;
-}
-
-
-=head2 set_peer_client( $peer )
-
-Sets the class that will act as the superclass of this class.
-Pass in a string representing the module to be used as the superclass,
-and that module is 'used' and unshifted into @ISA. We now have that
-classes capabilities.
-
-=cut
-sub set_peer_client {
- my( $class, $peer ) = @_;
- if( $peer ) {
- $peer->use;
- if( $@ ) {
- throw OpenSRF::EX::PANIC ( "Unable to set peer client: $@" );
- }
- unshift @ISA, $peer;
- }
-}
-
-1;
+++ /dev/null
-package OpenSRF::Transport::SlimJabber;
-use base qw/OpenSRF::Transport/;
-
-=head2 OpenSRF::Transport::SlimJabber
-
-Implements the Transport interface for providing the system with appropriate
-classes for handling transport layer messaging
-
-=cut
-
-
-sub get_listener { return "OpenSRF::Transport::SlimJabber::Inbound"; }
-
-sub get_peer_client { return "OpenSRF::Transport::SlimJabber::PeerConnection"; }
-
-sub get_msg_envelope { return "OpenSRF::Transport::SlimJabber::MessageWrapper"; }
-
-1;
+++ /dev/null
-package OpenSRF::Transport::SlimJabber::Client;
-use strict; use warnings;
-use OpenSRF::EX;
-use OpenSRF::Utils::Config;
-use OpenSRF::Utils::Logger qw/$logger/;
-use OpenSRF::Transport::SlimJabber::XMPPReader;
-use OpenSRF::Transport::SlimJabber::XMPPMessage;
-use IO::Socket::UNIX;
-use FreezeThaw qw/freeze/;
-
-sub DESTROY{
- shift()->disconnect;
-}
-
-sub new {
- my( $class, %params ) = @_;
- my $self = bless({}, ref($class) || $class);
- $self->params(\%params);
- return $self;
-}
-
-
-sub reader {
- my($self, $reader) = @_;
- $self->{reader} = $reader if $reader;
- return $self->{reader};
-}
-
-sub params {
- my($self, $params) = @_;
- $self->{params} = $params if $params;
- return $self->{params};
-}
-
-sub socket {
- my($self, $socket) = @_;
- $self->{socket} = $socket if $socket;
- return $self->{socket};
-}
-
-sub disconnect {
- my $self = shift;
- $self->reader->disconnect if $self->reader;
-}
-
-
-sub gather {
- my $self = shift;
- $self->process( 0 );
-}
-
-# -------------------------------------------------
-
-sub tcp_connected {
- my $self = shift;
- return $self->reader->tcp_connected if $self->reader;
- return 0;
-}
-
-
-
-sub send {
- my $self = shift;
- my $msg = OpenSRF::Transport::SlimJabber::XMPPMessage->new(@_);
- $self->reader->send($msg->to_xml);
-}
-
-sub initialize {
-
- my $self = shift;
-
- my $host = $self->params->{host};
- my $port = $self->params->{port};
- my $username = $self->params->{username};
- my $resource = $self->params->{resource};
- my $password = $self->params->{password};
-
- my $jid = "$username\@$host/$resource";
-
- my $conf = OpenSRF::Utils::Config->current;
-
- my $tail = "_$$";
- $tail = "" if !$conf->bootstrap->router_name and $username eq "router";
- $resource = "$resource$tail";
-
- my $socket = IO::Socket::INET->new(
- PeerHost => $host,
- PeerPort => $port,
- Peer => $port,
- Proto => 'tcp' );
-
- throw OpenSRF::EX::Jabber("Could not open TCP socket to Jabber server: $!")
- unless ( $socket and $socket->connected );
-
- $self->socket($socket);
- $self->reader(OpenSRF::Transport::SlimJabber::XMPPReader->new($socket));
- $self->reader->connect($host, $username, $password, $resource);
-
- throw OpenSRF::EX::Jabber("Could not authenticate with Jabber server: $!")
- unless ( $self->reader->connected );
-
- return $self;
-}
-
-
-sub construct {
- my( $class, $app ) = @_;
- $class->peer_handle($class->new( $app )->initialize());
-}
-
-
-sub process {
- my($self, $timeout) = @_;
-
- $timeout ||= 0;
- $timeout = int($timeout);
-
- unless( $self->reader and $self->reader->connected ) {
- throw OpenSRF::EX::JabberDisconnected
- ("This JabberClient instance is no longer connected to the server ");
- }
-
- return $self->reader->wait_msg($timeout);
-}
-
-
-# --------------------------------------------------------------
-# Sets the socket to O_NONBLOCK, reads all of the data off of
-# the socket, the restores the sockets flags
-# Returns 1 on success, 0 if the socket isn't connected
-# --------------------------------------------------------------
-sub flush_socket {
- my $self = shift;
- return $self->reader->flush_socket;
-}
-
-1;
-
-
+++ /dev/null
-package OpenSRF::Transport::SlimJabber::Inbound;
-use strict;use warnings;
-use base qw/OpenSRF::Transport::SlimJabber::Client/;
-use OpenSRF::EX qw(:try);
-use OpenSRF::Utils::Logger qw(:level);
-use OpenSRF::Utils::SettingsClient;
-use OpenSRF::Utils::Config;
-use Time::HiRes qw/usleep/;
-use FreezeThaw qw/freeze/;
-
-my $logger = "OpenSRF::Utils::Logger";
-
-=head1 Description
-
-This is the jabber connection where all incoming client requests will be accepted.
-This connection takes the data, passes it off to the system then returns to take
-more data. Connection params are all taken from the config file and the values
-retreived are based on the $app name passed into new().
-
-This service should be loaded at system startup.
-
-=cut
-
-{
- my $unix_sock;
- sub unix_sock { return $unix_sock; }
- my $instance;
-
- sub new {
- my( $class, $app ) = @_;
- $class = ref( $class ) || $class;
- if( ! $instance ) {
-
- my $conf = OpenSRF::Utils::Config->current;
- my $domain = $conf->bootstrap->domain;
- $logger->error("use of <domains/> is deprecated") if $conf->bootstrap->domains;
-
- my $username = $conf->bootstrap->username;
- my $password = $conf->bootstrap->passwd;
- my $port = $conf->bootstrap->port;
- my $host = $domain;
- my $resource = $app . '_listener_at_' . $conf->env->hostname;
-
- my $router_name = $conf->bootstrap->router_name;
- # no router, only one listener running..
- if(!$router_name) {
- $username = "router";
- $resource = $app;
- }
-
- OpenSRF::Utils::Logger->transport("Inbound as $username, $password, $resource, $host, $port\n", INTERNAL );
-
- my $self = __PACKAGE__->SUPER::new(
- username => $username,
- resource => $resource,
- password => $password,
- host => $host,
- port => $port,
- );
-
- $self->{app} = $app;
-
- my $client = OpenSRF::Utils::SettingsClient->new();
- my $f = $client->config_value("dirs", "sock");
- $unix_sock = join( "/", $f,
- $client->config_value("apps", $app, "unix_config", "unix_sock" ));
- bless( $self, $class );
- $instance = $self;
- }
- return $instance;
- }
-
-}
-
-sub DESTROY {
- my $self = shift;
- for my $router (@{$self->{routers}}) {
- if($self->tcp_connected()) {
- $logger->info("disconnecting from router $router");
- $self->send( to => $router, body => "registering",
- router_command => "unregister" , router_class => $self->{app} );
- }
- }
-}
-
-sub listen {
- my $self = shift;
-
- $self->{routers} = [];
-
- try {
-
- my $conf = OpenSRF::Utils::Config->current;
- my $router_name = $conf->bootstrap->router_name;
- my $routers = $conf->bootstrap->routers;
- $logger->info("loading router info $routers");
-
- for my $router (@$routers) {
- if(ref $router) {
- if( !$router->{services} || grep { $_ eq $self->{app} } @{$router->{services}->{service}} ) {
- my $name = $router->{name};
- my $domain = $router->{domain};
- my $target = "$name\@$domain/router";
- push(@{$self->{routers}}, $target);
- $logger->info( $self->{app} . " connecting to router $target");
- $self->send( to => $target, body => "registering", router_command => "register" , router_class => $self->{app} );
- }
- } else {
- my $target = "$router_name\@$router/router";
- push(@{$self->{routers}}, $target);
- $logger->info( $self->{app} . " connecting to router $target");
- $self->send( to => $target, body => "registering", router_command => "register" , router_class => $self->{app} );
- }
- }
-
- } catch Error with {
- $logger->transport( $self->{app} . ": No routers defined" , WARN );
- # no routers defined
- };
-
-
-
-
- $logger->transport( $self->{app} . " going into listen loop", INFO );
-
- while(1) {
-
- my $sock = $self->unix_sock();
- my $o;
-
- $logger->debug("Inbound listener calling process()");
-
- try {
- $o = $self->process(-1);
-
- if(!$o){
- $logger->error(
- "Inbound received no data from the Jabber socket in process()");
- usleep(100000); # otherwise we loop and pound syslog logger with errors
- }
-
- } catch OpenSRF::EX::JabberDisconnected with {
-
- $logger->error("Inbound process lost its ".
- "jabber connection. Attempting to reconnect...");
- $self->initialize;
- $o = undef;
- };
-
-
- if($o) {
- my $socket = IO::Socket::UNIX->new( Peer => $sock );
- throw OpenSRF::EX::Socket(
- "Unable to connect to UnixServer: socket-file: $sock \n :=> $! " )
- unless ($socket->connected);
- print $socket freeze($o);
- $socket->close;
- }
- }
-
- throw OpenSRF::EX::Socket( "How did we get here?!?!" );
-}
-
-1;
-
+++ /dev/null
-package OpenSRF::Transport::SlimJabber::MessageWrapper;
-use strict; use warnings;
-use OpenSRF::Transport::SlimJabber::XMPPMessage;
-
-# ----------------------------------------------------------
-# Legacy wrapper for XMPPMessage
-# ----------------------------------------------------------
-
-sub new {
- my $class = shift;
- my $msg = shift;
- return bless({msg => $msg}, ref($class) || $class);
-}
-
-sub msg {
- my($self, $msg) = @_;
- $self->{msg} = $msg if $msg;
- return $self->{msg};
-}
-
-sub toString {
- return $_[0]->msg->to_xml;
-}
-
-sub get_body {
- return $_[0]->msg->body;
-}
-
-sub get_sess_id {
- return $_[0]->msg->thread;
-}
-
-sub get_msg_type {
- return $_[0]->msg->type;
-}
-
-sub get_remote_id {
- return $_[0]->msg->from;
-}
-
-sub setType {
- $_[0]->msg->type(shift());
-}
-
-sub setTo {
- $_[0]->msg->to(shift());
-}
-
-sub setThread {
- $_[0]->msg->thread(shift());
-}
-
-sub setBody {
- $_[0]->msg->body(shift());
-}
-
-sub set_router_command {
- $_[0]->msg->router_command(shift());
-}
-sub set_router_class {
- $_[0]->msg->router_class(shift());
-}
-
-sub set_osrf_xid {
- $_[0]->msg->osrf_xid(shift());
-}
-
-sub get_osrf_xid {
- return $_[0]->msg->osrf_xid;
-}
-
-1;
+++ /dev/null
-package OpenSRF::Transport::SlimJabber::PeerConnection;
-use strict;
-use base qw/OpenSRF::Transport::SlimJabber::Client/;
-use OpenSRF::Utils::Config;
-use OpenSRF::Utils::Logger qw(:level);
-use OpenSRF::EX qw/:try/;
-
-=head1 Description
-
-Represents a single connection to a remote peer. The
-Jabber values are loaded from the config file.
-
-Subclasses OpenSRF::Transport::SlimJabber::Client.
-
-=cut
-
-=head2 new()
-
- new( $appname );
-
- The $appname parameter tells this class how to find the correct
- Jabber username, password, etc to connect to the server.
-
-=cut
-
-our %apps_hash;
-our $_singleton_connection;
-
-sub retrieve {
- my( $class, $app ) = @_;
- return $_singleton_connection;
-}
-
-
-sub new {
- my( $class, $app ) = @_;
-
- my $peer_con = $class->retrieve;
- return $peer_con if ($peer_con and $peer_con->tcp_connected);
-
- my $config = OpenSRF::Utils::Config->current;
-
- if( ! $config ) {
- throw OpenSRF::EX::Config( "No suitable config found for PeerConnection" );
- }
-
- my $conf = OpenSRF::Utils::Config->current;
- my $domain = $conf->bootstrap->domain;
- my $h = $conf->env->hostname;
- OpenSRF::Utils::Logger->error("use of <domains/> is deprecated") if $conf->bootstrap->domains;
-
- my $username = $conf->bootstrap->username;
- my $password = $conf->bootstrap->passwd;
- my $port = $conf->bootstrap->port;
- my $resource = "${app}_drone_at_$h";
- my $host = $domain; # XXX for now...
-
- if( $app eq "client" ) { $resource = "client_at_$h"; }
-
- OpenSRF::EX::Config->throw( "JPeer could not load all necesarry values from config" )
- unless ( $username and $password and $resource and $host and $port );
-
- OpenSRF::Utils::Logger->transport( "Built Peer with", INTERNAL );
-
- my $self = __PACKAGE__->SUPER::new(
- username => $username,
- resource => $resource,
- password => $password,
- host => $host,
- port => $port,
- );
-
- bless( $self, $class );
-
- $self->app($app);
-
- $_singleton_connection = $self;
- $apps_hash{$app} = $self;
-
- return $_singleton_connection;
- return $apps_hash{$app};
-}
-
-sub process {
- my $self = shift;
- my $val = $self->SUPER::process(@_);
- return 0 unless $val;
- return OpenSRF::Transport->handler($self->app, $val);
-}
-
-sub app {
- my $self = shift;
- my $app = shift;
- $self->{app} = $app if $app;
- return $self->{app};
-}
-
-1;
-
+++ /dev/null
-package OpenSRF::Transport::SlimJabber::XMPPMessage;
-use strict; use warnings;
-use OpenSRF::Utils::Logger qw/$logger/;
-use OpenSRF::EX qw/:try/;
-use strict; use warnings;
-use XML::LibXML;
-
-use constant JABBER_MESSAGE =>
- "<message to='%s' from='%s' router_command='%s' router_class='%s' osrf_xid='%s'>".
- "<thread>%s</thread><body>%s</body></message>";
-
-sub new {
- my $class = shift;
- my %args = @_;
- my $self = bless({}, $class);
-
- if($args{xml}) {
- $self->parse_xml($args{xml});
-
- } else {
- $self->{to} = $args{to} || '';
- $self->{from} = $args{from} || '';
- $self->{thread} = $args{thread} || '';
- $self->{body} = $args{body} || '';
- $self->{osrf_xid} = $args{osrf_xid} || '';
- $self->{router_command} = $args{router_command} || '';
- $self->{router_class} = $args{router_class} || '';
- }
-
- return $self;
-}
-
-sub to {
- my($self, $to) = @_;
- $self->{to} = $to if defined $to;
- return $self->{to};
-}
-sub from {
- my($self, $from) = @_;
- $self->{from} = $from if defined $from;
- return $self->{from};
-}
-sub thread {
- my($self, $thread) = @_;
- $self->{thread} = $thread if defined $thread;
- return $self->{thread};
-}
-sub body {
- my($self, $body) = @_;
- $self->{body} = $body if defined $body;
- return $self->{body};
-}
-sub status {
- my($self, $status) = @_;
- $self->{status} = $status if defined $status;
- return $self->{status};
-}
-sub type {
- my($self, $type) = @_;
- $self->{type} = $type if defined $type;
- return $self->{type};
-}
-sub err_type {
- my($self, $err_type) = @_;
- $self->{err_type} = $err_type if defined $err_type;
- return $self->{err_type};
-}
-sub err_code {
- my($self, $err_code) = @_;
- $self->{err_code} = $err_code if defined $err_code;
- return $self->{err_code};
-}
-sub osrf_xid {
- my($self, $osrf_xid) = @_;
- $self->{osrf_xid} = $osrf_xid if defined $osrf_xid;
- return $self->{osrf_xid};
-}
-sub router_command {
- my($self, $router_command) = @_;
- $self->{router_command} = $router_command if defined $router_command;
- return $self->{router_command};
-}
-sub router_class {
- my($self, $router_class) = @_;
- $self->{router_class} = $router_class if defined $router_class;
- return $self->{router_class};
-}
-
-
-sub to_xml {
- my $self = shift;
-
- my $body = $self->{body};
- $body =~ s/&/&/sog;
- $body =~ s/</</sog;
- $body =~ s/>/>/sog;
-
- return sprintf(
- JABBER_MESSAGE,
- $self->{to},
- $self->{from},
- $self->{router_command},
- $self->{router_class},
- $self->{osrf_xid},
- $self->{thread},
- $body
- );
-}
-
-sub parse_xml {
- my($self, $xml) = @_;
- my($doc, $err);
-
- try {
- $doc = XML::LibXML->new->parse_string($xml);
- } catch Error with {
- my $err = shift;
- $logger->error("Error parsing message xml: $xml --- $err");
- };
- throw $err if $err;
-
- my $root = $doc->documentElement;
-
- $self->{body} = $root->findnodes('/message/body').'';
- $self->{thread} = $root->findnodes('/message/thread').'';
- $self->{from} = $root->getAttribute('router_from');
- $self->{from} = $root->getAttribute('from') unless $self->{from};
- $self->{to} = $root->getAttribute('to');
- $self->{type} = $root->getAttribute('type');
- $self->{osrf_xid} = $root->getAttribute('osrf_xid');
-}
-
-
-1;
+++ /dev/null
-package OpenSRF::Transport::SlimJabber::XMPPReader;
-use strict; use warnings;
-use XML::Parser;
-use Fcntl qw(F_GETFL F_SETFL O_NONBLOCK);
-use Time::HiRes qw/time/;
-use OpenSRF::Transport::SlimJabber::XMPPMessage;
-use OpenSRF::Utils::Logger qw/$logger/;
-
-# -----------------------------------------------------------
-# Connect, disconnect, and authentication messsage templates
-# -----------------------------------------------------------
-use constant JABBER_CONNECT =>
- "<stream:stream to='%s' xmlns='jabber:client' xmlns:stream='http://etherx.jabber.org/streams'>";
-
-use constant JABBER_BASIC_AUTH =>
- "<iq id='123' type='set'><query xmlns='jabber:iq:auth'>" .
- "<username>%s</username><password>%s</password><resource>%s</resource></query></iq>";
-
-use constant JABBER_DISCONNECT => "</stream:stream>";
-
-
-# -----------------------------------------------------------
-# XMPP Stream states
-# -----------------------------------------------------------
-use constant DISCONNECTED => 1;
-use constant CONNECT_RECV => 2;
-use constant CONNECTED => 3;
-
-
-# -----------------------------------------------------------
-# XMPP Message states
-# -----------------------------------------------------------
-use constant IN_NOTHING => 1;
-use constant IN_BODY => 2;
-use constant IN_THREAD => 3;
-use constant IN_STATUS => 4;
-
-
-# -----------------------------------------------------------
-# Constructor, getter/setters
-# -----------------------------------------------------------
-sub new {
- my $class = shift;
- my $socket = shift;
-
- my $self = bless({}, $class);
-
- $self->{queue} = [];
- $self->{stream_state} = DISCONNECTED;
- $self->{xml_state} = IN_NOTHING;
- $self->socket($socket);
-
- my $p = new XML::Parser(Handlers => {
- Start => \&start_element,
- End => \&end_element,
- Char => \&characters,
- });
-
- $self->parser($p->parse_start); # create a push parser
- $self->parser->{_parent_} = $self;
- $self->{message} = OpenSRF::Transport::SlimJabber::XMPPMessage->new;
- return $self;
-}
-
-sub push_msg {
- my($self, $msg) = @_;
- push(@{$self->{queue}}, $msg) if $msg;
-}
-
-sub next_msg {
- my $self = shift;
- return shift @{$self->{queue}};
-}
-
-sub peek_msg {
- my $self = shift;
- return (@{$self->{queue}} > 0);
-}
-
-sub parser {
- my($self, $parser) = @_;
- $self->{parser} = $parser if $parser;
- return $self->{parser};
-}
-
-sub socket {
- my($self, $socket) = @_;
- $self->{socket} = $socket if $socket;
- return $self->{socket};
-}
-
-sub stream_state {
- my($self, $stream_state) = @_;
- $self->{stream_state} = $stream_state if $stream_state;
- return $self->{stream_state};
-}
-
-sub xml_state {
- my($self, $xml_state) = @_;
- $self->{xml_state} = $xml_state if $xml_state;
- return $self->{xml_state};
-}
-
-sub message {
- my($self, $message) = @_;
- $self->{message} = $message if $message;
- return $self->{message};
-}
-
-
-# -----------------------------------------------------------
-# Stream and connection handling methods
-# -----------------------------------------------------------
-
-sub connect {
- my($self, $domain, $username, $password, $resource) = @_;
-
- $self->send(sprintf(JABBER_CONNECT, $domain));
- $self->wait(10);
-
- unless($self->{stream_state} == CONNECT_RECV) {
- $logger->error("No initial XMPP response from server");
- return 0;
- }
-
- $self->send(sprintf(JABBER_BASIC_AUTH, $username, $password, $resource));
- $self->wait(10);
-
- unless($self->connected) {
- $logger->error('XMPP connect failed');
- return 0;
- }
-
- return 1;
-}
-
-sub disconnect {
- my $self = shift;
- if($self->tcp_connected) {
- $self->send(JABBER_DISCONNECT);
- shutdown($self->socket, 2);
- }
- close($self->socket);
-}
-
-# -----------------------------------------------------------
-# returns true if this stream is connected to the server
-# -----------------------------------------------------------
-sub connected {
- my $self = shift;
- return ($self->tcp_connected and $self->{stream_state} == CONNECTED);
-}
-
-# -----------------------------------------------------------
-# returns true if the socket is connected
-# -----------------------------------------------------------
-sub tcp_connected {
- my $self = shift;
- return ($self->socket and $self->socket->connected);
-}
-
-# -----------------------------------------------------------
-# sends pre-formated XML
-# -----------------------------------------------------------
-sub send {
- my($self, $xml) = @_;
- $self->{socket}->print($xml);
-}
-
-# -----------------------------------------------------------
-# Puts a file handle into blocking mode
-# -----------------------------------------------------------
-sub set_block {
- my $fh = shift;
- my $flags = fcntl($fh, F_GETFL, 0);
- $flags &= ~O_NONBLOCK;
- fcntl($fh, F_SETFL, $flags);
-}
-
-
-# -----------------------------------------------------------
-# Puts a file handle into non-blocking mode
-# -----------------------------------------------------------
-sub set_nonblock {
- my $fh = shift;
- my $flags = fcntl($fh, F_GETFL, 0);
- fcntl($fh, F_SETFL, $flags | O_NONBLOCK);
-}
-
-
-sub wait {
- my($self, $timeout) = @_;
-
- return $self->next_msg if $self->peek_msg;
-
- $timeout ||= 0;
- $timeout = undef if $timeout < 0;
- my $socket = $self->{socket};
-
- set_block($socket);
-
- # build the select readset
- my $infile = '';
- vec($infile, $socket->fileno, 1) = 1;
- return undef unless select($infile, undef, undef, $timeout);
-
- # now slurp the data off the socket
- my $buf;
- my $read_size = 1024;
- while(my $n = sysread($socket, $buf, $read_size)) {
- $self->{parser}->parse_more($buf) if $buf;
- if($n < $read_size or $self->peek_msg) {
- set_block($socket);
- last;
- }
- set_nonblock($socket);
- }
-
- return $self->next_msg;
-}
-
-# -----------------------------------------------------------
-# Waits up to timeout seconds for a fully-formed XMPP
-# message to arrive. If timeout is < 0, waits indefinitely
-# -----------------------------------------------------------
-sub wait_msg {
- my($self, $timeout) = @_;
- my $xml;
-
- $timeout = 0 unless defined $timeout;
-
- if($timeout < 0) {
- while(1) {
- return $xml if $xml = $self->wait($timeout);
- }
-
- } else {
- while($timeout >= 0) {
- my $start = time;
- return $xml if $xml = $self->wait($timeout);
- $timeout -= time - $start;
- }
- }
-
- return undef;
-}
-
-
-# -----------------------------------------------------------
-# SAX Handlers
-# -----------------------------------------------------------
-
-
-sub start_element {
- my($parser, $name, %attrs) = @_;
- my $self = $parser->{_parent_};
-
- if($name eq 'message') {
-
- my $msg = $self->{message};
- $msg->{to} = $attrs{'to'};
- $msg->{from} = $attrs{router_from} if $attrs{router_from};
- $msg->{from} = $attrs{from} unless $msg->{from};
- $msg->{osrf_xid} = $attrs{'osrf_xid'};
- $msg->{type} = $attrs{type};
-
- } elsif($name eq 'body') {
- $self->{xml_state} = IN_BODY;
-
- } elsif($name eq 'thread') {
- $self->{xml_state} = IN_THREAD;
-
- } elsif($name eq 'stream:stream') {
- $self->{stream_state} = CONNECT_RECV;
-
- } elsif($name eq 'iq') {
- if($attrs{type} and $attrs{type} eq 'result') {
- $self->{stream_state} = CONNECTED;
- }
-
- } elsif($name eq 'status') {
- $self->{xml_state } = IN_STATUS;
-
- } elsif($name eq 'stream:error') {
- $self->{stream_state} = DISCONNECTED;
-
- } elsif($name eq 'error') {
- $self->{message}->{err_type} = $attrs{'type'};
- $self->{message}->{err_code} = $attrs{'code'};
- $self->{stream_state} = DISCONNECTED;
- }
-}
-
-sub characters {
- my($parser, $chars) = @_;
- my $self = $parser->{_parent_};
- my $state = $self->{xml_state};
-
- if($state == IN_BODY) {
- $self->{message}->{body} .= $chars;
-
- } elsif($state == IN_THREAD) {
- $self->{message}->{thread} .= $chars;
-
- } elsif($state == IN_STATUS) {
- $self->{message}->{status} .= $chars;
- }
-}
-
-sub end_element {
- my($parser, $name) = @_;
- my $self = $parser->{_parent_};
- $self->{xml_state} = IN_NOTHING;
-
- if($name eq 'message') {
- $self->push_msg($self->{message});
- $self->{message} = OpenSRF::Transport::SlimJabber::XMPPMessage->new;
-
- } elsif($name eq 'stream:stream') {
- $self->{stream_state} = DISCONNECTED;
- }
-}
-
-sub flush_socket {
- my $self = shift;
- my $socket = $self->socket;
- return 0 unless $socket and $socket->connected;
-
- my $flags = fcntl($socket, F_GETFL, 0);
- fcntl($socket, F_SETFL, $flags | O_NONBLOCK);
-
- while( my $n = sysread( $socket, my $buf, 8192 ) ) {
- $logger->debug("flush_socket dropped $n bytes of data");
- $logger->error("flush_socket dropped data on disconnected socket: $buf")
- unless($socket->connected);
- }
-
- fcntl($socket, F_SETFL, $flags);
- return 0 unless $socket->connected;
- return 1;
-}
-
-
-
-
-
-1;
-
-
-
-
-
+++ /dev/null
-package OpenSRF::UnixServer;
-use strict; use warnings;
-use base qw/OpenSRF/;
-use OpenSRF::EX qw(:try);
-use OpenSRF::Utils::Logger qw(:level $logger);
-use OpenSRF::Transport::PeerHandle;
-use OpenSRF::Application;
-use OpenSRF::AppSession;
-use OpenSRF::DomainObject::oilsResponse qw/:status/;
-use OpenSRF::System;
-use OpenSRF::Utils::SettingsClient;
-use Time::HiRes qw(time);
-use OpenSRF::Utils::JSON;
-use vars qw/@ISA $app/;
-use Fcntl qw(F_GETFL F_SETFL O_NONBLOCK);
-use Carp;
-use FreezeThaw qw/thaw/;
-
-use IO::Socket::INET;
-use IO::Socket::UNIX;
-
-sub DESTROY { confess "Dying $$"; }
-
-=head1 What am I
-
-All inbound messages are passed on to the UnixServer for processing.
-We take the data, close the Unix socket, and pass the data on to our abstract
-'process()' method.
-
-Our purpose is to 'multiplex' a single TCP connection into multiple 'client' connections.
-So when you pass data down the Unix socket to us, we have been preforked and waiting
-to disperse new data among us.
-
-=cut
-
-sub app { return $app; }
-
-{
-
- sub new {
- my( $class, $app1 ) = @_;
- if( ! $app1 ) {
- throw OpenSRF::EX::InvalidArg( "UnixServer requires an app name to run" );
- }
- $app = $app1;
- my $self = bless( {}, $class );
-# my $client = OpenSRF::Utils::SettingsClient->new();
-# if( $client->config_value("server_type") !~ /fork/i ||
-# OpenSRF::Utils::Config->current->bootstrap->settings_config ) {
-# warn "Calling hooks for non-prefork\n";
-# $self->configure_hook();
-# $self->child_init_hook();
-# }
- return $self;
- }
-
-}
-
-=head2 process_request()
-
-Takes the incoming data, closes the Unix socket and hands the data untouched
-to the abstract process() method. This method is implemented in our subclasses.
-
-=cut
-
-sub process_request {
-
- my $self = shift;
- my $data; my $d;
- while( $d = <STDIN> ) { $data .= $d; }
-
- my $orig = $0;
- $0 = "$0*";
-
- if( ! $data or ! defined( $data ) or $data eq "" ) {
- close($self->{server}->{client});
- $logger->debug("Unix child received empty data from socket", ERROR);
- $0 = $orig;
- return;
- }
-
-
- if( ! close( $self->{server}->{client} ) ) {
- $logger->debug( "Error closing Unix socket: $!", ERROR );
- }
-
- my $app = $self->app();
- $logger->transport( "UnixServer for $app received $data", INTERNAL );
-
- # --------------------------------------------------------------
- # Drop all data from the socket before coninuting to process
- # --------------------------------------------------------------
- my $ph = OpenSRF::Transport::PeerHandle->retrieve;
- if(!$ph->flush_socket()) {
- $logger->error("We received a request ".
- "and we are no longer connected to the jabber network. ".
- "We will go away and drop this request: $data");
- exit;
- }
-
- ($data) = thaw($data);
- my $app_session = OpenSRF::Transport->handler( $self->app(), $data );
-
- if(!ref($app_session)) {
- $logger->transport( "Did not receive AppSession from transport handler, returning...", WARN );
- $0 = $orig;
- return;
- }
-
- if($app_session->stateless and $app_session->state != $app_session->CONNECTED()){
- $logger->debug("Exiting keepalive for stateless session / orig = $orig");
- $app_session->kill_me;
- $0 = $orig;
- return;
- }
-
-
- my $client = OpenSRF::Utils::SettingsClient->new();
- my $keepalive = $client->config_value("apps", $self->app(), "keepalive");
-
- my $req_counter = 0;
- while( $app_session and
- $app_session->state and
- $app_session->state != $app_session->DISCONNECTED() and
- $app_session->find( $app_session->session_id ) ) {
-
-
- my $before = time;
- $logger->debug( "UnixServer calling queue_wait $keepalive", INTERNAL );
- $app_session->queue_wait( $keepalive );
- $logger->debug( "after queue wait $keepalive", INTERNAL );
- my $after = time;
-
- if( ($after - $before) >= $keepalive ) {
-
- my $res = OpenSRF::DomainObject::oilsConnectStatus->new(
- status => "Disconnected on timeout",
- statusCode => STATUS_TIMEOUT);
- $app_session->status($res);
- $app_session->state( $app_session->DISCONNECTED() );
- last;
- }
-
- }
-
- my $x = 0;
- while( $app_session && $app_session->queue_wait(0) ) {
- $logger->debug( "Looping on zombies " . $x++ , DEBUG);
- }
-
- $logger->debug( "Timed out, disconnected, or authentication failed" );
- $app_session->kill_me if ($app_session);
-
- $0 = $orig;
-}
-
-
-sub serve {
- my( $self ) = @_;
-
- my $app = $self->app();
- $logger->set_service($app);
-
- $0 = "OpenSRF master [$app]";
-
- my $client = OpenSRF::Utils::SettingsClient->new();
- my @base = ('apps', $app, 'unix_config' );
-
- my $min_servers = $client->config_value(@base, 'min_children');
- my $max_servers = $client->config_value(@base, "max_children" );
- my $min_spare = $client->config_value(@base, "min_spare_children" );
- my $max_spare = $client->config_value(@base, "max_spare_children" );
- my $max_requests = $client->config_value(@base, "max_requests" );
- # fwiw, these file paths are (obviously) not portable
- my $log_file = join("/", $client->config_value("dirs", "log"), $client->config_value(@base, "unix_log" ));
- my $port = join("/", $client->config_value("dirs", "sock"), $client->config_value(@base, "unix_sock" ));
- my $pid_file = join("/", $client->config_value("dirs", "pid"), $client->config_value(@base, "unix_pid" ));
-
- $min_spare ||= $min_servers;
- $max_spare ||= $max_servers;
- $max_requests ||= 1000;
-
- $logger->info("UnixServer: min=$min_servers, max=$max_servers, min_spare=$min_spare ".
- "max_spare=$max_spare, max_req=$max_requests, log_file=$log_file, port=$port, pid_file=$pid_file");
-
- $self->run(
- min_servers => $min_servers,
- max_servers => $max_servers,
- min_spare_servers => $min_spare,
- max_spare_servers => $max_spare,
- max_requests => $max_requests,
- log_file => $log_file,
- port => $port,
- proto => 'unix',
- pid_file => $pid_file,
- );
-
-}
-
-
-sub configure_hook {
- my $self = shift;
- my $app = $self->app;
-
- # boot a client
- OpenSRF::System->bootstrap_client( client_name => "system_client" );
-
- $logger->debug( "Setting application implementation for $app", DEBUG );
- my $client = OpenSRF::Utils::SettingsClient->new();
- my $imp = $client->config_value("apps", $app, "implementation");
- OpenSRF::Application::server_class($app);
- OpenSRF::Application->application_implementation( $imp );
- OpenSRF::Utils::JSON->register_class_hint( name => $imp, hint => $app, type => "hash" );
- OpenSRF::Application->application_implementation->initialize()
- if (OpenSRF::Application->application_implementation->can('initialize'));
-
- if( $client->config_value("server_type") !~ /fork/i ) {
- $self->child_init_hook();
- }
-
- my $con = OpenSRF::Transport::PeerHandle->retrieve;
- if($con) {
- $con->disconnect;
- }
-
- return OpenSRF::Application->application_implementation;
-}
-
-sub child_init_hook {
-
- $0 =~ s/master/drone/g;
-
- if ($ENV{OPENSRF_PROFILE}) {
- my $file = $0;
- $file =~ s/\W/_/go;
- eval "use Devel::Profiler output_file => '/tmp/profiler_$file.out', buffer_size => 0;";
- if ($@) {
- $logger->debug("Could not load Devel::Profiler: $@",ERROR);
- } else {
- $0 .= ' [PROFILING]';
- $logger->debug("Running under Devel::Profiler", INFO);
- }
- }
-
- my $self = shift;
-
-# $logger->transport(
-# "Creating PeerHandle from UnixServer child_init_hook", INTERNAL );
- OpenSRF::Transport::PeerHandle->construct( $self->app() );
- $logger->transport( "PeerHandle Created from UnixServer child_init_hook", INTERNAL );
-
- OpenSRF::Application->application_implementation->child_init
- if (OpenSRF::Application->application_implementation->can('child_init'));
-
- return OpenSRF::Transport::PeerHandle->retrieve;
-}
-
-sub child_finish_hook {
- $logger->debug("attempting to call child exit handler...");
- OpenSRF::Application->application_implementation->child_exit
- if (OpenSRF::Application->application_implementation->can('child_exit'));
-}
-
-
-1;
-
+++ /dev/null
-package OpenSRF::Utils;
-
-=head1 NAME
-
-OpenSRF::Utils
-
-=head1 DESCRIPTION
-
-This is a container package for methods that are useful to derived modules.
-It has no constructor, and is generally not useful by itself... but this
-is where most of the generic methods live.
-
-
-=head1 METHODS
-
-
-=cut
-
-use vars qw/@ISA $AUTOLOAD %EXPORT_TAGS @EXPORT_OK @EXPORT $VERSION/;
-push @ISA, 'Exporter';
-
-$VERSION = do { my @r=(q$Revision$=~/\d+/g); sprintf "%d."."%02d"x$#r,@r };
-
-use Time::Local;
-use Errno;
-use POSIX;
-use FileHandle;
-#use Cache::FileCache;
-#use Storable qw(dclone);
-use Digest::MD5 qw(md5 md5_hex md5_base64);
-use Exporter;
-use DateTime;
-use DateTime::Format::ISO8601;
-use DateTime::TimeZone;
-
-our $date_parser = DateTime::Format::ISO8601->new;
-
-# This turns errors into warnings, so daemons don't die.
-#$Storable::forgive_me = 1;
-
-%EXPORT_TAGS = (
- common => [qw(interval_to_seconds seconds_to_interval sendmail tree_filter)],
- daemon => [qw(safe_fork set_psname daemonize)],
- datetime => [qw(clense_ISO8601 gmtime_ISO8601 interval_to_seconds seconds_to_interval)],
-);
-
-Exporter::export_ok_tags('common','daemon','datetime'); # add aa, cc and dd to @EXPORT_OK
-
-sub AUTOLOAD {
- my $self = shift;
- my $type = ref($self) or return undef;
-
- my $name = $AUTOLOAD;
- $name =~ s/.*://; # strip fully-qualified portion
-
- if (defined($_[0])) {
- return $self->{$name} = shift;
- }
- return $self->{$name};
-}
-
-
-sub _sub_builder {
- my $self = shift;
- my $class = ref($self) || $self;
- my $part = shift;
- unless ($class->can($part)) {
- *{$class.'::'.$part} =
- sub {
- my $self = shift;
- my $new_val = shift;
- if ($new_val) {
- $$self{$part} = $new_val;
- }
- return $$self{$part};
- };
- }
-}
-
-sub tree_filter {
- my $tree = shift;
- my $field = shift;
- my $filter = shift;
-
- my @things = $filter->($tree);
- for my $v ( @{$tree->$field} ){
- push @things, $filter->($v);
- push @things, tree_filter($v, $field, $filter);
- }
- return @things
-}
-
-#sub standalone_ipc_cache {
-# my $self = shift;
-# my $class = ref($self) || $self;
-# my $uniquifier = shift || return undef;
-# my $expires = shift || 3600;
-
-# return new Cache::FileCache ( { namespace => $class.'::'.$uniquifier, default_expires_in => $expires } );
-#}
-
-sub sendmail {
- my $self = shift;
- my $message = shift || $self;
-
- open SM, '|/usr/sbin/sendmail -U -t' or return 0;
- print SM $message;
- close SM or return 0;
- return 1;
-}
-
-sub __strip_comments {
- my $self = shift;
- my $config_file = shift;
- my ($line, @done);
- while (<$config_file>) {
- s/^\s*(.*)\s*$/$1/o if (lc($$self{keep_space}) ne 'true');
- /^(.*)$/o;
- $line .= $1;
- # keep new lines if keep_space is true
- if ($line =~ /^$/o && (lc($$self{keep_space}) ne 'true')) {
- $line = '';
- next;
- }
- if (/^([^<]+)\s*<<\s*(\w+)\s*$/o) {
- $line = "$1 = ";
- my $breaker = $2;
- while (<$config_file>) {
- chomp;
- last if (/^$breaker/);
- $line .= $_;
- }
- }
-
- if ($line =~ /^#/ && $line !~ /^#\s*include\s+/o) {
- $line = '';
- next;
- }
- if ($line =~ /\\$/o) {
- chomp $line;
- $line =~ s/^\s*(.*)\s*\\$/$1/o;
- next;
- }
- push @done, $line;
- $line = '';
- }
- return @done;
-}
-
-
-=head2 $thing->encrypt(@stuff)
-
-Returns a one way hash (MD5) of the values appended together.
-
-=cut
-
-sub encrypt {
- my $self = shift;
- return md5_hex(join('',@_));
-}
-
-=head2 $utils_obj->es_time('field') OR noo_es_time($timestamp)
-
-Returns the epoch-second style timestamp for the value stored in
-$utils_obj->{field}. Returns B<0> for an empty or invalid date stamp, and
-assumes a PostgreSQL style datestamp to be supplied.
-
-=cut
-
-sub es_time {
- my $self = shift;
- my $part = shift;
- my $es_part = $part.'_ES';
- return $$self{$es_part} if (exists($$self{$es_part}) && defined($$self{$es_part}) && $$self{$es_part});
- if (!$$self{$part} or $$self{$part} !~ /\d+/) {
- return 0;
-
- }
- my @tm = reverse($$self{$part} =~ /([\d\.]+)/og);
- if ($tm[5] > 0) {
- $tm[5] -= 1;
- }
-
- return $$self{$es_part} = noo_es_time($$self{$part});
-}
-
-=head2 noo_es_time($timestamp) (non-OO es_time)
-
-Returns the epoch-second style timestamp for the B<$timestamp> passed
-in. Returns B<0> for an empty or invalid date stamp, and
-assumes a PostgreSQL style datestamp to be supplied.
-
-=cut
-
-sub noo_es_time {
- my $timestamp = shift;
-
- my @tm = reverse($timestamp =~ /([\d\.]+)/og);
- if ($tm[5] > 0) {
- $tm[5] -= 1;
- }
- return timelocal(int($tm[1]), int($tm[2]), int($tm[3]), int($tm[4]) || 1, int($tm[5]), int($tm[6]) || 2002 );
-}
-
-
-=head2 $thing->interval_to_seconds('interval') OR interval_to_seconds('interval')
-
-=head2 $thing->seconds_to_interval($seconds) OR seconds_to_interval($seconds)
-
-Returns the number of seconds for any interval passed, or the interval for the seconds.
-This is the generic version of B<interval> listed below.
-
-The interval must match the regex I</\s*\+?\s*(\d+)\s*(\w{1})\w*\s*/g>, for example
-B<2 weeks, 3 d and 1hour + 17 Months> or
-B<1 year, 5 Months, 2 weeks, 3 days and 1 hour of seconds> meaning 46148400 seconds.
-
- my $expire_time = time() + $thing->interval_to_seconds('17h 9m');
-
-The time size indicator may be one of
-
-=over 2
-
-=item s[econd[s]]
-
-for seconds
-
-=item m[inute[s]]
-
-for minutes
-
-=item h[our[s]]
-
-for hours
-
-=item d[ay[s]]
-
-for days
-
-=item w[eek[s]]
-
-for weeks
-
-=item M[onth[s]]
-
-for months (really (365 * 1d)/12 ... that may get smarter, though)
-
-=item y[ear[s]]
-
-for years (this is 365 * 1d)
-
-=back
-
-=cut
-sub interval_to_seconds {
- my $self = shift;
- my $interval = shift || $self;
-
- $interval =~ s/and/,/g;
- $interval =~ s/,/ /g;
-
- my $amount = 0;
- while ($interval =~ /\s*\+?\s*(\d+)\s*(\w+)\s*/g) {
- my ($count, $type) = ($1, $2);
- $amount += $count if ($type eq 's');
- $amount += 60 * $count if ($type =~ /^m(?!o)/oi);
- $amount += 60 * 60 * $count if ($type =~ /^h/);
- $amount += 60 * 60 * 24 * $count if ($type =~ /^d/oi);
- $amount += 60 * 60 * 24 * 7 * $count if ($2 =~ /^w/oi);
- $amount += ((60 * 60 * 24 * 365)/12) * $count if ($type =~ /^mo/io);
- $amount += 60 * 60 * 24 * 365 * $count if ($type =~ /^y/oi);
- }
- return $amount;
-}
-
-sub seconds_to_interval {
- my $self = shift;
- my $interval = shift || $self;
-
- my $limit = shift || 's';
- $limit =~ s/^(.)/$1/o;
-
- my ($y,$ym,$M,$Mm,$w,$wm,$d,$dm,$h,$hm,$m,$mm,$s,$string);
- my ($year, $month, $week, $day, $hour, $minute, $second) =
- ('year','Month','week','day', 'hour', 'minute', 'second');
-
- if ($y = int($interval / (60 * 60 * 24 * 365))) {
- $string = "$y $year". ($y > 1 ? 's' : '');
- $ym = $interval % (60 * 60 * 24 * 365);
- } else {
- $ym = $interval;
- }
- return $string if ($limit eq 'y');
-
- if ($M = int($ym / ((60 * 60 * 24 * 365)/12))) {
- $string .= ($string ? ', ':'')."$M $month". ($M > 1 ? 's' : '');
- $Mm = $ym % ((60 * 60 * 24 * 365)/12);
- } else {
- $Mm = $ym;
- }
- return $string if ($limit eq 'M');
-
- if ($w = int($Mm / 604800)) {
- $string .= ($string ? ', ':'')."$w $week". ($w > 1 ? 's' : '');
- $wm = $Mm % 604800;
- } else {
- $wm = $Mm;
- }
- return $string if ($limit eq 'w');
-
- if ($d = int($wm / 86400)) {
- $string .= ($string ? ', ':'')."$d $day". ($d > 1 ? 's' : '');
- $dm = $wm % 86400;
- } else {
- $dm = $wm;
- }
- return $string if ($limit eq 'd');
-
- if ($h = int($dm / 3600)) {
- $string .= ($string ? ', ' : '')."$h $hour". ($h > 1 ? 's' : '');
- $hm = $dm % 3600;
- } else {
- $hm = $dm;
- }
- return $string if ($limit eq 'h');
-
- if ($m = int($hm / 60)) {
- $string .= ($string ? ', ':'')."$m $minute". ($m > 1 ? 's' : '');
- $mm = $hm % 60;
- } else {
- $mm = $hm;
- }
- return $string if ($limit eq 'm');
-
- if ($s = int($mm)) {
- $string .= ($string ? ', ':'')."$s $second". ($s > 1 ? 's' : '');
- } else {
- $string = "0s" unless ($string);
- }
- return $string;
-}
-
-sub full {
- my $self = shift;
- $$self{empty} = 0;
-}
-
-=head2 $utils_obj->set_psname('string') OR set_psname('string')
-
-Sets the name of this process in a B<ps> listing to B<string>.
-
-
-=cut
-
-sub set_psname {
- my $self = shift;
- my $PS_NAME = shift || $self;
- $0 = $PS_NAME if ($PS_NAME);
-}
-
-sub gmtime_ISO8601 {
- my $self = shift;
- my @date = gmtime;
-
- my $y = $date[5] + 1900;
- my $M = $date[4] + 1;
- my $d = $date[3];
- my $h = $date[2];
- my $m = $date[1];
- my $s = $date[0];
-
- return sprintf('%d-%0.2d-%0.2dT%0.2d:%0.2d:%0.2d+00:00', $y, $M, $d, $h, $m, $s);
-}
-
-sub clense_ISO8601 {
- my $self = shift;
- my $date = shift || $self;
- if ($date =~ /^\s*(\d{4})-?(\d{2})-?(\d{2})/o) {
- my $new_date = "$1-$2-$3";
-
- if ($date =~/(\d{2}):(\d{2}):(\d{2})/o) {
- $new_date .= "T$1:$2:$3";
-
- my $z;
- if ($date =~ /([-+]{1})([0-9]{1,2})(?::?([0-9]{1,2}))*\s*$/o) {
- $z = sprintf('%s%0.2d%0.2d',$1,$2,$3)
- } else {
- $z = DateTime::TimeZone::offset_as_string(
- DateTime::TimeZone
- ->new( name => 'local' )
- ->offset_for_datetime(
- $date_parser->parse_datetime($new_date)
- )
- );
- }
-
- if (length($z) > 3 && index($z, ':') == -1) {
- substr($z,3,0) = ':';
- substr($z,6,0) = ':' if (length($z) > 6);
- }
-
- $new_date .= $z;
- } else {
- $new_date .= "T00:00:00";
- }
-
- return $new_date;
- }
- return $date;
-}
-
-=head2 $utils_obj->daemonize('ps_name') OR daemonize('ps_name')
-
-Turns the current process into a daemon. B<ps_name> is optional, and is used
-as the argument to I<< set_psname() >> if passed.
-
-
-=cut
-
-sub daemonize {
- my $self = shift;
- my $PS_NAME = shift || $self;
- my $pid;
- if ($pid = safe_fork($self)) {
- exit 0;
- } elsif (defined($pid)) {
- set_psname($PS_NAME);
- chdir '/';
- setsid;
- return $$;
- }
-}
-
-=head2 $utils_obj->safe_fork('ps_name') OR safe_fork('ps_name');
-
-Forks the current process in a retry loop. B<ps_name> is optional, and is used
-as the argument to I<< set_psname() >> if passed.
-
-
-=cut
-
-sub safe_fork {
- my $self = shift;
- my $pid;
-
-FORK:
- {
- if (defined($pid = fork())) {
- srand(time ^ ($$ + ($$ << 15))) unless ($pid);
- return $pid;
- } elsif ($! == EAGAIN) {
- $self->error("Can't fork()! $!, taking 5 and trying again.") if (ref $self);
- sleep 5;
- redo FORK;
- } else {
- $self->error("Can't fork()! $!") if ($! && ref($self));
- exit $!;
- }
- }
-}
-
-#------------------------------------------------------------------------------------------------------------------------------------
-
-
-1;
+++ /dev/null
-package OpenSRF::Utils::Cache;
-use strict; use warnings;
-use base qw/OpenSRF/;
-use Cache::Memcached;
-use OpenSRF::Utils::Logger qw/:level/;
-use OpenSRF::Utils::Config;
-use OpenSRF::Utils::SettingsClient;
-use OpenSRF::EX qw(:try);
-use OpenSRF::Utils::JSON;
-
-my $log = 'OpenSRF::Utils::Logger';
-
-=head OpenSRF::Utils::Cache
-
-This class just subclasses Cache::Memcached.
-see Cache::Memcached for more options.
-
-The value passed to the call to current is the cache type
-you wish to access. The below example sets/gets data
-from the 'user' cache.
-
-my $cache = OpenSRF::Utils::Cache->current("user");
-$cache->set( "key1", "value1" [, $expire_secs ] );
-my $val = $cache->get( "key1" );
-
-
-=cut
-
-sub DESTROY {}
-
-my %caches;
-
-# ------------------------------------------------------
-# Persist methods and method names
-# ------------------------------------------------------
-my $persist_add_slot;
-my $persist_push_stack;
-my $persist_peek_stack;
-my $persist_destroy_slot;
-my $persist_slot_get_expire;
-my $persist_slot_find;
-
-my $max_persist_time;
-my $persist_add_slot_name = "opensrf.persist.slot.create_expirable";
-my $persist_push_stack_name = "opensrf.persist.stack.push";
-my $persist_peek_stack_name = "opensrf.persist.stack.peek";
-my $persist_destroy_slot_name = "opensrf.persist.slot.destroy";
-my $persist_slot_get_expire_name = "opensrf.persist.slot.get_expire";
-my $persist_slot_find_name = "opensrf.persist.slot.find";;
-
-# ------------------------------------------------------
-
-
-# return a named cache if it exists
-sub current {
- my ( $class, $c_type ) = @_;
- return undef unless $c_type;
- return $caches{$c_type} if exists $caches{$c_type};
- return $caches{$c_type} = $class->new( $c_type );
-}
-
-
-# create a new named memcache object.
-sub new {
-
- my( $class, $cache_type, $persist ) = @_;
- $cache_type ||= 'global';
- $class = ref( $class ) || $class;
-
- return $caches{$cache_type}
- if (defined $caches{$cache_type});
-
- my $conf = OpenSRF::Utils::SettingsClient->new;
- my $servers = $conf->config_value( cache => $cache_type => servers => 'server' );
- $max_persist_time = $conf->config_value( cache => $cache_type => 'max_cache_time' );
-
- if(!ref($servers)){
- $servers = [ $servers ];
- }
-
- my $self = {};
- $self->{persist} = $persist || 0;
- $self->{memcache} = Cache::Memcached->new( { servers => $servers } );
- if(!$self->{memcache}) {
- throw OpenSRF::EX::PANIC ("Unable to create a new memcache object for $cache_type");
- }
-
- bless($self, $class);
- $caches{$cache_type} = $self;
- return $self;
-}
-
-
-
-sub put_cache {
- my($self, $key, $value, $expiretime ) = @_;
- return undef unless( defined $key and defined $value );
-
- $value = OpenSRF::Utils::JSON->perl2JSON($value);
-
- if($self->{persist}){ _load_methods(); }
-
- $expiretime ||= $max_persist_time;
-
- unless( $self->{memcache}->set( $key, $value, $expiretime ) ) {
- $log->error("Unable to store $key => [".length($value)." bytes] in memcached server" );
- return undef;
- }
-
- $log->debug("Stored $key => $value in memcached server", INTERNAL);
-
- if($self->{"persist"}) {
-
- my ($slot) = $persist_add_slot->run("_CACHEVAL_$key", $expiretime . "s");
-
- if(!$slot) {
- # slot may already exist
- ($slot) = $persist_slot_find->run("_CACHEVAL_$key");
- if(!defined($slot)) {
- throw OpenSRF::EX::ERROR ("Unable to create cache slot $key in persist server" );
- } else {
- #XXX destroy the slot and rebuild it to prevent DOS
- }
- }
-
- ($slot) = $persist_push_stack->run("_CACHEVAL_$key", $value);
-
- if(!$slot) {
- throw OpenSRF::EX::ERROR ("Unable to push data onto stack in persist slot _CACHEVAL_$key" );
- }
- }
-
- return $key;
-}
-
-sub delete_cache {
- my( $self, $key ) = @_;
- if(!$key) { return undef; }
- if($self->{persist}){ _load_methods(); }
- $self->{memcache}->delete($key);
- if( $self->{persist} ) {
- $persist_destroy_slot->run("_CACHEVAL_$key");
- }
- return $key;
-}
-
-sub get_cache {
- my($self, $key ) = @_;
-
- my $val = $self->{memcache}->get( $key );
- return OpenSRF::Utils::JSON->JSON2perl($val) if defined($val);
-
- if($self->{persist}){ _load_methods(); }
-
- # if not in memcache but we are persisting, the put it into memcache
- if( $self->{"persist"} ) {
- $val = $persist_peek_stack->( "_CACHEVAL_$key" );
- if(defined($val)) {
- my ($expire) = $persist_slot_get_expire->run("_CACHEVAL_$key");
- if($expire) {
- $self->{memcache}->set( $key, $val, $expire);
- } else {
- $self->{memcache}->set( $key, $val, $max_persist_time);
- }
- return OpenSRF::Utils::JSON->JSON2perl($val);
- }
- }
- return undef;
-}
-
-
-
-
-sub _load_methods {
-
- if(!$persist_add_slot) {
- $persist_add_slot =
- OpenSRF::Application->method_lookup($persist_add_slot_name);
- if(!ref($persist_add_slot)) {
- throw OpenSRF::EX::PANIC ("Unable to retrieve method $persist_add_slot_name");
- }
- }
-
- if(!$persist_push_stack) {
- $persist_push_stack =
- OpenSRF::Application->method_lookup($persist_push_stack_name);
- if(!ref($persist_push_stack)) {
- throw OpenSRF::EX::PANIC ("Unable to retrieve method $persist_push_stack_name");
- }
- }
-
- if(!$persist_peek_stack) {
- $persist_peek_stack =
- OpenSRF::Application->method_lookup($persist_peek_stack_name);
- if(!ref($persist_peek_stack)) {
- throw OpenSRF::EX::PANIC ("Unable to retrieve method $persist_peek_stack_name");
- }
- }
-
- if(!$persist_destroy_slot) {
- $persist_destroy_slot =
- OpenSRF::Application->method_lookup($persist_destroy_slot_name);
- if(!ref($persist_destroy_slot)) {
- throw OpenSRF::EX::PANIC ("Unable to retrieve method $persist_destroy_slot_name");
- }
- }
- if(!$persist_slot_get_expire) {
- $persist_slot_get_expire =
- OpenSRF::Application->method_lookup($persist_slot_get_expire_name);
- if(!ref($persist_slot_get_expire)) {
- throw OpenSRF::EX::PANIC ("Unable to retrieve method $persist_slot_get_expire_name");
- }
- }
- if(!$persist_slot_find) {
- $persist_slot_find =
- OpenSRF::Application->method_lookup($persist_slot_find_name);
- if(!ref($persist_slot_find)) {
- throw OpenSRF::EX::PANIC ("Unable to retrieve method $persist_slot_find_name");
- }
- }
-}
-
-
-
-
-
-
-
-1;
-
+++ /dev/null
-package OpenSRF::Utils::Config::Section;
-
-no strict 'refs';
-
-use vars qw/@ISA $AUTOLOAD $VERSION/;
-push @ISA, qw/OpenSRF::Utils/;
-
-use OpenSRF::Utils (':common');
-use Net::Domain qw/hostfqdn/;
-
-$VERSION = do { my @r=(q$Revision$=~/\d+/g); sprintf "%d."."%02d"x$#r,@r };
-
-my %SECTIONCACHE;
-my %SUBSECTION_FIXUP;
-
-#use overload '""' => \&OpenSRF::Utils::Config::dump_ini;
-
-sub SECTION {
- my $sec = shift;
- return $sec->__id(@_);
-}
-
-sub new {
- my $self = shift;
- my $class = ref($self) || $self;
-
- $self = bless {}, $class;
-
- $self->_sub_builder('__id');
- # Hard-code this to match old bootstrap.conf section name
- $self->__id('bootstrap');
-
- my $bootstrap = shift;
-
- foreach my $key (sort keys %$bootstrap) {
- $self->_sub_builder($key);
- $self->$key($bootstrap->{$key});
- }
-
- return $self;
-}
-
-package OpenSRF::Utils::Config;
-
-use vars qw/@ISA $AUTOLOAD $VERSION $OpenSRF::Utils::ConfigCache/;
-push @ISA, qw/OpenSRF::Utils/;
-
-use FileHandle;
-use XML::LibXML;
-use OpenSRF::Utils (':common');
-use OpenSRF::Utils::Logger;
-use Net::Domain qw/hostfqdn/;
-
-#use overload '""' => \&OpenSRF::Utils::Config::dump_ini;
-
-sub import {
- my $class = shift;
- my $config_file = shift;
-
- return unless $config_file;
-
- $class->load( config_file => $config_file);
-}
-
-sub dump_ini {
- no warnings;
- my $self = shift;
- my $string;
- my $included = 0;
- if ($self->isa('OpenSRF::Utils::Config')) {
- if (UNIVERSAL::isa(scalar(caller()), 'OpenSRF::Utils::Config' )) {
- $included = 1;
- } else {
- $string = "# Main File: " . $self->FILE . "\n\n" . $string;
- }
- }
- for my $section ( ('__id', grep { $_ ne '__id' } sort keys %$self) ) {
- next if ($section eq 'env' && $self->isa('OpenSRF::Utils::Config'));
- if ($section eq '__id') {
- $string .= '['.$self->SECTION."]\n" if ($self->isa('OpenSRF::Utils::Config::Section'));
- } elsif (ref($self->$section)) {
- if (ref($self->$section) =~ /ARRAY/o) {
- $string .= "list:$section = ". join(', ', @{$self->$section}) . "\n";
- } elsif (UNIVERSAL::isa($self->$section,'OpenSRF::Utils::Config::Section')) {
- if ($self->isa('OpenSRF::Utils::Config::Section')) {
- $string .= "subsection:$section = " . $self->$section->SECTION . "\n";
- next;
- } else {
- next if ($self->$section->{__sub} && !$included);
- $string .= $self->$section . "\n";
- }
- } elsif (UNIVERSAL::isa($self->$section,'OpenSRF::Utils::Config')) {
- $string .= $self->$section . "\n";
- }
- } else {
- next if $section eq '__sub';
- $string .= "$section = " . $self->$section . "\n";
- }
- }
- if ($included) {
- $string =~ s/^/## /gm;
- $string = "# Subfile: " . $self->FILE . "\n#" . '-'x79 . "\n".'#include "'.$self->FILE."\"\n". $string;
- }
-
- return $string;
-}
-
-=head1 NAME
-
-OpenSRF::Utils::Config
-
-
-=head1 SYNOPSIS
-
-
- use OpenSRF::Utils::Config;
-
- my $config_obj = OpenSRF::Utils::Config->load( config_file => '/config/file.cnf' );
-
- my $attrs_href = $config_obj->bootstrap();
-
- $config_obj->bootstrap->loglevel(0);
-
- open FH, '>'.$config_obj->FILE() . '.new';
- print FH $config_obj;
- close FH;
-
-
-
-=head1 DESCRIPTION
-
-
-This module is mainly used by other OpenSRF modules to load an OpenSRF configuration file.
-OpenSRF configuration files are XML files that contain a C<< <config> >> root element and an C<< <opensrf> >>
-child element (in XPath notation, C</config/opensrf/>). Each child element is converted into a
-hash key=>value pair. Elements that contain other XML elements are pushed into arrays and added
-as an array reference to the hash. Scalar values have whitespace trimmed from the left and right
-sides.
-
-Child elements of C<< <config> >> other than C<< <opensrf> >> are currently ignored by this module.
-
-=head1 EXAMPLE
-
-Given an OpenSRF configuration file named F<opensrf_core.xml> with the following content:
-
- <?xml version='1.0'?>
- <config>
- <opensrf>
- <router_name>router</router_name>
-
- <routers>
- <router>localhost</router>
- <router>otherhost</router>
- </routers>
-
- <logfile>LOCALSTATEDIR/log/osrfsys.log</logfile>
- </opensrf>
- </config>
-
-... calling C<< OpenSRF::Utils::Config->load(config_file => 'opensrf_core.xml') >> will create a hash
-with the following structure:
-
- {
- router_name => 'router',
- routers => ['localhost', 'otherhost'],
- logfile => 'LOCALSTATEDIR/log/osrfsys.log'
- }
-
-You can retrieve any of these values by name from the bootstrap section of C<$config_obj>; for example:
-
- $config_obj->bootstrap->router_name
-
-=head1 NOTES
-
-For compatibility with a previous version of OpenSRF configuration files, the F</config/opensrf/> section
-has a hardcoded name of B<bootstrap>. However, future iterations of this module may extend the ability
-of the module to parse the entire OpenSRF configuration file and provide sections named after the sibling
-elements of C</config/opensrf>.
-
-Hashrefs of sections can be returned by calling a method of the object of the same name as the section.
-They can be set by passing a hashref back to the same method. Sections will B<NOT> be autovivicated, though.
-
-
-=head1 METHODS
-
-
-=cut
-
-
-$VERSION = do { my @r=(q$Revision$=~/\d+/g); sprintf "%d."."%02d"x$#r,@r };
-
-
-=head2 OpenSRF::Utils::Config->load( config_file => '/some/config/file.cnf' )
-
-Returns a OpenSRF::Utils::Config object representing the config file that was loaded.
-The most recently loaded config file (hopefully the only one per app)
-is stored at $OpenSRF::Utils::ConfigCache. Use OpenSRF::Utils::Config::current() to get at it.
-
-
-=cut
-
-sub load {
- my $pkg = shift;
- $pkg = ref($pkg) || $pkg;
-
- my %args = @_;
-
- (my $new_pkg = $args{config_file}) =~ s/\W+/_/g;
- $new_pkg .= "::$pkg";
- $new_section_pkg .= "${new_pkg}::Section";
-
- { eval <<" PERL";
-
- package $new_pkg;
- use base $pkg;
- sub section_pkg { return '$new_section_pkg'; }
-
- package $new_section_pkg;
- use base "${pkg}::Section";
-
- PERL
- }
-
- return $new_pkg->_load( %args );
-}
-
-sub _load {
- my $pkg = shift;
- $pkg = ref($pkg) || $pkg;
- my $self = {@_};
- bless $self, $pkg;
-
- no warnings;
- if ((exists $$self{config_file} and OpenSRF::Utils::Config->current) and (OpenSRF::Utils::Config->current->FILE eq $$self{config_file}) and (!$self->{force})) {
- delete $$self{force};
- return OpenSRF::Utils::Config->current();
- }
-
- $self->_sub_builder('__id');
- $self->FILE($$self{config_file});
- delete $$self{config_file};
- return undef unless ($self->FILE);
-
- $self->load_config();
- $self->load_env();
- $self->mangle_dirs();
- $self->mangle_logs();
-
- $OpenSRF::Utils::ConfigCache = $self unless $self->nocache;
- delete $$self{nocache};
- delete $$self{force};
- return $self;
-}
-
-sub sections {
- my $self = shift;
- my %filters = @_;
-
- my @parts = (grep { UNIVERSAL::isa($_,'OpenSRF::Utils::Config::Section') } values %$self);
- if (keys %filters) {
- my $must_match = scalar(keys %filters);
- my @ok_parts;
- foreach my $part (@parts) {
- my $part_count = 0;
- for my $fkey (keys %filters) {
- $part_count++ if ($part->$key eq $filters{$key});
- }
- push @ok_parts, $part if ($part_count == $must_match);
- }
- return @ok_parts;
- }
- return @parts;
-}
-
-sub current {
- return $OpenSRF::Utils::ConfigCache;
-}
-
-sub FILE {
- return shift()->__id(@_);
-}
-
-sub load_env {
- my $self = shift;
- my $host = $ENV{'OSRF_HOSTNAME'} || hostfqdn();
- chomp $host;
- $$self{env} = $self->section_pkg->new;
- $$self{env}{hostname} = $host;
-}
-
-sub mangle_logs {
- my $self = shift;
- return unless ($self->logs && $self->dirs && $self->dirs->log_dir);
- for my $i ( keys %{$self->logs} ) {
- next if ($self->logs->$i =~ /^\//);
- $self->logs->$i($self->dirs->log_dir."/".$self->logs->$i);
- }
-}
-
-sub mangle_dirs {
- my $self = shift;
- return unless ($self->dirs && $self->dirs->base_dir);
- for my $i ( keys %{$self->dirs} ) {
- if ( $i ne 'base_dir' ) {
- next if ($self->dirs->$i =~ /^\//);
- my $dir_tmp = $self->dirs->base_dir."/".$self->dirs->$i;
- $dir_tmp =~ s#//#/#go;
- $dir_tmp =~ s#/$##go;
- $self->dirs->$i($dir_tmp);
- }
- }
-}
-
-sub load_config {
- my $self = shift;
- my $parser = XML::LibXML->new();
-
- # Hash of config values
- my %bootstrap;
-
- # Return an XML::LibXML::Document object
- my $config = $parser->parse_file($self->FILE);
-
- unless ($config) {
- OpenSRF::Utils::Logger->error("Could not open ".$self->FILE.": $!\n");
- die "Could not open ".$self->FILE.": $!\n";
- }
-
- # Return an XML::LibXML::NodeList object matching all child elements
- # of <config><opensrf>...
- my $osrf_cfg = $config->findnodes('/config/opensrf/child::*');
-
- # Iterate through the nodes to pull out key=>value pairs of config settings
- foreach my $node ($osrf_cfg->get_nodelist()) {
- my $child_state = 0;
-
- # This will be overwritten if it's a scalar setting
- $bootstrap{$node->nodeName()} = [];
-
- foreach my $child_node ($node->childNodes) {
- # from libxml/tree.h: nodeType 1 = ELEMENT_NODE
- next if $child_node->nodeType() != 1;
-
- # If the child node is an element, this element may
- # have multiple values; therefore, push it into an array
- my $content = OpenSRF::Utils::Config::extract_child($child_node);
- push(@{$bootstrap{$node->nodeName()}}, $content) if $content;
- $child_state = 1;
- }
- if (!$child_state) {
- $bootstrap{$node->nodeName()} = OpenSRF::Utils::Config::extract_text($node->textContent);
- }
- }
-
- my $section = $self->section_pkg->new(\%bootstrap);
- my $sub_name = $section->SECTION;
- $self->_sub_builder($sub_name);
- $self->$sub_name($section);
-
-}
-sub extract_child {
- my $node = shift;
- use OpenSRF::Utils::SettingsParser;
- return OpenSRF::Utils::SettingsParser::XML2perl($node);
-}
-
-sub extract_text {
- my $self = shift;
- $self =~ s/^\s*([.*?])\s*$//m;
- return $self;
-}
-
-#------------------------------------------------------------------------------------------------------------------------------------
-
-=head1 SEE ALSO
-
- OpenSRF::Utils
-
-=head1 LIMITATIONS
-
-Elements containing heterogeneous child elements are treated as though they have the same element name;
-for example:
- <routers>
- <router>localhost</router>
- <furniture>chair</furniture>
- </routers>
-
-... will simply generate a key=>value pair of C<< routers => ['localhost', 'chair'] >>.
-
-=head1 BUGS
-
-No known bugs, but report any to open-ils-dev@list.georgialibraries.org or mrylander@gmail.com.
-
-=head1 COPYRIGHT AND LICENSING
-
-Copyright (C) 2000-2007, Mike Rylander
-Copyright (C) 2007, Laurentian University, Dan Scott <dscott@laurentian.ca>
-
-The OpenSRF::Utils::Config module is free software. You may distribute under the terms
-of the GNU General Public License version 2 or greater.
-
-=cut
-
-
-1;
+++ /dev/null
-package OpenSRF::Utils::JSON;
-use JSON::XS;
-use vars qw/%_class_map/;
-
-my $parser = JSON::XS->new;
-$parser->ascii(1); # output \u escaped strings
-$parser->allow_nonref(1);
-
-sub true {
- return $parser->true();
-}
-
-sub false {
- return $parser->false();
-}
-
-sub register_class_hint {
- my $class = shift;
- my %args = @_;
- $_class_map{hints}{$args{hint}} = \%args;
- $_class_map{classes}{$args{name}} = \%args;
-}
-
-sub lookup_class {
- my $self = shift;
- my $hint = shift;
- return $_class_map{hints}{$hint}{name}
-}
-
-sub lookup_hint {
- my $self = shift;
- my $class = shift;
- return $_class_map{classes}{$class}{hint}
-}
-
-sub _json_hint_to_class {
- my $type = shift;
- my $hint = shift;
-
- return $_class_map{hints}{$hint}{name} if (exists $_class_map{hints}{$hint});
-
- $type = 'hash' if ($type eq '}');
- $type = 'array' if ($type eq ']');
-
- OpenSRF::Utils::JSON->register_class_hint(name => $hint, hint => $hint, type => $type);
-
- return $hint;
-}
-
-
-my $JSON_CLASS_KEY = '__c';
-my $JSON_PAYLOAD_KEY = '__p';
-
-sub JSON2perl {
- my( $class, $string ) = @_;
- my $perl = $class->rawJSON2perl($string);
- return $class->JSONObject2Perl($perl);
-}
-
-sub perl2JSON {
- my( $class, $obj ) = @_;
- my $json = $class->perl2JSONObject($obj);
- return $class->rawPerl2JSON($json);
-}
-
-sub JSONObject2Perl {
- my $class = shift;
- my $obj = shift;
- my $ref = ref($obj);
- if( $ref eq 'HASH' ) {
- if( defined($obj->{$JSON_CLASS_KEY})) {
- my $cls = $obj->{$JSON_CLASS_KEY};
- $cls =~ s/^\s+//o;
- $cls =~ s/\s+$//o;
- if( $obj = $class->JSONObject2Perl($obj->{$JSON_PAYLOAD_KEY}) ) {
- $cls = $class->lookup_class($cls) || $cls;
- return bless(\$obj, $cls) unless ref($obj);
- return bless($obj, $cls);
- }
- return undef;
- }
- $obj->{$_} = $class->JSONObject2Perl($obj->{$_}) for (keys %$obj);
- } elsif( $ref eq 'ARRAY' ) {
- $obj->[$_] = $class->JSONObject2Perl($obj->[$_]) for(0..scalar(@$obj) - 1);
- }
- return $obj;
-}
-
-sub perl2JSONObject {
- my $class = shift;
- my $obj = shift;
- my $ref = ref($obj);
-
- return $obj unless $ref;
-
- return $obj if $ref eq 'JSON::XS::Boolean';
- my $newobj;
-
- if(UNIVERSAL::isa($obj, 'HASH')) {
- $newobj = {};
- $newobj->{$_} = $class->perl2JSONObject($obj->{$_}) for (keys %$obj);
- } elsif(UNIVERSAL::isa($obj, 'ARRAY')) {
- $newobj = [];
- $newobj->[$_] = $class->perl2JSONObject($obj->[$_]) for(0..scalar(@$obj) - 1);
- }
-
- if($ref ne 'HASH' and $ref ne 'ARRAY') {
- $ref = $class->lookup_hint($ref) || $ref;
- $newobj = {$JSON_CLASS_KEY => $ref, $JSON_PAYLOAD_KEY => $newobj};
- }
-
- return $newobj;
-}
-
-
-sub rawJSON2perl {
- my $class = shift;
- my $json = shift;
- return undef unless defined $json and $json !~ /^\s*$/o;
- return $parser->decode($json);
-}
-
-sub rawPerl2JSON {
- my ($class, $perl) = @_;
- return $parser->encode($perl);
-}
-
-1;
+++ /dev/null
-package OpenSRF::Utils::LogServer;
-use strict; use warnings;
-use base qw(OpenSRF);
-use IO::Socket::INET;
-use FileHandle;
-use OpenSRF::Utils::Config;
-use Fcntl;
-use Time::HiRes qw(gettimeofday);
-use OpenSRF::Utils::Logger;
-
-=head2 Name
-
-OpenSRF::Utils::LogServer
-
-=cut
-
-=head2 Synopsis
-
-Networ Logger
-
-=cut
-
-=head2 Description
-
-
-=cut
-
-
-
-our $config;
-our $port;
-our $bufsize = 4096;
-our $proto;
-our @file_info;
-
-
-sub DESTROY {
- for my $file (@file_info) {
- if( $file->handle ) {
- close( $file->handle );
- }
- }
-}
-
-
-sub serve {
-
- $config = OpenSRF::Utils::Config->current;
-
- unless ($config) { throw OpenSRF::EX::Config ("No suitable config found"); }
-
- $port = $config->system->log_port;
- $proto = $config->system->log_proto;
-
-
- my $server = IO::Socket::INET->new(
- LocalPort => $port,
- Proto => $proto )
- or die "Error creating server socket : $@\n";
-
-
-
- while ( 1 ) {
- my $client = <$server>;
- process( $client );
- }
-
- close( $server );
-}
-
-sub process {
- my $client = shift;
- my @params = split(/\|/,$client);
- my $log = shift @params;
-
- if( (!$log) || (!@params) ) {
- warn "Invalid logging params: $log\n";
- return;
- }
-
- # Put |'s back in since they are stripped
- # from the message by 'split'
- my $message;
- if( @params > 1 ) {
- foreach my $param (@params) {
- if( $param ne $params[0] ) {
- $message .= "|";
- }
- $message .= $param;
- }
- }
- else{ $message = "@params"; }
-
- my @lines = split( "\n", $message );
- my $time = format_time();
-
- my $fh;
-
- my ($f_obj) = grep { $_->name eq $log } @file_info;
-
- unless( $f_obj and ($fh=$f_obj->handle) ) {
- my $file = $config->logs->$log;
-
- sysopen( $fh, $file, O_WRONLY|O_APPEND|O_CREAT )
- or warn "Cannot sysopen $log: $!";
- $fh->autoflush(1);
-
- my $obj = new OpenSRF::Utils::NetLogFile( $log, $file, $fh );
- push @file_info, $obj;
- }
-
- foreach my $line (@lines) {
- print $fh "$time $line\n" || die "$!";
- }
-
-}
-
-sub format_time {
- my ($s, $ms) = gettimeofday();
- my @time = localtime( $s );
- $ms = substr( $ms, 0, 3 );
- my $year = $time[5] + 1900;
- my $mon = $time[4] + 1;
- my $day = $time[3];
- my $hour = $time[2];
- my $min = $time[1];
- my $sec = $time[0];
- $mon = "0" . "$mon" if ( length($mon) == 1 );
- $day = "0" . "$day" if ( length($day) == 1 );
- $hour = "0" . "$hour" if ( length($hour) == 1 );
- $min = "0" . "$min" if (length($min) == 1 );
- $sec = "0" . "$sec" if (length($sec) == 1 );
-
- my $proc = $$;
- while( length( $proc ) < 5 ) { $proc = "0" . "$proc"; }
- return "[$year-$mon-$day $hour:$min:$sec.$ms $proc]";
-}
-
-
-package OpenSRF::Utils::NetLogFile;
-
-sub new{ return bless( [ $_[1], $_[2], $_[3] ], $_[0] ); }
-
-sub name { return $_[0]->[0]; }
-sub file { return $_[0]->[1]; }
-sub handle { return $_[0]->[2]; }
-
-
-1;
+++ /dev/null
-package OpenSRF::Utils::Logger;
-# vim:ts=4:noet:
-use strict;
-use vars qw($AUTOLOAD @EXPORT_OK %EXPORT_TAGS);
-use Exporter;
-use Unix::Syslog qw(:macros :subs);
-use base qw/OpenSRF Exporter/;
-use FileHandle;
-use Time::HiRes qw(gettimeofday);
-use OpenSRF::Utils::Config;
-use Fcntl;
-
-=head1
-
-Logger code
-
-my $logger = OpenSRF::Utils::Logger;
-$logger->error( $msg );
-
-For backwards compability, a log level may also be provided to each log
-function thereby overriding the level defined by the function.
-
-i.e. $logger->error( $msg, WARN ); # logs at log level WARN
-
-=cut
-
-@EXPORT_OK = qw/ NONE ERROR WARN INFO DEBUG INTERNAL /;
-push @EXPORT_OK, '$logger';
-
-%EXPORT_TAGS = ( level => [ qw/ NONE ERROR WARN INFO DEBUG INTERNAL / ], logger => [ '$logger' ] );
-
-my $config; # config handle
-my $loglevel = INFO(); # global log level
-my $logfile; # log file
-my $facility; # syslog facility
-my $actfac; # activity log syslog facility
-my $actfile; # activity log file
-my $service = $0; # default service name
-my $syslog_enabled = 0; # is syslog enabled?
-my $act_syslog_enabled = 0; # is syslog enabled?
-my $logfile_enabled = 1; # are we logging to a file?
-my $act_logfile_enabled = 1; # are we logging to a file?
-
-our $logger = "OpenSRF::Utils::Logger";
-
-# log levels
-sub ACTIVITY { return -1; }
-sub NONE { return 0; }
-sub ERROR { return 1; }
-sub WARN { return 2; }
-sub INFO { return 3; }
-sub DEBUG { return 4; }
-sub INTERNAL { return 5; }
-sub ALL { return 100; }
-
-my $isclient; # true if we control the osrf_xid
-
-# load up our config options
-sub set_config {
-
- return if defined $config;
-
- $config = OpenSRF::Utils::Config->current;
- if( !defined($config) ) {
- $loglevel = INFO();
- warn "*** Logger found no config. Using STDERR ***\n";
- return;
- }
-
- $loglevel = $config->bootstrap->loglevel;
-
- $logfile = $config->bootstrap->logfile;
- if($logfile =~ /^syslog/) {
- $syslog_enabled = 1;
- $logfile_enabled = 0;
- $logfile = $config->bootstrap->syslog;
- $facility = $logfile;
- $logfile = undef;
- $facility = _fac_to_const($facility);
- openlog($service, 0, $facility);
-
- } else { $logfile = "$logfile"; }
-
-
- if($syslog_enabled) {
- # --------------------------------------------------------------
- # if we're syslogging, see if we have a special syslog facility
- # for activity logging. If not, use the syslog facility for
- # standard logging
- # --------------------------------------------------------------
- $act_syslog_enabled = 1;
- $act_logfile_enabled = 0;
- $actfac = $config->bootstrap->actlog || $config->bootstrap->syslog;
- $actfac = _fac_to_const($actfac);
- $actfile = undef;
- } else {
- # --------------------------------------------------------------
- # we're not syslogging, use any specified activity log file.
- # Fall back to the standard log file otherwise
- # --------------------------------------------------------------
- $act_syslog_enabled = 0;
- $act_logfile_enabled = 1;
- $actfile = $config->bootstrap->actlog || $config->bootstrap->logfile;
- }
-
- my $client = OpenSRF::Utils::Config->current->bootstrap->client();
- if (!$client) {
- $isclient = 0;
- return;
- }
- $isclient = ($client =~ /^true$/iog) ? 1 : 0;
-}
-
-sub _fac_to_const {
- my $name = shift;
- return LOG_LOCAL0 unless $name;
- return LOG_LOCAL0 if $name =~ /local0/i;
- return LOG_LOCAL1 if $name =~ /local1/i;
- return LOG_LOCAL2 if $name =~ /local2/i;
- return LOG_LOCAL3 if $name =~ /local3/i;
- return LOG_LOCAL4 if $name =~ /local4/i;
- return LOG_LOCAL5 if $name =~ /local5/i;
- return LOG_LOCAL6 if $name =~ /local6/i;
- return LOG_LOCAL7 if $name =~ /local7/i;
- return LOG_LOCAL0;
-}
-
-sub is_syslog {
- set_config();
- return $syslog_enabled;
-}
-
-sub is_act_syslog {
- set_config();
- return $act_syslog_enabled;
-}
-
-sub is_filelog {
- set_config();
- return $logfile_enabled;
-}
-
-sub is_act_filelog {
- set_config();
- return $act_logfile_enabled;
-}
-
-sub set_service {
- my( $self, $svc ) = @_;
- $service = $svc;
- if( is_syslog() ) {
- closelog();
- openlog($service, 0, $facility);
- }
-}
-
-sub error {
- my( $self, $msg, $level ) = @_;
- $level = ERROR() unless defined ($level);
- _log_message( $msg, $level );
-}
-
-sub warn {
- my( $self, $msg, $level ) = @_;
- $level = WARN() unless defined ($level);
- _log_message( $msg, $level );
-}
-
-sub info {
- my( $self, $msg, $level ) = @_;
- $level = INFO() unless defined ($level);
- _log_message( $msg, $level );
-}
-
-sub debug {
- my( $self, $msg, $level ) = @_;
- $level = DEBUG() unless defined ($level);
- _log_message( $msg, $level );
-}
-
-sub internal {
- my( $self, $msg, $level ) = @_;
- $level = INTERNAL() unless defined ($level);
- _log_message( $msg, $level );
-}
-
-sub activity {
- my( $self, $msg ) = @_;
- _log_message( $msg, ACTIVITY() );
-}
-
-# for backward compability
-sub transport {
- my( $self, $msg, $level ) = @_;
- $level = DEBUG() unless defined ($level);
- _log_message( $msg, $level );
-}
-
-
-# ----------------------------------------------------------------------
-# creates a new xid if necessary
-# ----------------------------------------------------------------------
-my $osrf_xid = '';
-my $osrf_xid_inc = 0;
-sub mk_osrf_xid {
- return unless $isclient;
- $osrf_xid_inc++;
- return $osrf_xid = "$^T${$}$osrf_xid_inc";
-}
-
-sub set_osrf_xid {
- return if $isclient; # if we're a client, we control our xid
- $osrf_xid = $_[1];
-}
-
-sub get_osrf_xid { return $osrf_xid; }
-# ----------------------------------------------------------------------
-
-
-sub _log_message {
- my( $msg, $level ) = @_;
- return if $level > $loglevel;
-
- my $l; my $n;
- my $fac = $facility;
-
- if ($level == ERROR()) {$l = LOG_ERR; $n = "ERR "; }
- elsif ($level == WARN()) {$l = LOG_WARNING; $n = "WARN"; }
- elsif ($level == INFO()) {$l = LOG_INFO; $n = "INFO"; }
- elsif ($level == DEBUG()) {$l = LOG_DEBUG; $n = "DEBG"; }
- elsif ($level == INTERNAL()) {$l = LOG_DEBUG; $n = "INTL"; }
- elsif ($level == ACTIVITY()) {$l = LOG_INFO; $n = "ACT"; $fac = $actfac; }
-
- my( undef, $file, $line_no ) = caller(1);
- $file =~ s#/.*/##og;
-
- # help syslog with the formatting
- $msg =~ s/\%/\%\%/gso if( is_act_syslog() or is_syslog() );
-
- $msg = "[$n:"."$$".":$file:$line_no:$osrf_xid] $msg";
-
- $msg = substr($msg, 0, 1536);
-
- if( $level == ACTIVITY() ) {
- if( is_act_syslog() ) { syslog( $fac | $l, $msg ); }
- elsif( is_act_filelog() ) { _write_file( $msg, 1 ); }
-
- } else {
- if( is_syslog() ) { syslog( $fac | $l, $msg ); }
- elsif( is_filelog() ) { _write_file($msg); }
- }
-}
-
-
-sub _write_file {
- my( $msg, $isact) = @_;
- my $file = $logfile;
- $file = $actfile if $isact;
- my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime(time);
- $year += 1900; $mon += 1;
- sysopen( SINK, $file, O_NONBLOCK|O_WRONLY|O_APPEND|O_CREAT )
- or die "Cannot sysopen $logfile: $!";
- binmode(SINK, ':utf8');
- printf SINK "[%04d-%02d-%02d %02d:%02d:%02d] %s %s\n", $year, $mon, $mday, $hour, $min, $sec, $service, $msg;
- close( SINK );
-}
-
-
-
-1;
+++ /dev/null
-use strict; use warnings;
-package OpenSRF::Utils::SettingsClient;
-use OpenSRF::Utils::SettingsParser;
-use OpenSRF::System;
-use OpenSRF::AppSession;
-use OpenSRF::Utils::Config;
-use OpenSRF::EX qw(:try);
-
-use vars qw/$host_config/;
-
-
-sub new {return bless({},shift());}
-my $session;
-$host_config = undef;
-
-my $we_cache = 1;
-sub set_cache {
- my($self, $val) = @_;
- if(defined($val)) { $we_cache = $val; }
-}
-
-sub has_config {
- if($host_config) { return 1; }
- return 0;
-}
-
-
-# ------------------------------------
-# utility method for grabbing config info
-sub config_value {
- my($self,@keys) = @_;
-
-
- my $bsconfig = OpenSRF::Utils::Config->current;
- die "No bootstrap config exists. Have you bootstrapped?\n" unless $bsconfig;
- my $host = $bsconfig->env->hostname;
-
- if($we_cache) {
- if(!$host_config) { grab_host_config($host); }
- } else {
- grab_host_config($host);
- }
-
- if(!$host_config) {
- throw OpenSRF::EX::Config ("Unable to retrieve host config for $host" );
- }
-
- my $hash = $host_config;
-
- # XXX TO DO, check local config 'version',
- # call out to settings server when necessary....
- try {
- for my $key (@keys) {
- if(!ref($hash) eq 'HASH'){
- return undef;
- }
- $hash = $hash->{$key};
- }
-
- } catch Error with {
- my $e = shift;
- throw OpenSRF::EX::Config ("No Config information for @keys : $e : $@");
- };
-
- return $hash;
-
-}
-
-
-# XXX make smarter and more robust...
-sub grab_host_config {
-
- my $host = shift;
-
- $session = OpenSRF::AppSession->create( "opensrf.settings" ) unless $session;
- my $bsconfig = OpenSRF::Utils::Config->current;
-
- my $resp;
- my $req;
- try {
-
- if( ! ($session->connect()) ) {die "Settings Connect timed out\n";}
- $req = $session->request( "opensrf.settings.host_config.get", $host );
- $resp = $req->recv( timeout => 10 );
-
- } catch OpenSRF::EX with {
-
- if( ! ($session->connect()) ) {die "Settings Connect timed out\n";}
- $req = $session->request( "opensrf.settings.default_config.get" );
- $resp = $req->recv( timeout => 10 );
-
- } catch Error with {
-
- my $e = shift;
- warn "Connection to Settings Failed $e : $@ ***\n";
- die $e;
-
- } otherwise {
-
- my $e = shift;
- warn "Settings Retrieval Failed $e : $@ ***\n";
- die $e;
- };
-
- if(!$resp) {
- warn "No Response from settings server...going to sleep\n";
- sleep;
- }
-
- if( $resp && UNIVERSAL::isa( $resp, "OpenSRF::EX" ) ) {
- throw $resp;
- }
-
- $host_config = $resp->content();
- $req->finish();
- $session->disconnect();
- $session->finish;
- $session->kill_me();
-}
-
-
-
-1;
+++ /dev/null
-use strict; use warnings;
-package OpenSRF::Utils::SettingsParser;
-use OpenSRF::Utils::Config;
-use OpenSRF::EX qw(:try);
-
-
-
-use XML::LibXML;
-
-sub DESTROY{}
-our $log = 'OpenSRF::Utils::Logger';
-my $parser;
-my $doc;
-
-sub new { return bless({},shift()); }
-
-
-# returns 0 if the config file could not be found or if there is a parse error
-# returns 1 if successful
-sub initialize {
-
- my ($self,$bootstrap_config) = @_;
- return 0 unless($self and $bootstrap_config);
-
- $parser = XML::LibXML->new();
- $parser->keep_blanks(0);
- try {
- $doc = $parser->parse_file( $bootstrap_config );
- } catch Error with {
- return 0;
- };
- return 1;
-}
-
-sub _get { _get_overlay(@_) }
-
-sub _get_overlay {
- my( $self, $xpath ) = @_;
- my @nodes = $doc->documentElement->findnodes( $xpath );
-
- my $base = XML2perl(shift(@nodes));
- my @overlays;
- for my $node (@nodes) {
- push @overlays, XML2perl($node);
- }
-
- for my $ol ( @overlays ) {
- $base = merge_perl($base, $ol);
- }
-
- return $base;
-}
-
-sub _get_all {
- my( $self, $xpath ) = @_;
- my @nodes = $doc->documentElement->findnodes( $xpath );
-
- my @overlays;
- for my $node (@nodes) {
- push @overlays, XML2perl($node);
- }
-
- return \@overlays;
-}
-
-sub merge_perl {
- my $base = shift;
- my $ol = shift;
-
- if (ref($ol)) {
- if (ref($ol) eq 'HASH') {
- for my $key (keys %$ol) {
- if (ref($$ol{$key}) and ref($$ol{$key}) eq ref($$base{$key})) {
- merge_perl($$base{$key}, $$ol{$key});
- } else {
- $$base{$key} = $$ol{$key};
- }
- }
- } else {
- for my $key (0 .. scalar(@$ol) - 1) {
- if (ref($$ol[$key]) and ref($$ol[$key]) eq ref($$base[$key])) {
- merge_perl($$base[$key], $$ol[$key]);
- } else {
- $$base[$key] = $$ol[$key];
- }
- }
- }
- } else {
- $base = $ol;
- }
-
- return $base;
-}
-
-sub _check_for_int {
- my $value = shift;
- return 0+$value if ($value =~ /^\d{1,10}$/o);
- return $value;
-}
-
-sub XML2perl {
- my $node = shift;
- my %output;
-
- return undef unless($node);
-
- for my $attr ( ($node->attributes()) ) {
- next unless($attr);
- $output{$attr->nodeName} = _check_for_int($attr->value);
- }
-
- my @kids = $node->childNodes;
- if (@kids == 1 && $kids[0]->nodeType == 3) {
- return _check_for_int($kids[0]->textContent);
- } else {
- for my $kid ( @kids ) {
- next if ($kid->nodeName eq 'comment');
- if (exists $output{$kid->nodeName}) {
- if (ref $output{$kid->nodeName} ne 'ARRAY') {
- $output{$kid->nodeName} = [$output{$kid->nodeName}, XML2perl($kid)];
- } else {
- push @{$output{$kid->nodeName}}, XML2perl($kid);
- }
- next;
- }
- $output{$kid->nodeName} = XML2perl($kid);
- }
- }
-
- return \%output;
-}
-
-
-# returns the full config hash for a given server
-sub get_server_config {
- my( $self, $server ) = @_;
- my $xpath = "/opensrf/default|/opensrf/hosts/$server";
- return $self->_get( $xpath );
-}
-
-sub get_default_config {
- my( $self, $server ) = @_;
- my $xpath = "/opensrf/default";
- return $self->_get( $xpath );
-}
-
-sub get_bootstrap_config {
- my( $self ) = @_;
- my $xpath = "/opensrf/bootstrap";
- return $self->_get( $xpath );
-}
-
-sub get_router_config {
- my( $self, $router ) = @_;
- my $xpath = "/opensrf/routers/$router";
- return $self->_get($xpath );
-}
-
-
-
-
-1;
projects / working / OpenSRF.git / commitdiff