File Coverage

blib/lib/Connector.pm
Criterion Covered Total %
statement 64 115 55.6
branch 16 40 40.0
condition 3 11 27.2
subroutine 15 26 57.6
pod 10 10 100.0
total 108 202 53.4


line stmt bran cond sub pod time code
1             # Connector
2             #
3             # A generic abstraction for accessing information.
4             #
5             # Written by Scott Hardin, Martin Bartosch and Oliver Welter for the OpenXPKI project 2012
6             #
7             package Connector;
8              
9             # This is the earliest version we've tested on and we need at least 5.10
10             # because of the '//' operator in one of the sub-modules.
11 24     24   181233 use 5.010001;
  24         93  
12              
13             our $VERSION = '1.47';
14              
15 24     24   162 use strict;
  24         72  
  24         541  
16 24     24   258 use warnings;
  24         51  
  24         597  
17 24     24   151 use English;
  24         63  
  24         203  
18 24     24   9826 use Data::Dumper;
  24         14747  
  24         1456  
19              
20 24     24   3795 use Log::Log4perl;
  24         186585  
  24         299  
21              
22 24     24   1934 use Moose;
  24         475921  
  24         177  
23 24     24   170959 use Connector::Types;
  24         79  
  24         42764  
24              
25             has LOCATION => (
26             is => 'ro',
27             isa => 'Connector::Types::Location',
28             required => 1,
29             );
30              
31             # In order to clear the prefix, call the accessor with undef as argument
32             has PREFIX => (
33             is => 'rw',
34             isa => 'Connector::Types::Key|ArrayRef|Undef',
35             # build and store an array of the prefix in _prefix_path
36             trigger => sub {
37             my ($self, $prefix, $old_prefix) = @_;
38             if (defined $prefix) {
39             my @path = $self->_build_path($prefix);
40             $self->__prefix_path(\@path);
41             } else {
42             $self->__prefix_path([]);
43             }
44             }
45             );
46              
47             has DELIMITER => (
48             is => 'rw',
49             isa => 'Connector::Types::Char',
50             default => '.',
51             );
52              
53             has RECURSEPATH => (
54             is => 'rw',
55             isa => 'Bool',
56             default => '0',
57             );
58              
59             # internal representation of the instance configuration
60             # NB: this should be a private variable and not accessible from outside
61             # an instance.
62             # TODO: figure out how to protect it.
63             has _config => (
64             is => 'rw',
65             lazy => 1,
66             init_arg => undef, # not settable via constructor
67             builder => '_build_config',
68             );
69              
70             has log => (
71             is => 'rw',
72             lazy => 1,
73             init_arg => undef, # not settable via constructor
74             builder => '_build_logger',
75             );
76              
77              
78             # this instance variable is set in the trigger function of PREFIX.
79             # it contains an array representation of PREFIX (assumed to be delimited
80             # by the DELIMITER character)
81             has _prefix_path => (
82             is => 'rw',
83             isa => 'ArrayRef',
84             init_arg => undef,
85             default => sub { [] },
86             writer => '__prefix_path',
87             lazy => 1
88             );
89              
90             # weather to die on undef or just fail silently
91             # implemented in _node_not_exists
92             has 'die_on_undef' => (
93             is => 'rw',
94             isa => 'Bool',
95             default => 0,
96             );
97              
98              
99             # This is the foo that allows us to just milk the connector config from
100             # the settings fetched from another connector.
101              
102             around BUILDARGS => sub {
103             my $orig = shift;
104             my $class = shift;
105              
106             my $args = $_[0];
107              
108             if ( ref($args) eq 'HASH'
109             && defined($args->{CONNECTOR})
110             && defined($args->{TARGET}) ) {
111              
112             my $conn = $args->{CONNECTOR};
113             delete $args->{CONNECTOR};
114              
115             my @targ = $conn->_build_path( $args->{TARGET} );
116             delete $args->{TARGET};
117              
118             my $meta = $class->meta;
119              
120             my $log = $conn->log(); # Logs to the parent that is initialising us
121             $log->trace( 'Wrapping connector - config at ' . join ".", @targ ) ;
122              
123             for my $attr ( $meta->get_all_attributes ) {
124             my $attrname = $attr->name();
125             next if $attrname =~ m/^_/; # skip apparently internal params
126             # allow caller to override params in CONNECTOR
127             if ( not exists($args->{$attrname}) ) {
128             my $meta = $conn->get_meta( [ @targ , $attrname ] );
129             $log->trace( ' Check for ' . $attrname . ' - meta is ' . Dumper $meta );
130             next unless($meta && $meta->{TYPE});
131             if ($meta->{TYPE} eq 'scalar') {
132             $args->{$attrname} = $conn->get( [ @targ , $attrname ] );
133             } elsif ($meta->{TYPE} eq 'list') {
134             my @tmp = $conn->get_list( [ @targ , $attrname ] );
135             $args->{$attrname} = \@tmp;
136             } elsif ($meta->{TYPE} eq 'hash') {
137             $args->{$attrname} = $conn->get_hash( [ @targ , $attrname ] );
138             } else {
139             $log->warn( ' Unexpected type '.$meta->{TYPE}.' for attribute ' . $attrname );
140             }
141             }
142             }
143              
144             $log->trace( 'Wrapping connector - arglist ' .Dumper \@_ );
145             }
146             return $class->$orig(@_);
147             };
148              
149              
150             # subclasses must implement this to initialize _config
151 0     0   0 sub _build_config { return; };
152              
153             sub _build_logger {
154              
155 51     51   400 return Log::Log4perl->get_logger("connector");
156              
157             };
158              
159              
160             # helper function: build a path from the given input. does not take PREFIX
161             # into account
162             sub _build_path {
163              
164 1110     1110   2212 my $self = shift;
165 1110         2211 my @arg = @_;
166              
167 1110         1560 my @path;
168              
169              
170             # Catch old call format
171 1110 50       2428 if (scalar @arg > 1) {
172 0         0 die "Sorry, we changed the API (pass scalar or array ref but not array)";
173             }
174              
175 1110         1827 my $location = shift @arg;
176              
177 1110 100       15233 if (not $location) {
    100          
    50          
    100          
178 20         62 @path = ();
179             } elsif (ref $location eq '') {
180             # String path - split at delimiter
181 579         14252 my $delimiter = $self->DELIMITER();
182 579         3212 @path = split(/[$delimiter]/, $location);
183             } elsif (ref $location ne "ARRAY") {
184             # Nothing else than arrays allowed beyond this point
185 0         0 die "Invalid data type passed in argument to _build_path";
186             } elsif ($self->RECURSEPATH()) {
187 4         6 foreach my $item (@{$location}) {
  4         9  
188 8         20 push @path, $self->_build_path( $item );
189             }
190             } else {
191             # Atomic path, the array is the result
192 507         755 @path = @{$location};
  507         1282  
193             }
194              
195 1110         25116 $self->log()->trace( 'path created ' . Dumper \@path );
196              
197 1110 100       73448 if (wantarray) {
    50          
198 1109         5284 return @path;
199             } elsif ($self->RECURSEPATH()) {
200 1         25 return join $self->DELIMITER(), @path;
201             } else {
202 0         0 die "Sorry, we changed the API, request a list and join yourself or set RECURSEPATH in constructor";
203             }
204              
205             }
206              
207             # same as _build_config, but prepends PREFIX
208             sub _build_path_with_prefix {
209 939     939   1404 my $self = shift;
210 939         1409 my $location = shift;
211              
212 939 100       2076 if (not $location) {
213 21         47 return @{$self->_prefix_path()};
  21         650  
214             } else {
215 918         1295 return (@{$self->_prefix_path()}, ($self->_build_path( $location )));
  918         23381  
216             }
217              
218             }
219              
220             # return the prefix as string (using DELIMITER)
221             sub _get_prefix {
222 0     0   0 my $self = shift;
223 0         0 return join($self->DELIMITER(), @{$self->_prefix_path()});
  0         0  
224             }
225              
226             # This is a helper to handle non exisiting nodes
227             # By default we just return undef but you can configure the connector
228             # to die with an error
229             sub _node_not_exists {
230 116     116   257 my $self = shift;
231 116   100     348 my $path = shift || '';
232 116 100       329 $path = join ("|", @{$path}) if (ref $path eq "ARRAY");
  8         23  
233              
234 116         2761 $self->log()->debug('Node does not exist at ' . $path );
235              
236 116 50       3598 if ($self->die_on_undef()) {
237 0         0 confess("Node does not exist at " . $path );
238             }
239              
240 116         583 return;
241             }
242              
243             sub _log_and_die {
244 1     1   3 my $self = shift;
245 1         2 my $message = shift;
246 1   33     13 my $log_message = shift || $message;
247              
248 1         25 $self->log()->error($log_message);
249 1         529 die $message;
250              
251             }
252              
253              
254             # Subclasses can implement these to save resources
255             sub get_size {
256              
257 0     0 1   my $self = shift;
258 0           my @node = $self->get_list( shift );
259              
260 0 0         if (!@node) {
261 0           return 0;
262             }
263 0           return scalar @node;
264             }
265              
266             sub get_keys {
267              
268 0     0 1   my $self = shift;
269 0           my $node = $self->get_hash( shift );
270              
271 0 0         if (!defined $node) {
272 0           return @{[]};
  0            
273             }
274              
275 0 0         if (ref $node ne "HASH") {
276 0           die "requested path looks not like a hash";
277             }
278              
279 0           return keys (%{$node});
  0            
280             }
281              
282             # Generic, should be implemented in child classes to save resources
283             sub exists {
284              
285 0     0 1   my $self = shift;
286 0           my @args = @_;
287 0           my @path = $self->_build_path_with_prefix( $args[0] );
288 0           my $meta;
289             my $result;
290              
291 0           eval {
292              
293 0           $meta = $self->get_meta( @args );
294              
295 0 0 0       if (!$meta || !$meta->{TYPE}) {
    0          
    0          
    0          
    0          
    0          
296 0           $result = undef;
297             } elsif ($meta->{TYPE} eq 'scalar') {
298 0           $result = defined $self->get( @args );
299             } elsif ($meta->{TYPE} eq 'list') {
300 0           my @tmp = $self->get_list( @args );
301 0   0       $result = (@tmp && scalar @tmp > 0);
302             } elsif ($meta->{TYPE} eq 'hash') {
303 0           $result = defined $self->get_hash( @args );
304             } elsif ($meta->{TYPE} eq 'connector') {
305 0           $result = 1;
306             } elsif ($meta->{TYPE} eq 'reference') {
307 0           $result = 1;
308             } else {
309 0           $self->log()->warn( ' Unexpected type '.$meta->{TYPE}.' for exist on path ' . join ".", @path );
310             }
311             };
312              
313 0 0         $self->log()->debug("Got eval error ($EVAL_ERROR) for exist on path " . join ".", @path ) if ($EVAL_ERROR);
314              
315 0           return $result;
316             }
317              
318             # subclasses must implement get and/or set in order to do something useful
319 0     0 1   sub get { shift; die "No get() method defined"; };
  0            
