source: trunk/LATMOS-Accounts/lib/LATMOS/Accounts/Bases/Objects.pm

Last change on this file was 2608, checked in by nanardon, 4 weeks ago

Fix: function name
  • Property svn:keywords set to Id Rev
File size: 27.8 KB
Line 
1package LATMOS::Accounts::Bases::Objects;
2
3use 5.010000;
4use strict;
5use warnings;
6
7use overload '""' => 'stringify';
8
9use LATMOS::Accounts::Log;
10use LATMOS::Accounts::Bases::Attributes;
11use LATMOS::Accounts::Utils;
12use Crypt::Cracklib;
13
14our $VERSION = (q$Rev: 2072 $ =~ /^Rev: (\d+) /)[0];
15
16=head1 NAME
17
18LATMOS::Accounts::Bases::Objects - Base class for account objects
19
20=head1 SYNOPSIS
21
22  use LATMOS::Accounts::Bases::Objects;
23  LATMOS::Accounts::Bases::Objects->new($base, $type, $id);
24
25=head1 DESCRIPTION
26
27=head1 FUNCTIONS
28
29=cut
30
31=head2 is_supported
32
33If exists, must return true or false if the object is supported or not
34
35=cut
36
37=head2 list($base)
38
39List object supported by this module existing in base $base
40
41Must be provide by object class
42
43    sub list {
44        my ($class, $base) = @_;
45    }
46
47=cut
48
49=head2 listReal($base)
50
51List object supported by this module existing in base $base
52
53Can be override by base driver. The result must exclude specials object such alias.
54
55=cut
56
57sub listReal {
58    my ($class, $base) = @_;
59    $class->list($base);
60}
61
62=head2 list_from_rev($base, $rev)
63
64List objects created or modified after base revision C<$rev>.
65
66=cut
67
68=head2 new($base, $id)
69
70Create a new object having $id as uid.
71
72=cut
73
74sub new {
75    my ($class, $base, $id, @args) = @_;
76    # So can be call as $class->SUPER::new()
77    bless {
78        _base => $base,
79        _type => lc(($class =~ m/::([^:]*)$/)[0]),
80        _id => $id,
81    }, $class;
82}
83
84=head2 _create($class, $base, $id, %data)
85
86Must create a new object in database.
87
88Is called if underling base does not override create_object
89
90    sub _create(
91        my ($class, $base, $id, %data)
92    }
93
94=cut
95
96=head2 type
97
98Return the type of the object
99
100=cut
101
102sub type {
103    my ($self) = @_;
104    if (ref $self) {
105        return $self->{_type}
106    } else {
107        return lc(($self =~ /::([^:]+)$/)[0]);
108    }
109}
110
111=head2 base
112
113Return the base handle for this object.
114
115=cut
116
117sub base {
118    return $_[0]->{_base}
119}
120
121=head2 id
122
123Must return the unique identifier for this object
124
125=cut
126
127sub id {
128    my ($self) = @_;
129    $self->{_id}
130}
131
132=head2 AclID
133
134Return object for acl check
135
136=cut
137
138sub AclID { $_[0]->id }
139
140=head2 Iid
141
142Return internal id if different from Id
143
144=cut
145
146sub Iid {
147    my ($self) = @_;
148    $self->id
149}
150
151=head2 stringify
152
153Display object as a string
154
155=cut
156
157sub stringify {
158    my ($self) = @_;
159
160    return $self->id
161}
162
163=head2 list_canonical_fields($for)
164
165Object shortcut to get the list of field supported by the object.
166
167=cut
168
169sub list_canonical_fields {
170    my ($self, $for) = @_;
171    $for ||= 'rw';
172    $self->_canonical_fields($for);
173}
174
175=head2 attribute ($attribute)
176
177Return L<LATMOS::Accounts::Bases::Attributes> object for C<$attribute>
178
179=cut
180
181sub attribute {
182    my ($self, $attribute) = @_;
183
184    my $attrinfo;
185    if (! ref $attribute) {
186        $attrinfo = $self->_get_attr_schema(
187            $self->base)->{$attribute}
188        or do { return };
189        $attrinfo->{name} = $attribute;
190    } else {
191        $attrinfo = $attribute;
192    }
193
194    return LATMOS::Accounts::Bases::Attributes->new(
195        $attrinfo,
196        $self,
197    );
198}   
199
200sub _canonical_fields {
201    my ($class, $base, $for) = @_;
202    $for ||= 'rw';
203    my $info = $base->_get_attr_schema($class->type);
204    my @attrs = map { $base->attribute($class->type, $_) } keys %{$info || {}};
205    @attrs = grep { ! $_->ro } @attrs if($for =~ /w/);
206    @attrs = grep { $_->readable } @attrs if($for =~ /r/);
207    @attrs = grep { !$_->hidden }  @attrs unless($for =~ /a/);
208    map { $_->name } @attrs;
209}
210
211=head2 GetOtypeDef
212
213This function is called to provide sub object definition. Must be overwritten
214per object class when need.
215
216Must return a hashref listing each sub object type and their related key atribute:
217
218    return {
219        addresses => 'user',
220    }
221
222=cut
223
224sub GetOtypeDef {
225    my ($class) = @_;
226
227    return;
228}
229
230=head2 get_field($field)
231
232Return the value for $field, must be provide by data base.
233
234    sub get_field {
235        my ($self, $field)
236    }
237
238=cut
239
240=head2 get_c_field($cfield)
241
242Return the value for canonical field $cfield.
243
244Call driver specific get_field()
245
246=cut
247
248sub get_c_field {
249    my ($self, $cfield) = @_;
250    $self->base->check_acl($self, $cfield, 'r') or do {
251        $self->base->log(LA_DEBUG, "Permission denied to get %s/%s",
252            $self->id, $cfield
253        );
254        return;
255    };
256    return $self->_get_c_field($cfield);
257}
258
259=head2 get_attributes($attr)
260
261Like get_c_field but always return an array
262
263=cut
264
265sub get_attributes {
266    my ($self, $cfield) = @_;
267    my $res = $self->get_c_field($cfield);
268    if ($res) {
269        return(ref $res ? @{$res} : $res);
270    } else {
271        return;
272    }
273}
274
275sub _get_attributes {
276    my ($self, $cfield) = @_;
277    my $res = $self->_get_c_field($cfield);
278    if ($res) {
279        return(ref $res ? @{$res} : ($res));
280    } else {
281        return;
282    }
283}
284
285sub _get_c_field {
286    my ($self, $cfield) = @_;
287
288    my $attribute = $self->attribute($cfield) or do {
289        $self->base->log(LA_WARN, "Unknown attribute $cfield for object type " . $self->type);
290        return;
291    };
292    $attribute->readable or do {
293        $self->base->log(LA_WARN, "Attribute $cfield is not readable");
294        return;
295    };
296    return $attribute->get; 
297}
298
299=head2 GetAttributeValue($cfield)
300
301Return the value to exposed to other base
302
303=cut
304
305sub GetAttributeValue {
306    my ($self, $cfield) = @_;
307
308    return $self->get_c_field($cfield);
309}
310
311
312sub _deref_attribute {
313    my ( $self, $attribute ) = @_;
314
315    my ( $derefAttr, $target ) = $attribute =~ /([^.]+)(.*)?/;
316
317    my $name = $self->get_c_field( $derefAttr ) or return;
318
319    if ( $target ) {
320        my $Attr = $self->attribute( $derefAttr );
321        if ( my $otype = $Attr->reference ) {
322            my @values;
323            foreach my $n ( ref $name ? @$name : $name ) {
324                my $obj = $self->base->get_object( $otype, $n ) or return;
325                my $res = $obj->_deref_attribute( $target );
326                push(@values, grep { $_ } (ref $res ? @$res : $res));
327            }
328            return scalar(@values) <= 1 ? $values[0] : \@values
329        }
330    } else {
331        return $name;
332    }
333
334}
335
336=head2 queryformat ($fmt)
337
338Return formated string according C<$fmt>
339
340=cut
341
342sub queryformat {
343    my ($self, $fmt) = @_;
344    $fmt ||= ''; # avoid undef
345    $fmt =~ s/\\n/\n/g;
346    $fmt =~ s/\\t/\t/g;
347
348    my $old;
349    do {
350        $old = $fmt;
351        $fmt =~ s&(?<!%)(?:%\{([\?!]+)?([^:}%]*)(?::([^}%]*))?\})&
352            my $op = $1;
353            my $attr = $2;
354            my $val = '';
355            my $modifier = $3 || '';
356           
357            if ($attr =~ /^(\w+)\((.*)\)$/) {
358                $val = $self->base->QFunc($1, $2);
359            } else {
360                $val = $self->_deref_attribute($2);
361            }
362
363            my $res = '';
364            $val = '' unless( defined( $val ) );
365
366            if ($op) {
367                if ($op eq '?') {
368                    $res = $val ? $3 : '';
369                } elsif ($op eq '?!') {
370                    $res = $val ? '' : $3;
371                }
372                if ($res =~ /^(\w+)\((.*)\)$/) {
373                    $res = $self->base->QFunc($1, $2);
374                }
375            } else {
376                $res = $val;
377                foreach (split('\|' , $modifier)) {
378                    /upper/ and do {
379                        $res = uc($res);
380                        next;
381                    };
382                    /ucfirst/ and do {
383                        $res = ucfirst($res);
384                        next;
385                    };
386                    /lower/ and do {
387                        $res = lc($res);
388                        next;
389                    };
390                    /lcfirst/ and do {
391                        $res = lcfirst($res);
392                        next;
393                    };
394                    /ascii/ and do {
395                        $res = LATMOS::Accounts::Utils::to_ascii($res);
396                        next;
397                    };
398                    /substr\s+(\d+)\s+(\d+)?/ and do {
399                        $res = substr($res, $1, $2);
400                        next;
401                    };
402                    /join\s+(\S+)/ and do {
403                        $res = join($1, ref $res ? @$res : $res );
404                        next;
405                    };
406                    $res = sprintf('%' . ($modifier || 's'), ref $val ? join(',', @$val) : (defined($val) ? $val : ''))
407                }
408            }
409            $res
410        &egx;
411    } while($old ne $fmt);
412    $fmt;
413}
414
415=head2 set_fields(%data)
416
417Set values for this object. %data is a list or peer field => values.
418
419    sub set_fields {
420        my ($self, %data) = @_;
421    }
422
423=cut
424
425=head2 checkValues ($base, $obj, %attributes)
426
427Allow to pre-check values when object are modified or created
428
429C<$obj> is either the new id at object creation or the object itself on modification.
430
431=cut
432
433sub checkValues {
434    my ($class, $base, $obj, %attributes) = @_;
435
436    return 1;
437}
438
439=head2 check_allowed_values ($attr, $values)
440
441Check if value C<$values> is allowed for attributes C<$attr>
442
443=cut
444
445sub check_allowed_values {
446    my ($self, $attr, $values) = @_;
447    $self->base->check_allowed_values($self->type, $attr, $values);
448}
449
450=head2 attr_allow_values ($attr)
451
452Return allowed for attribute C<$attr>
453
454=cut
455
456sub attr_allow_values {
457    my ($self, $attr) = @_;
458    return $self->base->obj_attr_allowed_values(
459        $self->type,
460        $attr,
461    );
462}
463
464=head2 set_c_fields(%data)
465
466Set values for this object. %data is a list or peer
467canonical field => values. Fields names are translated.
468
469=cut
470
471sub set_c_fields {
472    my ($self, %cdata) = @_;
473    foreach my $cfield (keys %cdata) {
474        $self->base->check_acl($self, $cfield, 'w') or do { 
475            $self->base->log(LA_ERR, "Cannot modify %s on %s/%s: %s",
476                $cfield, $self->type, $self->id, "permission denied");
477            return;
478        };
479    }
480
481    foreach my $cfield (keys %cdata) {
482        $self->check_allowed_values($cfield, $cdata{$cfield}) or do {
483            $self->base->log(LA_ERR, "Cannot modify %s/%s: %s",
484                $self->type, $self->id, "non authorized value ($cfield : $cdata{$cfield}");
485            return;
486        };
487    }
488
489    $self->_set_c_fields(%cdata);
490}
491
492sub _set_c_fields {
493    my ($self, %cdata) = @_;
494    my %data;
495    my $sub;
496    my $res = 0;
497    foreach my $cfield (keys %cdata) {
498
499        if (my ($sotype, $key, $scfield) = $cfield =~ /^(\w+)(?:\[(\w+)\])?\.(.*)/) {
500            $key ||= '_';
501            $sub->{$sotype}{$key}{$scfield} = $cdata{$cfield};
502            next;
503        }
504
505        my $attribute = $self->attribute($cfield) or do {
506            $self->base->log(LA_ERR,
507                "Cannot set unsupported attribute %s to %s (%s)",
508                $cfield, $self->id, $self->type
509            );
510            return;
511        };
512        $attribute->ro and do {
513            $self->base->log(LA_ERR,
514                "Cannot set read-only attribute %s to %s (%s)",
515                $cfield, $self->id, $self->type
516            );
517            return;
518        };
519
520        if (!$attribute->checkinput($cdata{$cfield})) {
521            $self->base->log(LA_ERR,
522                "Value for attribute %s to %s (%s) does not match requirements",
523                $cfield, $self->id, $self->type
524            );
525            return;
526        };
527    }
528
529    if (!$self->checkValues($self->base, $self, %cdata)) {
530        my $last = LATMOS::Accounts::Log::lastmessage(LA_ERR);
531        $self->base->log(LA_ERR,
532            "Cannot update %s (%s): wrong value%s",
533            $self->id, $self->type,
534            ($last ? ": $last" : $last)
535        );
536        return;
537    }
538
539    my %updated = ();
540    foreach my $cfield (keys %cdata) {
541        my $attribute = $self->attribute($cfield) or do {
542            $self->base->log(LA_ERR,
543                "Cannot set unsupported attribute %s to %s (%s)",
544                $cfield, $self->id, $self->type
545            );
546            return;
547        };
548        if ($attribute->set($cdata{$cfield})) {
549            $updated{$cfield} = $attribute->monitored;
550        }
551    }
552
553    my $subupdate = 0;
554    if ($sub) {
555
556        # Security: if caller is create_c_object calling it to check permission ?
557        # See below
558        # my ($caller) = caller();
559        # my $subcreate = $caller eq 'create_c_object' ? 'create_c_object' : __SUB__;
560
561        # Trying to create subobject
562        foreach my $sotype (keys %$sub) {
563            my $SubKeyRef = $self->base->GetSubObjectKey($self->otype, $sotype) or do {
564                $self->base->log(LA_ERR, "Cannot create object type $sotype, subtype of " . $self->otype . " not defined");
565                return;
566            };
567            foreach my $skey (keys %{ $sub->{$sotype} || {} }) {
568                # TODO Check if object exists !
569                # Building id
570                my $info = $sub->{$sotype}{$skey} || {};
571                # For id: if key is given using it, otherwise using random
572                my $sid =
573                    $info->{$SubKeyRef} ||
574                    $self->id . '-' . join('', map { ('a' .. 'z')[rand(26)] } (0 .. 6));
575                $info->{$SubKeyRef} = $self->id;
576
577                # Here we don't check permission to create sub object:
578                $self->base->_create_c_object($sotype, $sid, %{ $info || {} }) or return;
579                $subupdate++;
580            }
581        }
582    }
583
584
585    if (keys %updated) {
586        $self->PostSetAttribute() or do {
587            $self->base->log(LA_ERR, "PostSetAttribute failed when updating %s/%s",
588                $self->type, $self->id);
589            return;
590        };
591
592        $self->ReportChange('Update', 'Attributes %s have been updated', join(', ', sort keys %updated));
593        foreach (sort keys %updated) {
594            $self->ReportChange('Attributes', '%s set to %s', $_, 
595                (ref $cdata{$_}
596                    ? join(', ', sort @{ $cdata{$_} })
597                    : $cdata{$_}) || '(none)')
598                if ($updated{$_});
599        }
600    }
601    return(scalar(keys %updated) + $subupdate);
602}
603
604=head2 PostSetAttribute
605
606This function is call to compute data when object is modify.
607
608=cut
609
610sub PostSetAttribute {
611    my ($self) = @_;
612
613    return 1;
614}
615
616=head2 addAttributeValue($attribute, $value)
617
618Add a value to a multivalue attributes
619
620=cut
621
622sub _addAttributeValue {
623    my ($self, $attribute, @values) = @_;
624
625    my @oldvalues = grep { $_ } $self->_get_attributes($attribute);
626    $self->_set_c_fields($attribute => [ @oldvalues, @values ]);
627}
628
629sub addAttributeValue {
630    my ($self, $attribute, @values) = @_;
631
632    my @oldvalues = grep { $_ } $self->_get_attributes($attribute);
633    $self->set_c_fields($attribute => [ @oldvalues, @values ]);
634}
635
636=head2 delAttributeValue($attribute, $value)
637
638Remove a value to a multivalue attributes
639
640=cut
641
642sub _delAttributeValue {
643    my ($self, $attribute, @values) = @_;
644
645    my @oldvalues = grep { $_ } $self->_get_attributes($attribute);
646
647    foreach my $value (@values) {
648        @oldvalues = grep { $_ ne $value } @oldvalues;
649    }
650
651    $self->_set_c_fields($attribute => @oldvalues ? [ @oldvalues, ] : undef );
652}
653
654sub delAttributeValue {
655    my ($self, $attribute, @values) = @_;
656
657    my @oldvalues = grep { $_ } $self->_get_attributes($attribute);
658
659    foreach my $value (@values) {
660        @oldvalues = grep { $_ ne $value } @oldvalues;
661    }
662
663    $self->set_c_fields($attribute => @oldvalues ? [ @oldvalues, ] : undef );
664}
665
666=head2 set_password($password)
667
668Set the password into the database, $password is the clear version
669of the password.
670
671This function store it into userPassword canonical field if supported
672using crypt unix and md5 algorythm (crypt md5), the salt is 8 random
673caracters.
674
675The base driver should override it if another encryption is need.
676
677=cut
678
679sub set_password {
680    my ($self, $clear_pass) = @_;
681    if ($self->base->check_acl($self, 'userPassword', 'w')) {
682        if ($self->_set_password($clear_pass)) {
683             $self->ReportChange('Password', 'user password has changed');
684             return 1;
685        } else {
686            return;
687        }
688    } else {
689        $self->base->log(LA_ERROR, "Permission denied for %s to change its password",
690            $self->id);
691        return;
692    }
693}
694
695sub _set_password {
696    my ($self, $clear_pass) = @_;
697    if (my $attribute = $self->base->attribute($self->type, 'userPassword')) {
698        my $res = $self->set_fields($attribute->iname, $self->base->passCrypt($clear_pass));
699        $self->base->log(LA_NOTICE, 'Mot de passe changé pour %s', $self->id)
700            if($res);
701        return $res;
702    } else {
703        $self->base->log(LA_WARN,
704            "Cannot set password: userPassword attributes is unsupported");
705    }
706}
707
708=head2 check_password ($password)
709
710Check given password is secure using L<Crypt::Cracklib>
711
712=cut
713
714sub check_password {
715    my ( $self, $password ) = @_;
716    my $dictionary = $self->base->config('cracklib_dictionnary');
717
718    if ($password !~ /^[[:ascii:]]*$/) {
719       return "the password must contains ascii characters only";
720    }
721
722    return fascist_check($password, $dictionary);
723}
724
725=head2 InjectCryptPasswd($cryptpasswd)
726
727Inject a password encrypted using standard UNIX method.
728
729=cut
730
731sub InjectCryptPasswd {
732    my ($self, $cryptpasswd) = @_;
733
734    if ($self->can('_InjectCryptPasswd')) {
735        return $self->_InjectCryptPasswd($cryptpasswd);
736    } else {
737        $self->base->log(LA_ERR, 'Injecting unix crypt password is not supported');
738        return;
739    }
740}
741
742=head2 search ($base, @filter)
743
744Search object matching C<@filter>
745
746=cut
747
748sub search {
749    my ($class, $base, @filter) = @_;
750    my @results;
751    my %parsed_filter;
752    while (my $item = shift(@filter)) {
753        # attr=foo => no extra white space !
754        # \W is false, it is possible to have two char
755        my ($attr, $mode, $val) = $item =~ /^(\w+)(?:(\W)(.+))?$/ or next;
756        if (!$mode) {
757            $mode = '~';
758            $val = shift(@filter);
759        }
760        push(
761            @{$parsed_filter{$attr}},
762            {
763                attr => $attr,
764                mode => $mode,
765                val  => $val,
766            }
767        );
768    }
769    foreach my $id ($base->list_objects($class->type)) {
770        my $obj = $base->get_object($class->type, $id);
771        my $match = 1;
772        foreach my $field (keys %parsed_filter) {
773            $base->attribute($class->type, $field) or
774                la_log(LA_WARN, "Unsupported attribute %s", $field);
775            my $tmatch = 0;
776            foreach (@{$parsed_filter{$field}}) {
777                my $value = $_->{val};
778                my $fval = $obj->_get_c_field($field) || '';
779                if ($value eq '*') {
780                    if ($fval ne '') {
781                        $tmatch = 1;
782                        last;
783                    }
784                } elsif ($value eq '!') {
785                    if ($fval eq '') {
786                        $match = 1;
787                        last;
788                    }
789                } elsif ($_->{mode} eq '=') {
790                    if ($fval eq $value) {
791                        $tmatch = 1;
792                        last;
793                    }
794                } elsif($_->{mode} eq '~') {
795                    if ($fval =~ m/\Q$value\E/i) {
796                        $tmatch = 1;
797                        last;
798                    }
799                }
800            }
801            $match = 0 unless($tmatch);
802        }
803        push(@results, $id) if($match);
804    }
805    @results;
806}
807
808=head2 attributes_summary ($base, $attribute)
809
810Return list of values existing in base for C<$attribute>
811
812=cut
813
814sub attributes_summary {
815    my ($class, $base, $attribute) = @_;
816    my $attr = $base->attribute($class->type, $attribute) or do {
817        $base->log(LA_WARN, "Cannot instantiate %s attribute for class %s", $attribute, $class->type);
818        return;
819    };
820    if (!$attr->readable) {
821        $base->log(LA_WARN, l('Attribute %s is not readable', $attribute));
822        return;
823    }
824    if (!$base->check_acl($class->type, $attribute, 'r')) {
825        $base->log(LA_WARN, l('Permission denied to read attribute %s', $attribute));
826        return;
827    }
828    my %values;
829    foreach my $id ($base->list_objects($class->type)) {
830        my $obj = $base->get_object($class->type, $id);
831        my $value = $obj->_get_c_field($attribute);
832        if ($value) {
833            if (ref $value) {
834                foreach (@$value) {
835                    $values{$_} = 1;
836                }
837            } else {
838                $values{$value} = 1;
839            }
840        }
841    }
842    return sort(keys %values);
843}
844
845=head2 attributes_summary_by_object ($base, $attribute)
846
847Return list of peer object <=> values
848
849=cut
850
851sub attributes_summary_by_object {
852    my ($class, $base, $attribute) = @_;
853    my $attr = $base->attribute($class->type, $attribute) or do {
854        $base->log(LA_WARN, "Cannot instantiate %s attribute for class %s", $attribute, $class->type);
855        return;
856    };
857    if (!$attr->readable) {
858        $base->log(LA_WARN, l('Attribute %s is not readable', $attribute));
859        return;
860    }
861    if (!$base->check_acl($class->type, $attribute, 'r')) {
862        $base->log(LA_WARN, l('Permission denied to read attribute %s', $attribute));
863        return;
864    }
865    my %values;
866    foreach my $id ($base->list_objects($class->type)) {
867        my $obj = $base->get_object($class->type, $id);
868        my $value = $obj->_get_c_field($attribute);
869        if ($value) {
870            if (ref $value) {
871                foreach (@$value) {
872                    push(@{ $values{ $id } }, $_);
873                }
874            } else {
875                push(@{ $values{ $id } }, $value);
876            }
877        }
878    }
879    return %values;
880}
881
882=head2 find_next_numeric_id ($base, $field, $min, $max)
883
884Find next free uniq id for attribute C<$field>
885
886=cut
887
888sub find_next_numeric_id {
889    my ($class, $base, $field, $min, $max) = @_;
890    $base->attribute($class->type, $field) or return;
891    $min ||= 
892        $field eq 'uidNumber' ? 500 :
893        $field eq 'gidNumber' ? 500 :
894        1;
895    $max ||= 65635;
896    $base->log(LA_DEBUG, "Trying to find %s in range %d - %d",
897        $field, $min, $max);
898    my %existsid;
899    $base->temp_switch_unexported(sub {
900        foreach ($base->list_objects($class->type)) {
901            my $obj = $base->get_object($class->type, $_) or next;
902            my $id = $obj->_get_c_field($field) or next;
903            $existsid{$id + 0} = 1;
904        }
905    }, 1);
906    $min += 0;
907    $max += 0;
908    for(my $i = $min; $i <= $max; $i++) {
909        $existsid{$i + 0} or do {
910            $base->log(LA_DEBUG, "Next %s found: %d", $field, $i);
911            return $i;
912        };
913    }
914    return;
915}
916
917=head2 ListChildObjects
918
919List dependant objects.
920
921=cut
922
923sub ListChildObjects {
924    my ( $self ) = @_;
925
926    return;
927}
928
929=head2 DataDump($config)
930
931Return a structure about the object
932
933=cut
934
935sub DataDump {
936    my ($self, $config, $base) = @_;
937
938    # {
939    #   base => # base latmoslocal: object address/thauvin-GY
940    #   otype => 'otype',
941    #   id => 'name',
942    #   roAttrs => []
943    #   Attrs => {
944    #       'Attr' => [],
945    #   }
946    #   subObjs => {
947    #       'otype' => [],
948    #   }
949    # }
950
951
952    $config->{level} ||= 0;
953    my $otype = $self->type;
954    $base ||= $self->base;
955    my $dump = {
956        otype => $otype,
957        id => ref $self ? $self->id : 'N/A',
958    };
959    if (ref $self) {
960        $dump->{base} = $base->label;
961    }
962
963    my %roAttrs = ();
964    foreach my $attr (sort { $a cmp $b } $base->list_canonical_fields($otype,
965        $config->{only_rw} ? 'rw' : 'r')) {
966        my $oattr = ref $self ? $self->attribute($attr) : $base->attribute($otype, $attr);
967        next if ($oattr->hidden);
968
969        if (ref $self) {
970            my $val = $self->get_c_field($attr);
971            if ($val || $config->{empty_attr}) {
972                my @vals = ref $val ? @{ $val } : $val;
973                $dump->{Attrs}{$attr} = \@vals;
974                $roAttrs{ $attr } = 1 if ($oattr->ro);
975            }
976        } else {
977            $dump->{Attrs}{$attr} = undef;
978            $roAttrs{ $attr } = 1 if ($oattr->ro);
979        }
980
981        $dump->{roAttrs} = [ sort keys %roAttrs ]
982            unless($config->{noSchema});
983    }
984
985    if ($config->{cb}) {
986        $config->{cb}->($config, $dump);
987    }
988
989    my $SubOtype = undef;
990
991    if (@{ $config->{SubOtype} || []}) {
992        $SubOtype = { map { $_ => 1 } @{ $config->{SubOtype} } };
993    }
994
995    if (ref $self && $config->{recur}) {
996          my %subobj = $self->ListChildObjects;
997          foreach my $otype (sort keys %subobj) {
998              if ($SubOtype) {
999                  $SubOtype->{$otype} or next;
1000              }
1001              foreach my $oname (sort @{ $subobj{$otype} }) {
1002                  my $obj = $self->base->get_object($otype, $oname) or next;
1003                  push(@{ $dump->{subObjs}{$otype} }, $obj->DataDump({ %{$config || {}}, recur => $config->{recur}, level => $config->{level} + 2 }));
1004              }
1005          }
1006    }
1007
1008    return $dump;
1009}
1010
1011=head2 text_dump ($handle, $config, $base)
1012
1013Dump object into C<$handle>
1014
1015=cut
1016
1017sub text_dump {
1018    my ($self, $handle, $config, $base) = @_;
1019    print $handle $self->dump($config, $base);
1020    return 1;
1021}
1022
1023=head2 dump
1024
1025Return dump for this object
1026
1027=cut
1028
1029sub dump {
1030    my ($self, $InitConfig, $base) = @_;
1031
1032    $InitConfig->{level} ||= 0;
1033    $base ||= $self->base;
1034    my $dump = '';
1035
1036    $InitConfig->{cb} = sub {
1037        my ( $config, $Dump ) = @_;
1038
1039        if ($config->{level}) {
1040            $dump .= "\n";
1041        }
1042
1043        if (ref $self) {
1044            $dump .= sprintf "%s# base %s: object %s/%s\n",
1045                ' ' x $config->{level},
1046                $Dump->{base}, $Dump->{otype}, $Dump->{id};
1047        }
1048        $dump .= sprintf(
1049            "%s# %s\n",
1050            ' ' x $config->{level},
1051            scalar(localtime)
1052        );
1053
1054        my %roAttrs = map { $_ => 1 } @{ $Dump->{roAttrs} || [] };
1055
1056        foreach my $attr (sort { $a cmp $b } sort keys %{ $Dump->{Attrs} || {} }) {
1057            my $val = $Dump->{Attrs}{$attr};
1058            my $oattr = $base->attribute($Dump->{otype}, $attr);
1059            if ($val) {
1060                if (my @allowed = $base->obj_attr_allowed_values($Dump->{otype}, $attr)) {
1061                    $dump .= sprintf("%s# %s must be%s: %s\n",
1062                        ' ' x $config->{level},
1063                        $attr,
1064                        ($oattr->mandatory ? '' : ' empty or either'),
1065                        join(', ', @allowed)
1066                    );
1067                }
1068
1069                foreach (@$val) {
1070                    $_ ||= '';
1071                    s/\r?\n/\\n/g;
1072                    $dump .= sprintf("%s%s%s%s:%s\n",
1073                        ' ' x $config->{level},
1074                        $roAttrs{$attr} ? '# (ro) ' : '',
1075                        $config->{level} ? $Dump->{otype} . '[' . $Dump->{id} . '].' : '',
1076                        $attr, $_ ? " $_" : '');
1077                }
1078            } elsif ( $config->{empty_attr} || ! ref $self) {
1079                if (my @allowed = $base->obj_attr_allowed_values($Dump->{otype}, $attr)) {
1080                    $dump .= sprintf("%s# %s must be%s: %s\n",
1081                        ' ' x $config->{level},
1082                        $attr,
1083                        ($oattr->mandatory ? '' : ' empty or either'),
1084                        join(', ', @allowed)
1085                    );
1086                }
1087                $dump .= sprintf("%s%s%s%s:\n",
1088                    ' ' x $config->{level},
1089                    $roAttrs{$attr} ? '# (ro) ' : '',
1090                    $config->{level} ? $Dump->{otype} . '[' . $Dump->{id} . '].' : '',
1091                    $attr);
1092            }
1093        }
1094    };
1095
1096    $self->DataDump($InitConfig, $base);
1097
1098    return $dump;
1099}
1100
1101=head2 ReportChange($changetype, $message, @args)
1102
1103Possible per database way to log changes
1104
1105=cut
1106
1107sub ReportChange {
1108    my ($self, $changetype, $message, @args) = @_;
1109
1110    $self->base->ReportChange(
1111        $self->type,
1112        $self->id,
1113        $self->Iid,
1114        $changetype, $message, @args
1115    )
1116}
1117
11181;
1119
1120__END__
1121
1122
1123=head1 SEE ALSO
1124
1125L<LATMOS::Accounts::Bases>
1126
1127=head1 AUTHOR
1128
1129Thauvin Olivier, E<lt>olivier.thauvin.ipsl.fr@localdomainE<gt>
1130
1131=head1 COPYRIGHT AND LICENSE
1132
1133Copyright (C) 2009 by Thauvin Olivier
1134
1135This library is free software; you can redistribute it and/or modify
1136it under the same terms as Perl itself, either Perl version 5.10.0 or,
1137at your option, any later version of Perl 5 you may have available.
1138
1139=cut
Note: See TracBrowser for help on using the repository browser.