CipUX-RPC-Client-3.4.0.7000755001750001750 011424126732 15310 5ustar00ckuelkerckuelker000000000000CipUX-RPC-Client-3.4.0.7/MANIFEST000444001750001750 31411424126732 16554 0ustar00ckuelkerckuelker000000000000Build.PL Changes doc/examples/readme.mkd lib/CipUX/RPC/Client.pm Makefile.PL MANIFEST This list of files MANIFEST.SKIP META.yml README t/00-load.t t/perlcritic.t t/perlcriticrc t/pod-coverage.t t/pod.t CipUX-RPC-Client-3.4.0.7/Build.PL000444001750001750 276711424126732 16755 0ustar00ckuelkerckuelker000000000000use strict; use warnings; use Module::Build; use version; our $VERSION = qv('3.4.0.7'); my $builder = Module::Build->new( module_name => 'CipUX::RPC::Client', license => 'gpl2', dist_author => 'Christian Kuelker ', dist_version => $VERSION, dist_abstract => 'Generic CipUX XML-RPC client library', # create_makefile_pl => 'traditional', # create_readme => 1, # verbose => 1, installdirs => 'vendor', meta_merge => { resources => { homepage => q(http://www.cipux.org), }, }, recommends => { 'File::Spec' => 0, 'Test::More' => 0, 'Test::Perl::Critic' => 0, 'Test::Pod' => '1.14', 'Test::Pod::Coverage' => '1.04', }, build_requires => {}, requires => { 'Carp' => 0, 'CipUX' => '3.4.0.0', 'Class::Std' => '0.0.9', 'Data::Dumper' => 0, 'English' => 0, 'Frontier::Client' => 0, 'Log::Log4perl' => 0, 'Readonly' => 0, 'version' => 0, }, mkd_files => { 'doc/examples/readme.mkd' => 'mydoc/examples/readme.mkd', }, install_path => { 'mydoc' => '/usr/share/doc/cipux-rpc-client' }, add_to_cleanup => ['CipUX-RPC-Client-*'], ); # BUILD target #$builder->do_create_readme(); #$builder->do_create_makefile_pl(); $builder->add_build_element('mkd'); $builder->create_build_script(); CipUX-RPC-Client-3.4.0.7/README000444001750001750 144711424126732 16333 0ustar00ckuelkerckuelker000000000000CipUX-RPC-Client version 3.4.0.7 Base Class for CipUX XML-RPC Clients. INSTALLATION To install this module, preferably run the following commands: perl Build.PL ./Build ./Build test ./Build install Alternatively, to install with ExtUtils::MakeMaker, you can use the following commands: perl Makefile.PL make make test make install DEPENDENCIES Carp CipUX Class::Std Data::Dumper English Frontier::Client Log::Log4perl Readonly version COPYRIGHT AND LICENSE Copyright (C) 2009 by Christian Kuelker This library is licensed under the GNU GPL - GNU General Public License version 2 or (at your opinion) any later version. CipUX-RPC-Client-3.4.0.7/META.yml000444001750001750 144611424126732 16723 0ustar00ckuelkerckuelker000000000000--- abstract: 'Generic CipUX XML-RPC client library' author: - 'Christian Kuelker ' configure_requires: Module::Build: 0.36 generated_by: 'Module::Build version 0.3607' license: gpl2 meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: 1.4 name: CipUX-RPC-Client provides: CipUX::RPC::Client: file: lib/CipUX/RPC/Client.pm version: v3.4.0.7 recommends: File::Spec: 0 Test::More: 0 Test::Perl::Critic: 0 Test::Pod: 1.14 Test::Pod::Coverage: 1.04 requires: Carp: 0 CipUX: v3.4.0.0 Class::Std: v0.0.9 Data::Dumper: 0 English: 0 Frontier::Client: 0 Log::Log4perl: 0 Readonly: 0 version: 0 resources: homepage: http://www.cipux.org license: http://opensource.org/licenses/gpl-2.0.php version: v3.4.0.7 CipUX-RPC-Client-3.4.0.7/Makefile.PL000444001750001750 17111424126732 17376 0ustar00ckuelkerckuelker000000000000use Module::Build::Compat; Module::Build::Compat->run_build_pl(args => \@ARGV); Module::Build::Compat->write_makefile(); CipUX-RPC-Client-3.4.0.7/Changes000444001750001750 565511424126732 16753 0ustar00ckuelkerckuelker000000000000Revision history for CipUX-RPC-Client 3.4.0.7 2010-07-28T23:41:23 - changes: * add doc and README to encurage example code * disable /etc/cipux-cat-web/log4perl.conf If use any, better /etc/cipux/log4perl.conf should be used. * drop build dependency to Module::Build::CipUX - contributor: Christian Kuelker - version created by: Christian Kuelker 3.4.0.6 2010-01-07T23:48:22 - changes: * simplification on return value on rpc call * add debug logging * tighten licence specification to make META.yml happy - contributor: Christian Kuelker - version created by: Christian Kuelker 3.4.0.5 2009-12-20T02:59:45 - changes: * returned object are alphabetically sorted now * add new sub rpc_session for convenience. * code cleanup * add more comments * add rpcev (rpc eval) helper sub routine * add context sensitive answer for sub xmlrpc * improve documentation * add ltarget param to sub extract_data_for_tpl - contributor: Christian Kuelker - version created by: Christian Kuelker 3.4.0.4 2009-09-03T14:16:18 - changes: * improve object API * regarding a suggestion from Ulich P. Klein renaming task cipux_task_change_own_password_on_command_line to cipux_task_change_own_password_interactive - contributor: Christian Kuelker - version created by: Christian Kuelker 3.4.0.3 2009-05-11T23:47:21 - changes: * add debug messages to rpc_login * fixed new introduced bug from 3.4.0.2 in rpc_login (password parameter was not passed to subroutine) * add sub extract_data_for_tpl (makes CipUX::CAT::RPC obsolete) - version created by: Christian Kuelker 3.4.0.2 2009-05-03T23:39:11 - changes: * add %login_of, %ticket_of, %password_of to object interface * add sub get_login_of * add login and password parameter to sub rpc_login (make sub usable for non command line tools) - version created by: Christian Kuelker 3.4.0.1 2009-04-26T11:46:21 - changes: * make sub xmlrpc open (other applications might want to use it) - version created by: Christian Kuelker 3.4.0.0 2009-04-23T20:03:02 Initial release Christian Kuelker . CipUX-RPC-Client-3.4.0.7/MANIFEST.SKIP000444001750001750 24411424126732 17323 0ustar00ckuelkerckuelker000000000000-stamp$ \.orig$ \.bak$ \.swp$ \.svn _build blib Build$ \.ptkdb$ .deb$ .build$ .changes$ .upload$ .asc$ .dsc$ .tar.gz$ .cvsignore debian/files$ \..*\~$ ^MYMETA.yml$ CipUX-RPC-Client-3.4.0.7/lib000755001750001750 011424126732 16056 5ustar00ckuelkerckuelker000000000000CipUX-RPC-Client-3.4.0.7/lib/CipUX000755001750001750 011424126732 17046 5ustar00ckuelkerckuelker000000000000CipUX-RPC-Client-3.4.0.7/lib/CipUX/RPC000755001750001750 011424126732 17472 5ustar00ckuelkerckuelker000000000000CipUX-RPC-Client-3.4.0.7/lib/CipUX/RPC/Client.pm000444001750001750 7570011424126732 21434 0ustar00ckuelkerckuelker000000000000# +========================================================================+ # || module: CipUX::RPC::Client || # || || # || Base Class for CipUX XML-RPC clients. || # || || # || Copyright (C) 2009 by Christian Kuelker || # || || # || License: GNU General Public License - GNU GPL version 2 || # || or (at your opinion) any later version. || # || || # +========================================================================+ # ID: $Id$ # Revision: $Revision$ # Head URL: $HeadURL$ # Date: $Date$ # Source: $Source$ package CipUX::RPC::Client; use 5.008001; use warnings; use strict; use Carp; use Class::Std; use Data::Dumper; use English qw( -no_match_vars); use Frontier::Client; use Log::Log4perl qw(get_logger :levels); use Readonly; use base qw(CipUX); { # BEGIN CLASS # CONSTRUCTOR # DESTRUCTOR # MAIN # * RPC COMMANDS # - rpc_ping # - rpc_login # - rpc_logout # - rpc_ttl (rpc_intern) # - rpc_cat_module_cache_size (rpc_intern) # - rpc_rpc_intern_cache_size (rpc_intern) # - rpc_task_cache_size (rpc_intern) # - rpc_flush (rpc_intern) # - rpc_check_access # * RPC HELPER SUBS # - rpcev # - xmlrpc # - extract_data_for_tpl use version; our $VERSION = qv('3.4.0.7'); use re 'taint'; # Keep data captured by parens tainted delete @ENV{qw(PATH IFS CDPATH ENV BASH_ENV)}; # Make %ENV safer # +======================================================================+ # || CONST || # +======================================================================+ Readonly::Scalar my $EMPTY_STRING => q{}; Readonly::Scalar my $L4PCONF => '/etc/cipux/log4perl.conf'; # +======================================================================+ # || OBJECT || # +======================================================================+ my %url_of : ATTR( :name :default('http://localhost:8001/RPC2') ); my %client_of : ATTR( :name); my %version_of : ATTR( :name ); my %login_of : ATTR( :set :get :default 'rc_dummy'); my %ticket_of : ATTR( :set :default('rc_dummy') :get ); my %password_of : ATTR( :default(undef) ); # +======================================================================+ # || GLOBAL || # +======================================================================+ my $rpc_ttl = 0; my $rpc_cat_module_cache_size = 0; my $rpc_rpc_intern_cache_size = 0; my $rpc_task_cache_size = 0; # +======================================================================+ # || CONSTRUCTOR || # +======================================================================+ sub BUILD { # +------------------------------------------------------------------+ # | API my ( $self, $ident, $arg_r ) = @_; # +------------------------------------------------------------------+ # | main # not needed, is already sub class #$cipux = CipUX->new(); # TODO: make that cfg aware #Log::Log4perl::init_once('/etc/cipux-cat-web/log4perl.conf'); # +------------------------------------------------------------------+ # | API return; } # +======================================================================+ # || DESTRUCTOR || # +======================================================================+ sub DEMOLISH { # +------------------------------------------------------------------+ # | API my ( $self, $ident ) = @_; # +------------------------------------------------------------------+ # | main #undef $cipux; delete $url_of{ ident $self}; delete $client_of{ ident $self}; delete $version_of{ ident $self}; # +------------------------------------------------------------------+ # | API return; } # +======================================================================+ # || RPC methods || # +======================================================================+ sub rpc_selfpasswd { # +------------------------------------------------------------------ # | API my ( $self, $arg_r ) = @_; my $password = ( exists $arg_r->{password} ) ? $self->l( $arg_r->{password} ) : $self->perr('password'); my $logger = get_logger(__PACKAGE__); $logger->debug('going to change the password'); my $task = 'cipux_task_change_own_password_interactive'; my $answer_hr = $self->xmlrpc( { cmd => $task, param_hr => { object => $login_of{ ident $self}, userPassword => $password, }, } ); my $status = $answer_hr->{status} || 'UNKNOWN'; $logger->debug( 'the status of the XML-RPC server is: ', $status, "\n" ); if ( $status eq 'FALSE' ) { my $msg = "EXCEPTION: Setting password via server $url_of{ident $self} failed!\n"; $msg .= "($answer_hr->{msg})\n"; croak $msg; } elsif ( $status eq 'UNKNOWN' ) { my $msg = 'EXCEPTION: Server status UNKNOWN' . "\n"; croak $msg; } elsif ( $status eq 'TRUE' ) { return 1; } return 0; } sub rpc_ping { # +------------------------------------------------------------------ # | API my ( $self, $arg_r ) = @_; my $logger = get_logger(__PACKAGE__); $logger->debug('going to ping the XML-RPC server'); my $answer_hr = $self->xmlrpc( { login => 'rc_pingdummy', cmd => 'ping', } ); my $status = $answer_hr->{status} || 'UNKNOWN'; $logger->debug( 'the status of the XML-RPC server is: ', $status, "\n" ); if ( $status eq 'FALSE' ) { my $msg = "EXCEPTION: Server $url_of{ident $self} not responding\n"; croak $msg; } elsif ( $status eq 'UNKNOWN' ) { my $msg = 'EXCEPTION: Server status UNKNOWN' . "\n"; croak $msg; } elsif ( $status eq 'TRUE' ) { return 1; } return 0; } sub rpc_login { # +------------------------------------------------------------------ # | API my ( $self, $arg_r ) = @_; my $logger = get_logger(__PACKAGE__); $logger->debug('BEGIN'); # prompt 1 login my $lstr = "$client_of{ ident $self}: Enter login: "; # prompt 2 password my $pstr = "$client_of{ ident $self}: Enter password: "; $login_of{ ident $self} = ( exists $arg_r->{login} ) ? $self->l( $arg_r->{login} ) : $self->l( $self->login_prompt( { prompt => $lstr } ) ); $logger->debug("login: $login_of{ident $self}"); $password_of{ ident $self} = ( exists $arg_r->{password} ) ? $arg_r->{password} : $self->lp( $self->password_prompt( { prompt => $pstr } ) ); #$logger->debug("password: $password_of{ident $self}"); # +------------------------------------------------------------------ # | main my $answer_hr = $self->xmlrpc( { ticket => 'rc_logindummy', cmd => 'login', param_hr => { password => $password_of{ ident $self}, }, } ); if ( $answer_hr->{status} eq 'TRUE' ) { $logger->debug('login successful'); # +-------------------------------------------------------------- # | API return 1; } $logger->debug('login NOT successful'); # +------------------------------------------------------------------ # | API return 0; } sub rpc_logout { # +------------------------------------------------------------------ # | API my ( $self, $arg_r ) = @_; my $answer_hr = $self->xmlrpc( { cmd => 'logout', } ); if ( $answer_hr->{status} eq 'TRUE' ) { return 1; } return 0; } sub rpc_session { my ( $self, $arg_r ) = @_; my $answer_hr = $self->xmlrpc( { cmd => 'session', } ); my $t = $self->get_ticket; if ( $answer_hr->{status} eq 'TRUE' ) { return $t; } else { $ticket_of{ ident $self} = 0; } return 0; } # rpc_intern # +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+ # | SHELL RPC COMMANDS | # +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+ sub rpc_ttl { # +------------------------------------------------------------------ # | API my ( $self, $arg_r ) = @_; # +------------------------------------------------------------------ # | main my $answer_hr = $self->xmlrpc( { cmd => 'ttl', } ); if ( $answer_hr->{status} ne 'TRUE' ) { croak "XML-RPC server ERRROR: $answer_hr->{msg}"; } $rpc_ttl = $answer_hr->{cmdres_r}->{ttl}; return $rpc_ttl; } sub rpc_cat_module_cache_size { # +------------------------------------------------------------------ # | API my ( $self, $arg_r ) = @_; # +------------------------------------------------------------------ # | main my $answer_hr = $self->xmlrpc( { cmd => 'rpc_intern', param_hr => { subcmd => 'cat_module_cache_size', }, } ); if ( $answer_hr->{status} ne 'TRUE' ) { my $msg = 'XML-RPC server ERRROR:'; $msg .= ' Can not retrieve cache cat_module cache size.'; croak "$msg [$answer_hr->{msg}]"; } $rpc_cat_module_cache_size = $answer_hr->{cmdres_r}->{cat_module_cache_size}; return $rpc_cat_module_cache_size; } sub rpc_rpc_intern_cache_size { # +------------------------------------------------------------------ # | API my ( $self, $arg_r ) = @_; # +------------------------------------------------------------------ # | main my $answer_hr = $self->xmlrpc( { cmd => 'rpc_intern', param_hr => { subcmd => 'rpc_intern_cache_size', }, } ); if ( $answer_hr->{status} ne 'TRUE' ) { my $msg = 'XML-RPC server ERRROR:'; $msg .= ' Can not retrieve cache rpc_intern cache size.'; croak "$msg [$answer_hr->{msg}]"; } $rpc_rpc_intern_cache_size = $answer_hr->{cmdres_r}->{rpc_intern_cache_size}; return $rpc_rpc_intern_cache_size; } sub rpc_task_cache_size { # +------------------------------------------------------------------ # | API my ( $self, $arg_r ) = @_; # +------------------------------------------------------------------ # | main my $answer_hr = $self->xmlrpc( { cmd => 'rpc_intern', param_hr => { subcmd => 'task_cache_size', }, } ); if ( $answer_hr->{status} ne 'TRUE' ) { my $msg = 'XML-RPC server ERRROR:'; $msg .= ' Can not retrieve cache task cache size.'; croak "$msg [$answer_hr->{msg}]"; } $rpc_task_cache_size = $answer_hr->{cmdres_r}->{task_cache_size}; return $rpc_task_cache_size; } sub rpc_flush { # +------------------------------------------------------------------ # | API my ( $self, $arg_r ) = @_; # +------------------------------------------------------------------ # | main my $answer_hr = $self->xmlrpc( { cmd => 'rpc_intern', param_hr => { subcmd => 'flush', }, } ); if ( $answer_hr->{status} ne 'TRUE' ) { my $msg = 'XML-RPC server ERRROR:'; $msg .= ' Can not flush cache.'; croak "$msg [$answer_hr->{msg}]"; } return 1; } sub rpc_check_access { # subcmd: user_task_access | user_task_access_survey | # user_cat_module_access | user_cat_module_access_survey | # user_rpc_intern_access | user_rpc_intern_access_survey # rpc_mode: rpc_info | rpc_intern # entity: task | rpc_intern | cat_module # scope: single | manifold # param_ar: array reference of to be tested modules # +------------------------------------------------------------------ # | API my ( $self, $arg_r ) = @_; # rpc_info | rpc_intern my $rpcmode = exists $arg_r->{rpcmode} ? $self->l( $arg_r->{rpcmode} ) : $self->perr('rpcmode'); # task | rpc_intern | cat_module my $entity = exists $arg_r->{entity} ? $self->l( $arg_r->{entity} ) : $self->perr('entity'); # single | manifold my $scope = exists $arg_r->{scope} ? $self->l( $arg_r->{scope} ) : $self->perr('scope'); my $subcmd = exists $arg_r->{subcmd} ? $self->l( $arg_r->{subcmd} ) : $login_of{ ident $self}; my $param_ar = exists $arg_r->{param_ar} ? $self->a( $arg_r->{param_ar} ) : $self->perr('param_ar'); my $logger = get_logger(__PACKAGE__); # dispatch shell logic and rpc server logic # rpc shell rpcmode xml-rpc server command # --------------------------------------------------- # rbac -> rpc_info -> rpc_info # rpc -> rpc_intern -> rpc_intern my $cmd = ( $rpcmode eq 'rpc_info' ) ? 'rpc_info' : ( $rpcmode eq 'rpc_intern' ) ? 'rpc_intern' : croak "CipUX shell Error: invalid mode [$rpcmode]\n"; $logger->debug("cmd [$cmd]"); my $from = ( $subcmd eq 'user_task_access' or $subcmd eq 'user_task_access_survey' or $subcmd eq 'user_cat_module_access' or $subcmd eq 'user_cat_module_access_survey' or $subcmd eq 'user_rpc_intern_access' or $subcmd eq 'user_rpc_intern_access_survey' ) ? shift @{$param_ar} : undef; if ( defined $from ) { $logger->debug("from [$from]"); } else { $logger->debug("from [UNDEF]"); } if ( $cmd ne 'rpc_intern' ) { $from = $login_of{ ident $self}; } if ( defined $from ) { $logger->debug("from [$from]"); } else { $logger->debug("from [UNDEF]"); } my $answer_hr = $self->xmlrpc( { cmd => $cmd, param_hr => { subcmd => $subcmd, rpcmode => $rpcmode, entity => $entity, scope => $scope, from => $from, to_ar => $param_ar, }, } ); if ( $answer_hr->{status} ne 'TRUE' ) { croak "XML-RPC server ERRROR: $answer_hr->{msg}"; } if ( exists $answer_hr->{cmdres_r}->{access_hr} and exists $answer_hr->{cmdres_r}->{from} ) { my $r_hr = $answer_hr->{cmdres_r}->{access_hr}; my $from = $answer_hr->{cmdres_r}->{from}; if ( defined $r_hr and ref $r_hr eq 'HASH' ) { $logger->debug("return from [$from]"); $logger->debug( 'return r_hr: ', { filter => \&Dumper, value => $r_hr } ); return ( $from, $r_hr ); } } return ( undef, {} ); } # +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+ # | RPC HELPER METHOD | # +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+ sub rpcev { my $self = shift; # obj my $c = shift; # code_ref to be evaluated my $p = shift; # param_hr | undef my $a = undef; # answer (scalar or hash reference) if ( defined $p ) { eval { $a = $c->($p) }; } else { eval { $a = $c }; } if ($EVAL_ERROR) { croak "Server is down: $EVAL_ERROR\n"; } return $a; } sub xmlrpc { my ( $self, $arg_r ) = @_; my $cmd = exists $arg_r->{cmd} ? $self->l( $arg_r->{cmd} ) : $self->perr('cmd'); my $tmp_login = exists $arg_r->{login} ? $self->l( $arg_r->{login} ) : $login_of{ ident $self}; my $tmp_ticket = exists $arg_r->{ticket} ? $self->l( $arg_r->{ticket} ) : $ticket_of{ ident $self}; my $param_hr = exists $arg_r->{param_hr} ? $self->h( $arg_r->{param_hr} ) : {}; my $logger = get_logger(__PACKAGE__); my $header_hr = { 'cipux_version' => "$VERSION", 'client_name' => "$client_of{ident $self}", 'client_version' => "$version_of{ident $self}", 'rpc_version' => '2.0', 'client_key' => $EMPTY_STRING, 'client_cred' => $EMPTY_STRING, 'gmt_time' => time(), }; my $pay_hr = { header_hr => $header_hr, login => $tmp_login, ticket => $tmp_ticket, cmd => $cmd, param_hr => $param_hr }; my $socket = Frontier::Client->new( url => $url_of{ ident $self} ); my $call = $cmd; if ( $cmd =~ m/^cipux_task/smx ) { $call = 'task'; } $logger->debug("cmd [$cmd]"); $logger->debug("call [$call]"); my $answer_hr = $socket->call( $call, $pay_hr ); # if we got a new ticket explicitly (login, session): use it if ( ref( $answer_hr->{cmdres_r} ) eq 'HASH' ) { my $t = $answer_hr->{cmdres_r}->{ticket}; if ( defined $t and $t ne $EMPTY_STRING ) { $ticket_of{ ident $self} = $t; $logger->debug("set new ticket [$t]"); } } if (wantarray) { $logger->debug("wantarray!"); confess "depricated wantarray in xmlrpc call!"; return $answer_hr, $ticket_of{ ident $self}; } else { return $answer_hr; } } sub extract_data_for_tpl { my ( $self, $arg_r ) = @_; my $letter = ( exists $arg_r->{letter} ) ? 1 : 0; my $use_ltarget = ( exists $arg_r->{use_ltarget} ) ? 1 : 0; my $answer_hr = exists $arg_r->{answer_hr} ? $self->h( $arg_r->{answer_hr} ) : $self->perr('answer_hr'); # +------------------------------------------------------------------+ # | prepare my $logger = get_logger(__PACKAGE__); # We have to deal with 2 different data formats # [1] traditional _list_ data # 'cmdres_r' => { # pupil' => { # 'uid' => [ 'pupil' ] # }, # 'bilbo' => { # 'uid' => [ 'bilbo' ] # }, # } # Results in: # data_ar $VAR1 = [ # { 'uid' => 'pupil' }, # { 'uid' => 'bilbo' # ] # # [2] And second the _member_ list format # 'cmdres_r' => { # 'students' => { # 'cn' => [ 'students' ], # 'memberUid' => [ # 'bilbo', # 'frmeier' # ] # } # }, # Results FALLBACK (good for 'retrieve' bad for 'list member'): # data_ar $VAR1 = [ # { # 'cn' => 'students', # 'memberUid' => 'bilbo, frodo, mytest, mytest2, frmeier' # } #]; # Results LTARGET in (bad for 'retrieve' good for 'list member'): # if '{answer_hr=>answer_hr,use_ltarget=>1}' # data_ar $VAR1 = [ # { 'memberUid' => 'bilbo' }, # { 'memberUid' => 'frmeier' # ] # +------------------------------------------------------------------+ # | main $logger->debug("use_ltarget [$use_ltarget]"); $logger->debug("letter [$letter]"); my $return_hr = {}; my @tpl_data = (); #my @sorted = sort keys %{ $answer_hr->{cmdres_r}}; my %firstletter = (); foreach my $obj ( sort keys %{ $answer_hr->{cmdres_r} } ) { #$logger->debug("extract obj [$obj]"); # if we want an analysis for the first letter # here it comes: (what else do we want?) if ($letter) { my $l = uc( substr( $obj, 0, 1 ) ); #$logger->debug("letter [$l]"); if ( not defined $firstletter{$l} ) { $firstletter{$l} = 1; } else { $firstletter{$l}++; } } # create an array of hash_refs my $data_hr = $answer_hr->{cmdres_r}->{$obj}; # the ltarget from the task layer my $ltarget = ( exists $answer_hr->{ltarget} and defined $answer_hr->{ltarget} and $use_ltarget ) ? $answer_hr->{ltarget} : 'NULL'; $logger->debug("ltarget [$ltarget]"); # test if we get a hint from the task layer if ( $ltarget eq 'NULL' ) { # no help, FALLBACK my %data = (); # key = uid, cipuxFirstname, cipuxLastname, ... foreach my $key ( keys %{$data_hr} ) { $data{$key} = join q{, }, @{ $data_hr->{$key} }; utf8::encode( $data{$key} ); } push @tpl_data, \%data; } else { # LTARGET $return_hr->{ltarget} = $ltarget; # for 'bilbo', 'frodo', ... foreach my $value ( @{ $data_hr->{$ltarget} } ) { #$logger->debug("ltarget [$ltarget]"); utf8::encode($value); #$logger->debug("value [$value]"); push @tpl_data, { $ltarget => $value }; } } } # Ah, oh yes here it comes it again: if we want to have an # analyses for the first letter, we should give it back if ($letter) { my @firstletter = sort keys %firstletter; my $fl = $firstletter[0]; #$logger->debug("fristletter [$fl]"); #$logger->debug('END'); # data lettercount firstletter $return_hr->{firstletter_hr} = \%firstletter; $return_hr->{firstletter} = $fl; } $return_hr->{tpl_data_ar} = \@tpl_data; # +------------------------------------------------------------------+ # | API # [1] default: # returns always { tpl_data_ar } # [2] letter=>1 # returns additionally to [1]: { firstletter_hr, firstletter } # [3] use_ltarget=>1 # returns additionally to [1]: { ltarget } return $return_hr; # $extract_answer_hr } } 1; # Magic true value required at end of module __END__ =pod =for stopwords login uid rpc UTF UTF-8 CipUX XML-RPC Destructor xmlrpc webpage Kuelker TTL subcommands =head1 NAME CipUX::RPC::Client - XML-RPC client call library =head1 VERSION This document describes CipUX::RPC::Client version 3.4.0.7 =head1 SYNOPSIS use warnings; use strict; use CipUX::RPC::Client; use version; our $VERSION = qv('3.4.0.0'); my $rpc = CipUX::RPC::Client->new({ url=>'http://localhost:8001/RPC2', client=>'clientname', # name of client version=>'3.4.0.0', # version of client }); if ( $rpc->rpc_ping() ) { print "OK\n" }else{ exit 1; } if ( $rpc->rpc_login() ) { print "OK\n" }else{ exit 1; } # probably do some other calls if ( $rpc->rpc_logout() ) { print "OK\n" }else{ exit 1; } exit 0; =head1 DESCRIPTION =head1 SUBROUTINES/METHODS =head2 BUILD Constructor (Not used at the moment) =head2 DEMOLISH Destructor =head2 get_login Retrieve the login (uid) of the rpc client object. $login = $rpc->get_login(); =head2 rpc_selfpasswd Set own password. 1|0 = $rpc->rpc_login( { password=>$password } ); =head2 rpc_ping Test if the server is up. 1|0 = $rpc->rpc_ping(); =head2 rpc_login Perform a log in. 1|0 = $rpc->rpc_login(); =head2 rpc_logout Perform a log out. 1|0 = $rpc->rpc_logout(); =head2 rpc_ttl Returns the TTL via rpc_intern. $ttl = $rpc->rpc_ttl(); =head2 rpc_session Returns a ticket or 0; my $ticket = $rpc->rpc_session(); =head2 rpc_cat_module_cache_size Returns the cache size via rpc_intern. $integer = $rpc->rpc_cat_module_cache_size(); =head2 rpc_rpc_intern_cache_size Returns the cache size via rpc_intern. $integer = $rpc->rpc_rpc_intern_cache_size(); =head2 rpc_task_cache_size Returns the cache size via rpc_intern. $integer = $rpc->rpc_task_cache_size(); =head2 rpc_flush Flush the cache via rpc_intern. 0|1 = $rpc->rpc_flush(); =head2 rpc_check_access Aggregate several check access subcommands. ( $from, $r_hr ) = $rpc->rpc_check_access({ rpcmode => rpc_intern|rpc_info, entity => task | rpc_intern | cat_module scope => single | manifold, subcommand => user_task_access | user_task_access_survey | user_cat_module_access | user_cat_module_access_survey | user_rpc_intern_access | user_rpc_intern_access_survey param_ar => (rest send as to_ar) }); =head2 rpcev Helper routine to evaluate calls. $ok = $rpc->rpcev( 'ping', \&{ $rpc->rpc_ping } ); $ok = $rpc->rpcev( 'login', \&{ $rpc->rpc_login } ); $code = sub { return $rpc->xmlrpc(@_); }; # remains the same $a_hr = $rpc->rpcev 'list', $code, {cmd => 'cipux_task_list_student_accounts'} ); $d_ar = $rpc->extract_data_for_tpl( {answer_hr => $a_hr, use_ltarget=>1} ); print "Students on the system:\n"; foreach my $l (@{$d_ar->{tpl_data_ar}}){ print "\t$l->{$d_ar->{ltarget}}\n";} $ok = $rpc->rpcev( 'logout',\&{ $rpc->rpc_logout }, ); =head2 xmlrpc Helper subroutine to executing XML-RPC calls. ($answer_hr, $ticket) = $rpc->xmlrpc({ cmd => 'cipux_task_*|rpc_intern|...', # mandatory login => $login, ticket => $ticket, param_hr => {}, }); =head2 extract_data_for_tpl Helper subroutine to extract data for using in web templates. Encode it into UTF-8. $tpl_data_ar = $rpc->extract_data_for_tpl({answer_hr=>$answer_hr}); =head1 DIAGNOSTICS =over =item C<< EXCEPTION: Setting password via server %url failed! >> =item C<< EXCEPTION: Server %url not responding >> =item C<< EXCEPTION: Server status UNKNOWN >> =back =head1 CONFIGURATION AND ENVIRONMENT CipUX::RPC::Client requires no configuration files or environment variables. =head1 DEPENDENCIES Carp CipUX Class::Std Data::Dumper English Frontier::Client Log::Log4perl Readonly version =head1 INCOMPATIBILITIES None reported. =head1 BUGS AND LIMITATIONS No bugs have been reported. =head1 SEE ALSO See the CipUX webpage and the manual at L See the mailing list L =head1 AUTHOR Christian Kuelker Echristian.kuelker@cipworx.orgE =head1 LICENSE AND COPYRIGHT Copyright (C) 2009 by Christian Kuelker. All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA =head1 DISCLAIMER OF WARRANTY BECAUSE THIS SOFTWARE IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR THE SOFTWARE, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE SOFTWARE "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE SOFTWARE IS WITH YOU. SHOULD THE SOFTWARE PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR, OR CORRECTION. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTRIBUTE THE SOFTWARE AS PERMITTED BY THE ABOVE LICENSE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE SOFTWARE (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE SOFTWARE TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. =cut CipUX-RPC-Client-3.4.0.7/doc000755001750001750 011424126732 16055 5ustar00ckuelkerckuelker000000000000CipUX-RPC-Client-3.4.0.7/doc/examples000755001750001750 011424126732 17673 5ustar00ckuelkerckuelker000000000000CipUX-RPC-Client-3.4.0.7/doc/examples/readme.mkd000444001750001750 103611424126732 21762 0ustar00ckuelkerckuelker000000000000 # CipUX-RPC-Client examples The example folder is empty. For now. Please, feel free to add your examples to: rpc_client/doc/example/bin If you are searching for any clue on how to write clients - even bad one's - you might have a look at the doc/example/bin folder provided with the CipUX::RPC module in the CipUX-RPC upstream release. If you are looking for advanced clients - even good one's - you should consider to study CipUX-Passwd or CipUX-CAT-Web, or if you prefer other languages then CATweasel (Python) or cipuxPHP (PHP). CipUX-RPC-Client-3.4.0.7/t000755001750001750 011424126732 15553 5ustar00ckuelkerckuelker000000000000CipUX-RPC-Client-3.4.0.7/t/00-load.t000444001750001750 24311424126732 17210 0ustar00ckuelkerckuelker000000000000#!perl -T use Test::More tests => 1; BEGIN { use_ok('CipUX::RPC::Client'); } diag("Testing CipUX::RPC::Client $CipUX::RPC::Client::VERSION, Perl $], $^X"); CipUX-RPC-Client-3.4.0.7/t/perlcriticrc000444001750001750 101711424126732 20317 0ustar00ckuelkerckuelker000000000000# CipUX Perl::Critic Configuration # # SEVERITY NAME ...is equivalent to... SEVERITY NUMBER # ---------------------------------------------------- # gentle 5 # stern 4 # harsh 3 # cruel 2 # brutal 1 severity = brutal verbose = 11 CipUX-RPC-Client-3.4.0.7/t/pod.t000444001750001750 35011424126732 16635 0ustar00ckuelkerckuelker000000000000#!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(); CipUX-RPC-Client-3.4.0.7/t/pod-coverage.t000444001750001750 104711424126732 20452 0ustar00ckuelkerckuelker000000000000use strict; use warnings; use Test::More; # 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(); CipUX-RPC-Client-3.4.0.7/t/perlcritic.t000444001750001750 100711424126732 20233 0ustar00ckuelkerckuelker000000000000#!perl use strict; use warnings; use File::Spec; use Test::More; use English qw(-no_match_vars); if ( not $ENV{TEST_AUTHOR} ) { my $msg = 'Author test. Set $ENV{TEST_AUTHOR} to a true value to run.'; plan( skip_all => $msg ); } eval { require Test::Perl::Critic; }; if ($EVAL_ERROR) { my $msg = 'Test::Perl::Critic required to criticise code'; plan( skip_all => $msg ); } my $rcfile = File::Spec->catfile( 't', 'perlcriticrc' ); Test::Perl::Critic->import( -profile => $rcfile ); all_critic_ok();