320 0     0 1   sub get_list { shift; die "No get_list() method defined"; };
  0            
321 0     0 1   sub get_hash { shift; die "No get_hash() method defined"; };
  0            
322 0     0 1   sub get_meta { shift; die "No get_meta() method defined"; };
  0            
323 0     0 1   sub get_reference { shift; die "No get_hash() method defined"; };
  0            
324 0     0 1   sub set { shift; die "No set() method defined"; };
  0            
325       7 1   sub cleanup {};
326              
327              
328 24     24   228 no Moose;
  24         77  
  24         165  
329             __PACKAGE__->meta->make_immutable;
330              
331             1;
332             __END__
333              
334             =head1 NAME
335              
336             Connector - a generic connection to a hierarchical-structured data set
337              
338             =head1 DESCRIPTION
339              
340             The Connector is generic connection to a data set, typically configuration
341             data in a hierarchical structure. Each connector object accepts the get(KEY)
342             method, which, when given a key, returns the associated value from the
343             connector's data source.
344              
345             Typically, a connector acts as a proxy to a simple data source like
346             YAML, Config::Std, Config::Versioned, or to a more complex data source
347             like an LDAP server or Proc::SafeExec. The standard calling convention
348             via get(KEY) makes the connectors interchangeable.
349              
350             In addition, a set of meta-connectors may be used to combine multiple
351             connectors into more complex chains. The Connector::Multi, for example,
352             allows for redirection to delegate connectors via symbolic links. If
353             you have a list of connectors and want to use them in a load-balancing,
354             round-robin fashion or have the list iterated until a value is found,
355             use Connector::List and choose the algorithm to perform.
356              
357             =head1 SYNOPSIS
358              
359             use Connector::MODULENAME;
360              
361             my $conn = Connector::MODULENAME->new( {
362             LOCATION => $path_to_config_for_module,
363             });
364              
365             my $val = $conn->get('full.name.of.key');
366              
367             =head2 Connector Class
368              
369             This is the base class for all Connector implementations. It provides
370             common helper methods and performs common sanity checking.
371              
372             Usually this class should not be instantiated directly.
373              
374             =head1 CONFIGURATION
375              
376             =head2 die_on_undef
377              
378             Set to true if you want the connector to die when a query reaches a non-exisiting
379             node. This will affect calls to get/get_list/get_hash and will not affect
380             values that are explicitly set to undef (if supported by the connector!).
381              
382             =head1 Accessor Methods
383              
384             Each accessor method is valid only on special types of nodes. If you call them
385             on a wrong type of node, the connector may retunr unexpected result or simply die.
386              
387             =head2 exists
388              
389             =head2 get
390              
391             Basic method to obtain a scalar value at the leaf of the config tree.
392              
393             my $value = $connector->get('smartcard.owners.tokenid.bob');
394              
395             Each implementation must also accept an arrayref as path. The path is
396             contructed from the elements. The default behaviour allows strings using
397             the delimiter character inside an array element. If you want each array
398             element to be parsed, you need to pass "RECURSEPATH => 1" to the constructor.
399              
400             my $value = $connector->get( [ 'smartcard','owners','tokenid','bob.builder' ] );
401              
402             Some implementations accept control parameters, which can be passed by
403             I<params>, which is a hash ref of key => value pairs.
404              
405             my $value = $connector->get( 'smartcard.owners.tokenid.bob' , { version => 1 } );
406              
407             =head2 get_list
408              
409             This method is only valid if it is called on a "n-1" depth node representing
410             an ordered list of items (array). The return value is an array with all
411             values present below the node.
412              
413             my @items = $connector->get_list( 'smartcard.owners.tokenid' );
414              
415              
416             =head2 get_size
417              
418             This method is only valid if it is called on a "n-1" depth node representing
419             an ordered list of items (array). The return value is the number of elements
420             in this array (including undef elements if they are explicitly given).
421              
422             my $count = $connector->get_size( 'smartcard.owners.tokens.bob' );
423              
424             If the node does not exist, 0 is returned.
425              
426             =head2 get_hash
427              
428             This method is only valid if it is called on a "n-1" depth node representing
429             a key => value list (hash). The return value is a hash ref.
430              
431             my %data = %{$connector->get_hash( 'smartcard.owners.tokens.bob' )};
432              
433              
434             =head2 get_keys
435              
436             This method is only valid if it is called on a "n-1" depth node representing
437             a key => value list (hash). The return value is an array holding the
438             values of all keys (including undef elements if they are explicitly given).
439              
440             my @keys = $connector->get_keys( 'smartcard.owners.tokens.bob' );
441              
442             If the node does not exist, an empty list is returned.
443              
444             =head2 get_reference
445              
446             Rarely used, returns the value of a reference node. Currently used by
447             Connector::Multi in combination with Connector::Proxy::Config::Versioned
448             to create internal links and cascaded connectors. See Connector::Multi
449             for details.
450              
451             =head2 set
452              
453             The set method is a "all in one" implementation, that is used for either type
454             of value. If the value is not a scalar, it must be passed by reference.
455              
456             $connector->set('smartcard.owners.tokenid.bob', $value, $params);
457              
458             The I<value> parameter holds a scalar or ref to an array/hash with the data to
459             be written. I<params> is a hash ref which holds additional parameters for the
460             operation and can be undef if not needed.
461              
462             =head1 STRUCTURAL METHODS
463              
464             =head2 get_meta
465              
466             This method returns some structural information about the current node as
467             hash ref. At minimum it must return the type of node at the current path.
468              
469             Valid values are I<scalar, list, hash, reference>. The types match the
470             accessor methods given above (use C<get> for I<scalar>).
471              
472             my $meta = $connector->get_meta( 'smartcard.owners' );
473             my $type = $meta->{TYPE};
474              
475             When you call a proxy connector without sufficient arguments to perform the
476             query, you will receive a value of I<connector> for type. Running a get_*
477             method against such a node will cause the connector to die!
478              
479             =head2 cleanup
480              
481             Advise connectors to close, release or flush any open handle or sessions.
482             Should be called directly before the program terminates. Connectors might
483             be stale and not respond any longer after this was called.
484              
485             =head1 IMPLEMENTATION GUIDELINES
486              
487             You SHOULD use the _node_not_exists method if the requested path does not exist
488             or has an undefined value. This will internally take care of the I<die_on_undef>
489             setting and throw an exception or return undef. So you can just write:
490              
491             if (path not exists || not defined val) {
492             return $self->_node_not_exists( pathspec );
493             }
494              
495             As connectors are often used in eval constructs where the error messages
496             are swallowed you SHOULD log a verbose error before aborting with
497             die/confess. You can use the _log_and_die method for this purpose. It will
498             send a message to the logger on error level before calling "die $message".
499              
500             =head2 path building
501              
502             You should always pass the first parameter to the private C<_build_path>
503             method. This method converts any valid path spec representation to a valid
504             path. It takes care of the RECURSEPATH setting and returns the path
505             elements as list.
506              
507             =head2 Supported methods
508              
509             The methods get, get_list, get_size, get_hash, get_keys, set, get_meta are
510             routed to the appropriate connector.
511              
512             You MUST implement at minimum one of the three data getters, if get_list/get_keys
513             is omited, the base class will do a get_list/get_keys call and return the info
514             which will be a correct result but might be expensive, so you can provide your
515             own implementiation if required.
516              
517             You MUST also implement the get_meta method. If you have a connector with a
518             fixed type, you MAY check if the particular path exists and return
519             the result of I<_node_not_exists>.
520              
521             =head2 cleanup
522              
523             Connectors that keep locks or use long-lived sessions that are not
524             bound to the lifetime of the perl process should implement this method
525             and cleanup their mess. While it would be nice, that connectors can be
526             revived after cleanup was called, this is not a strict requirement.
527              
528             =head1 AUTHORS
529              
530             Scott Hardin <mrscotty@cpan.org>
531              
532             Martin Bartosch
533              
534             Oliver Welter
535              
536             =head1 COPYRIGHT
537              
538             Copyright 2013/2021 White Rabbit Security Gmbh
539              
540             This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.