source: trunk/LATMOS-Accounts/lib/LATMOS/Accounts/Bases/Sql/objects.pm @ 2448

Last change on this file since 2448 was 2448, checked in by nanardon, 4 years ago

Fix: ListReal? returning all userstatus instead only futur one
  • Property svn:keywords set to Id Rev
File size: 47.5 KB
Line 
1package LATMOS::Accounts::Bases::Sql::objects;
2
3use 5.010000;
4use strict;
5use warnings;
6
7use base qw(LATMOS::Accounts::Bases::Objects);
8use LATMOS::Accounts::Log;
9use Crypt::RSA;
10use Crypt::RSA::Key::Public::SSH;
11use DateTime;
12use LATMOS::Accounts::I18N;
13
14our $VERSION = (q$Rev: 2105 $ =~ /^Rev: (\d+) /)[0];
15
16=head1 NAME
17
18LATMOS::Accounts::Bases::Sql::objects - Parent class for SQL object
19
20=cut
21
22# Write extend attribute table
23sub _object_table_attributes      { $_[0]->_object_table . '_attributes' }
24# Read search table (with compute attribute)
25sub _object_table_attributes_read { $_[0]->_object_table . '_attributes' }
26
27sub listReal {
28    my ($class, $base) = @_;
29
30    $class->list( $base, 'True' );
31}
32
33sub list {
34    my ($class, $base, $Real) = @_;
35
36    my $sth = $base->db->prepare_cached(
37        sprintf(
38            q{select %s as k from %s where internobject = false %s %s order by %s},
39            $base->db->quote_identifier($class->_key_field),
40            $base->db->quote_identifier($class->_object_table),
41            ($base->{wexported} ? '' : 'and exported = true'),
42            ($Real ? 'and oalias IS NULL' : ''),
43            $base->db->quote_identifier($class->_key_field),
44        )
45    );
46    $sth->execute;
47    my @keys;
48    while(my $res = $sth->fetchrow_hashref) {
49        push(@keys, $res->{k});
50    }
51    @keys
52}
53
54sub list_from_rev {
55    my ($class, $base, $rev) = @_;
56    my $sth = $base->db->prepare_cached(
57        sprintf(
58            q{select %s as k from %s where rev > ? and internobject = false
59                and oalias IS NULL  %s order by %s},
60            $base->db->quote_identifier($class->_key_field),
61            $base->db->quote_identifier($class->_object_table),
62            ($base->{wexported} ? '' : 'and exported = true'),
63            $base->db->quote_identifier($class->_key_field),
64        )
65    );
66    $sth->execute($rev);
67    my @keys;
68    while(my $res = $sth->fetchrow_hashref) {
69        push(@keys, $res->{k});
70    }
71    @keys
72}
73
74sub _has_extended_attributes { 0 }
75
76sub _get_attr_schema {
77    my ($class, $base, $info) = @_;
78    $info ||= {};
79    if (!$base->{__cache}{$class->_object_table}{inline}) {
80        $base->{__cache}{$class->_object_table}{inline} = [];
81        my $sth = $base->db->prepare(
82            q{SELECT column_name FROM information_schema.columns
83              WHERE table_name = ?}
84        );
85        $sth->execute($class->_object_table);
86        while (my $res = $sth->fetchrow_hashref) {
87            push(@{$base->{__cache}{$class->_object_table}{inline}},
88                $res->{column_name});
89        }
90    }
91    foreach (@{$base->{__cache}{$class->_object_table}{inline}}) {
92        $info->{$_}{inline} = 1;
93        if (m/^(rev|date|create|ikey)$/) {
94            $info->{$_}{ro} = 1
95        }
96    }
97
98    # Common to all object attribute:
99    my %commons = (
100        name      => {
101            inline => 1,
102            ro => 1,
103            label => l('Name'),
104        },
105        create    => {
106            inline => 1,
107            ro => 1,
108            label => l('Created'),
109        },
110        date      => {
111            inline => 1,
112            ro => 1,
113            label => l('Last modified'),
114        },
115        exported   =>   { inline => 1, formtype => 'CHECKBOX', hide => 1, monitored => 1 },
116        unexported =>   {
117            inline => 1,
118            managed => 1,
119            formtype => 'CHECKBOX',
120            get => sub {
121                my ($self) = @_;
122                return $self->object->get_field('exported') ? undef : 1;
123            },
124            set => sub {
125                my ($self, $data) = @_;
126                $self->object->_set_c_fields('exported', $data ? 0 : 1);
127            },
128            label => l('Hidden'),
129        },
130        services   =>   {
131            managed => 1,
132            multiple => 1,
133            reference => 'service',
134            label => l('Service'),
135        },
136        modifiedby =>   {
137            inline  => 1,
138            reference => 'user',
139            ro => 1,
140            label => l('Modified by'),
141        },
142        createdby => {
143            inline  => 1,
144            reference => 'user',
145            ro => 1,
146            label => l('Created by'),
147        },
148        oalias => {
149            inline  => 1,
150            reference => $class->type,
151            label => l('Object alias for'),
152            post => sub {
153                my ($self, $value) = @_;
154                $self->object->_update_aliases_ptr();
155                $self->object->_update_aliases_cache();
156            },
157            checkinput => sub {
158                my ($oalias) = @_;
159                my $otype = $class->type;
160                $oalias ||= '';
161
162                if (my ($aliasotype, $aliasoname, $aliasattr) = $oalias =~ m/^([^\/]+)\.([^\.]+)\.(.*)$/) {
163                    my $attribute = $base->attribute($aliasotype, $aliasattr) or do {
164                        $base->log(LA_DEBUG, "Oalias %s (%s): can fetch attibute %s/%s",
165                            $otype, $oalias, $aliasotype, $aliasattr);
166                        return;
167                    };
168                    my $refotype = $attribute->reference or do {
169                        $base->log(LA_DEBUG, "Oalias %s (%s): Attribute does not reference an object",
170                            $otype, $oalias);
171                        return;
172                    };
173
174                    if ($attribute->multiple) {
175                        $base->log(LA_DEBUG, "Oalias %s (%s): Attribute must not be multiple",
176                            $otype, $oalias);
177                        return;
178                    };
179                } elsif(!$base->get_object($otype, $oalias)) {
180                    $base->log(LA_DEBUG, "Cannot get object $otype/$oalias");
181                    return;
182                }
183                return 1;
184            },
185        },
186        oaliascache => {
187            inline  => 1,
188            reference => $class->type,
189            label => l('Cache for oalias data'),
190            hide => 1,
191        },
192        internobject => {
193            inline  => 1,
194            label => l('Internal object'),
195            hide => 1,
196        },
197        nodelete => {
198            inline => 1,
199            label => l('Deletion protection'),
200            hide => 1,
201        },
202        setReftoMe  => {
203            multiple => 1,
204            managed => 1,
205            delayed => 1,
206            set => sub {
207                my ($self, $data) = @_;
208                my $count = 0;
209                foreach (ref $data ? @{$data} : $data) {
210                    my ($otype, $oname, $attribute) = $_ =~ m/^([^\.]+)\.(.+)\.([^\.]+)$/ or next;
211                    my $object = $base->get_object($otype, $oname) or next;
212                    my $attr = $base->attribute($otype, $attribute) or next;
213                    if ($attr->reference ne $self->object->type) {
214                        $base->log(LA_ERR, "Cannot set $_ pointing to " . $self->object->id . ": attribute does not reference " . $self->object->type);
215                        return;
216                    }
217                    if ($attr->multiple) {
218                        my @values = $object->get_attributes($attribute);
219                        $count += $object->set_c_fields($attribute => [ @values, $self->object->id ]);
220                    } else {
221                        $count += $object->set_c_fields($attribute => $self->object->id);
222                    }
223                }
224                return $count;
225            },
226            label => l('Set me as reference'),
227        },
228        log => {
229            multiple => 1,
230            managed => 1,
231            ro => 1,
232            hide => 1,
233            get => sub {
234                my ($self) = @_;
235                return [
236                    map { sprintf(
237                    "%s (%d), %s: %s/%s (%d) %s",
238                    $_->{logdate},
239                    $_->{irev} || -1,
240                    $_->{username},
241                    $_->{otype},
242                    $_->{name},
243                    $_->{ikey},
244                    $_->{message}
245                ) } $self->object->base->getobjectlogs(
246                    $self->object->type,
247                    $self->object->id,
248                ) ];
249            },
250        },
251        template => {
252            reference => 'templates',
253            can_values => sub {
254                $base->search_objects('templates', 'objectType=' . $class->type, 'exported=1')
255            },
256            ro => sub { ref $_[0] ? 1 : 0 },
257            set => sub {},
258        },
259    );
260
261    # Merging / overriding with common to all object attributes properties
262    foreach my $attr (keys %commons) {
263        foreach my $var (keys %{ $commons{$attr} }) {
264            $info->{$attr}{$var} = $commons{$attr}{$var};
265        }
266    }
267
268    $info
269}
270
271# Everything managed by the perl code
272
273sub _managed_fields {
274    my ($class, $for, $base) = @_;
275    return();
276}
277
278sub new {
279    my ($class, $base, $id) = @_;
280
281    my $__cache = $base->{__cache}{"_" . $class->type};
282
283    if (!(exists($__cache->{$id})
284        && $__cache->{$id}{__time} >= time - 1)) {
285
286        my $sth = $base->db->prepare_cached(
287            sprintf(q{ select 1 from %s where %s = ? %s},
288                $base->db->quote_identifier($class->_object_table),
289                $base->db->quote_identifier($class->_key_field),
290                ($base->{wexported} ? '' : 'and exported = true'),
291            ),
292        );
293        my $count = $sth->execute($id);
294        $sth->finish;
295        ($count || 0) == 1 or return;
296    }
297    $class->SUPER::new($base, $id);
298}
299
300sub Iid { $_[0]->_get_ikey }
301
302=head2 ParentObject
303
304When object is part of another return the parent object, return undef otherwise.
305
306=cut
307
308sub ParentObject { }
309
310=head2 ListChildObjects
311
312Return objects having this object as Parent
313
314=cut
315
316sub ListChildObjects {
317    my ($self) = @_;
318
319    my $Subotype = $self->GetOtypeDef or return;
320
321    my %res;
322
323    foreach my $otype (keys %$Subotype) {
324        my %objectNames = ();
325        foreach my $attr (ref $Subotype->{$otype} ? @{ $Subotype->{$otype} } : $Subotype->{$otype}) {
326            my @list = $self->base->search_objects( $otype, $attr . '=' . $self->id );
327            foreach (@list) {
328                $objectNames{ $_ } = 1;
329            }
330        }
331        if (keys %objectNames) {
332            $res{$otype} = [ sort keys %objectNames ];
333        }
334    }
335
336    %res;
337}
338
339sub _get_ikey {
340    my ($class, $base, $id) = @_;
341    $base ||= $class->base;
342    $id ||= $class->id;
343    my $sth = $base->db->prepare_cached(
344        sprintf(
345            q{select ikey from %s where %s = ?},
346            $base->db->quote_identifier($class->_object_table),
347            $base->db->quote_identifier($class->_key_field),
348        )
349    );
350    $sth->execute($id);
351    my $res = $sth->fetchrow_hashref;
352    $sth->finish;
353    $res->{ikey}
354}
355
356sub _create {
357    my ($class, $base, $id, %data) = @_;
358
359    # splitting inline from extended
360    my (%first, %second);
361    # Ensure object is exported if not specified
362    $data{exported} = 1 if (!exists($data{exported}));
363    if (exists $data{unexported}) {
364        $data{exported} = $data{unexported} ? 0 : 1;
365        delete $data{unexported}
366    }
367    foreach (keys %data) {
368        my $attr = $base->attribute($class->type, $_) or next;
369        $_ =~ /^exported$/ and $data{$_} = $data{$_} ? 1 : 0;
370        my $formatted = ref($data{$_})
371            ? [ map { $attr->input($_) } @{ $data{$_} } ]
372            : $attr->input($data{$_});
373        if ($attr->{inline} && ! $attr->{delayed}) {
374            my $iname = $attr->iname;
375            $first{$iname} = $formatted;
376        } else {
377            # the real internal name will be translate by _set_c_field
378            $second{$_} = $formatted if(defined($formatted));
379        }
380    }
381    $first{$class->_key_field} = $id;
382    $first{createdby} =  $base->LogUser;
383    $first{modifiedby} = $base->LogUser;
384
385    my $lastid;
386    {
387        my $sthnextval = $base->db->prepare_cached("select nextval('ikey_seq') as c");
388        $sthnextval->execute;
389        $lastid = $sthnextval->fetchrow_hashref()->{c};
390        $first{ikey} = $lastid;
391        $sthnextval->finish;
392    }
393
394    my $sth = $base->db->prepare(
395        sprintf(
396            q{insert into %s (%s) values (%s)},
397            $base->db->quote_identifier($class->_object_table),
398            join(', ', map { $base->db->quote_identifier($_) } sort keys %first),
399            join(',', qw(?) x scalar(keys %first)),
400        )
401    );
402    $sth->execute(map { defined($first{$_}) ? $first{$_} : undef } sort keys %first) or return;
403
404    my $sthid = $base->db->prepare_cached(
405        sprintf(q{select %s as k from %s where ikey = ?},
406            $base->db->quote_identifier($class->_key_field),
407            $base->db->quote_identifier($class->_object_table),
408        )
409    );
410    $sthid->execute($lastid);
411    my $res = $sthid->fetchrow_hashref();
412    $sthid->finish;
413    $res or do {
414        $base->log(LA_DEBUG, 'Cannot retrieve SQL row from freshly create object %s/%s', $class->type, $id);
415        return;
416    };
417
418    my $obj = $class->new($base, $res->{k}) or return;
419    if (keys %second) {
420        $obj->_set_c_fields(%second) or do {
421            $base->log(LA_DEBUG, 'Cannot set attributes to freshly create object %s/%s', $class->type, $id);
422            return;
423        };
424    }
425
426    $obj->PostSetAttribute;
427
428    my @parents = $obj->ParentObject;
429    foreach my $pobj (@parents) {
430        $pobj->PostSetAttribute;
431    }
432
433    return $res->{k};
434}
435
436=head2 refreshRev
437
438Increase revision of the object to force synchronisation
439
440=cut
441
442sub refreshRev {
443    my ($self) = @_;
444
445    my $sth = $self->db->prepare_cached(
446        sprintf(q{
447                UPDATE %s SET rev = nextval('revisions_rev_seq'::regclass)  WHERE %s = ?
448            },
449            $self->db->quote_identifier($self->_object_table),
450            $self->db->quote_identifier($self->_key_field),
451        )
452    );
453    $sth->execute($self->id);
454}
455
456=head2 CreateAlias($base, $name, $for)
457
458Create an alias named C<$name> with pointing to C<$for>
459
460=cut
461
462sub CreateAlias {
463    my ($class, $base, $name, $for) = @_;
464
465    $base->log(LA_ERR, '%s does not support alias object, alias %s not created', $class->type, $name);
466}
467
468sub _delete {
469    my ($class, $base, $id) = @_;
470
471    my $__cache = $base->{__cache}{"_" . $class->type};
472
473    my $obj = $base->get_object($class->type, $id)
474        or return;
475
476    if ($obj->_get_attributes('internobject')) {
477        # Cannot happend: internal are not fetchable
478        $base->log(LA_ERR,'Cannot delete %s/%s: is an internal object', $class->type, $id);
479        return;
480    }
481    if ($obj->_get_attributes('nodelete')) {
482        $base->log(LA_ERR,'Cannot delete %s/%s: is write protected', $class->type, $id);
483        return;
484    }
485
486    $obj->ReportChange('Delete', 'Removing %s.%s object', $obj->type, $obj->id);
487
488    my @parents = $obj->ParentObject;
489
490    my $sthd = $base->db->prepare_cached(
491        sprintf(
492            q{delete from %s where %s = ?},
493            $base->db->quote_identifier($class->_object_table),
494            $base->db->quote_identifier($class->_key_field),
495        )
496    );
497    my $res = $sthd->execute($id);
498    if ($res) {
499        delete($__cache->{$id});
500    }
501
502    foreach my $pobj (@parents) {
503        $res += $pobj->PostSetAttribute;
504    }
505
506    $res
507}
508
509sub _rename {
510    my ($class, $base, $id, $newid) = @_;
511
512    my $sthr = $base->db->prepare_cached(
513        sprintf(
514            q{update %s set %s = ? where %s = ?},
515            $base->db->quote_identifier($class->_object_table),
516            $base->db->quote_identifier($class->_key_field),
517            $base->db->quote_identifier($class->_key_field),
518        )
519    );
520
521    if (($sthr->execute($newid, $id) || 0) != 1) {
522        $base->log(LA_ERR, "Erreur renaming %s %s to %s",
523            $class->type,
524            $id, $newid,
525        );
526        return;
527    }
528
529    1;
530}
531
532=head2 db
533
534Return reference to L<DBI> object.
535
536=cut
537
538sub db {
539    return $_[0]->base->db;
540}
541
542sub _quote_object_table {
543    my ($self) = @_;
544    my $table = $self->_object_table or return;
545    $self->db->quote_identifier($table);
546}
547sub _quote_key_field {
548    my ($self) = @_;
549    my $key_field = $self->_key_field or return;
550    $self->db->quote_identifier($key_field);
551}
552
553sub get_field {
554    my ($self, $field) = @_;
555    if ($field eq 'services') {
556        my @services;
557        my $sth = $self->db->prepare_cached(
558            q{ select name from service join service_attributes
559               on okey = ikey
560               where service_attributes.attr = 'dependOn' and value = ?
561               });
562        $sth->execute($self->type . '.' . $self->id);
563        while(my $res = $sth->fetchrow_hashref) {
564            push(@services, $res->{name});
565        }
566        return \@services; 
567    }
568    my $attr = $self->attribute($field) or return;
569    if ($attr->{inline}) {
570    my $sth = $self->db->prepare_cached(
571        sprintf(
572            q{select %s from %s where %s = ?},
573            $self->db->quote_identifier(lc($field)),
574            $self->_quote_object_table,
575            $self->_quote_key_field,
576        )
577    );
578    $sth->execute($self->id);
579    my $res = $sth->fetchrow_hashref or $self->db->rollback;
580    $sth->finish;
581    return $res->{$field};
582    } elsif ($self->_has_extended_attributes) { # else, then we mandatory have extend attr
583        $self->base->{__cache}{"_" . $self->type} ||= {};
584        my $__cache = $self->base->{__cache}{"_" . $self->type};
585        if (!(exists($__cache->{$self->id})
586            && $__cache->{$self->id}{__time} >= time - 1)) {
587        my $sth = $self->db->prepare_cached(
588            sprintf(
589                q{
590                select attr, value from %s
591                join %s on okey = ikey
592                where %s = ?
593                },
594                $self->db->quote_identifier($self->_object_table_attributes_read),
595                $self->db->quote_identifier($self->_object_table),
596                $self->db->quote_identifier($self->_key_field),
597            )
598        );
599        $sth->execute($self->id);
600        delete($__cache->{$self->id});
601        $__cache->{$self->id}{__time} = time;
602        while(my $res = $sth->fetchrow_hashref) {
603            push(@{$__cache->{$self->id}{$res->{attr}}}, $res->{value});
604        }
605        #return @values > 1 ? \@values : $values[0];
606        }
607        my $val = $__cache->{$self->id}{$field};
608        return @{$val || []} > 1 ? $val : $val->[0];
609    }
610}
611
612sub GetAttributeValue {
613    my ($self, $cfield) = @_;
614
615    my $res = $self->SUPER::GetAttributeValue($cfield) or return;
616
617    my $attribute = $self->attribute($cfield) or do {
618        $self->base->log(LA_WARN, "Unknow attribute $cfield");
619        return;
620    };
621
622    if (my $ref = $attribute->reference) {
623        my @deref;
624        foreach my $v (ref $res ? @{ $res } : $res) {
625            my $derefobj = $self->base->_derefObject($ref, $v);
626            push(@deref, $derefobj->id) if ($derefobj);
627        }
628        return scalar(@deref) > 1 ? \@deref : $deref[0];
629    } else {
630        return $res;
631    }
632}
633
634sub set_fields {
635    my ($self, %data) = @_;
636    my @updated_attributes = ();
637    my @fields;
638    my @vals;
639    my %ext;
640    if (exists($data{services})) {
641        my %old = map { $_ => 0 } $self->get_attributes('services');
642        foreach my $serv (grep { $_ } ref $data{services} ? @{ $data{services} } : $data{services}) {
643            if (!exists($old{$serv})) {
644                my $oserv = $self->base->get_object('service', $serv) or next;
645                $oserv->addAttributeValue('dependOn', $self->type . '.' . $self->id);
646            }
647            $old{$serv} = 1;
648        }
649        foreach my $serv (keys %old) {
650            if (!$old{$serv}) {
651                my $oserv = $self->base->get_object('service', $serv) or next;
652                $oserv->delAttributeValue('dependOn', $self->type . '.' . $self->id);
653            }
654        }
655        delete($data{services});
656    }
657    foreach my $field (keys %data) {
658        my $attr = $self->attribute($field);
659        my $oldval = $self->get_field($field);
660        next if (($data{$field} || '') eq ($oldval || ''));
661        if ($attr->{inline}) {
662        # TODO check fields exists !
663            push(@fields, sprintf("%s = ?", $self->db->quote_identifier($field)));
664            # undef mean unset, handling null for exported:
665            if ($field eq 'exported') {
666                push(@vals, $data{$field} ? 1 : 0);
667            } else {
668                push(@vals, $data{$field} || undef);
669            }
670            push(@updated_attributes, $field);
671        } else {
672            $ext{$field} = $data{$field};
673        }
674    }
675    if (@fields) {
676        my $sth = $self->db->prepare_cached(
677            sprintf(
678                q{update %s set %s where %s = ?},
679                $self->_quote_object_table,
680                join(', ', @fields),
681                $self->_quote_key_field,
682            )
683        );
684        $sth->execute(@vals, $self->id) or do {
685            $self->base->log(LA_ERR,
686                "Cannot update inline field for object %s, %s: %s",
687                $self->type,
688                $self->id,
689                $self->base->db->errstr);
690            return;
691        };
692    }
693   
694    if ($self->_has_extended_attributes) {
695        my $sthd = $self->db->prepare_cached(
696            sprintf(
697                q{delete from %s where okey = ? and attr = ?},
698                $self->db->quote_identifier($self->_object_table_attributes),
699            ),
700        );
701        my $sthd1 = $self->db->prepare_cached(
702            sprintf(
703                q{delete from %s where okey = ? and attr = ? and value = ?},
704                $self->db->quote_identifier($self->_object_table_attributes),
705            ),
706        );
707        my $sthx = $self->db->prepare_cached(
708            sprintf(
709                q{insert into %s (okey, attr, value) values (?,?,?)},
710                $self->db->quote_identifier($self->_object_table_attributes),
711            )
712        );
713        my $sthu = $self->db->prepare_cached(
714            sprintf(
715                q{update %s set value = ? where okey = ? and attr = ?},
716                $self->db->quote_identifier($self->_object_table_attributes),
717            )
718        );
719
720        my $okey = $self->_get_ikey($self->base, $self->id);
721        foreach my $uattr (keys %ext) {
722            my $attr = $self->attribute($uattr);
723            if ($ext{$uattr}) {
724                if ($attr->{multiple}) {
725                    my $updated = 0;
726                    my $oldvalue = $self->get_field($uattr);
727                    my %newvalues = map { $_ => 1 } (ref $ext{$uattr}
728                        ? @{$ext{$uattr}}
729                        : $ext{$uattr});
730                    foreach (grep { $_ } ref $oldvalue ? @{$oldvalue} : $oldvalue) {
731                        if(exists($newvalues{$_})) {
732                            $newvalues{$_} = 0;
733                        } else {
734                            defined($sthd1->execute($okey, $uattr, $_)) or do {
735                                $self->base->log(LA_ERR,
736                                    "Error while updating attributes on %s/%s %s: %s",
737                                    $self->type,
738                                    $self->id,
739                                    $uattr,
740                                    $self->base->db->errstr
741                                );
742                                return;
743                            };
744                            $updated++;
745                        }
746                    }
747                    foreach (grep { $newvalues{$_} } keys %newvalues) {
748                        $sthx->execute($okey, $uattr, $_) or do {
749                            $self->base->log(LA_ERR,
750                                "Error while updating attributes: %s/%s %s: %s",
751                                $self->type,
752                                $self->id,
753                                $uattr,
754                                $self->base->db->errstr
755                            );
756                            return;
757                        };
758                        $updated++;
759                    }
760                    push(@updated_attributes, $uattr) if ($updated);
761                } else {
762                    my $res = $sthu->execute($ext{$uattr}, $okey, $uattr);
763                    defined($res) or do {
764                        $self->base->log(LA_ERR,
765                            "Error while udapting attributes: %s/%s %s: %s",
766                            $self->type,
767                            $self->id,
768                            $uattr,
769                            $self->base->db->errstr
770                        );
771                        return;
772                    };
773                    if ($res == 0) {
774                        $res = $sthx->execute($okey, $uattr, $ext{$uattr});
775                        defined($res) or do {
776                            $self->base->log(LA_ERR,
777                                "Error while updating attributes: %s/%s %s: %s",
778                                $self->type,
779                                $self->id,
780                                $uattr,
781                                $self->base->db->errstr
782                            );
783                            return;
784                        };
785                    }
786                    push(@updated_attributes, $uattr);
787                }
788            } else {
789                defined($sthd->execute($okey, $uattr)) or do {
790                    $self->base->log(LA_ERR,
791                        "Error while deleting attributes: %s/%s %s: %s",
792                        $self->otype,
793                        $self->id,
794                        $uattr,
795                        $self->base->db->errstr
796                    );
797                    return;
798                };
799                push(@updated_attributes, $uattr);
800            }
801        }
802    }
803
804    delete($self->base->{__cache}{"_" . $self->type}{$self->id});
805
806    # TODO Update computed attribute for dependant object
807
808    foreach my $attr (@updated_attributes) {
809        my $oattr = $self->attribute($attr);
810        my $ref = $oattr->reference or next;
811        my $refname = sprintf('%s.%s.%s', $self->type, $self->id, $attr);
812        my $attrref = "oalias=$refname";
813
814        foreach my $alias ($self->base->search_objects($ref, $attrref)) {
815            my $oalias = $self->base->GetAlias($ref, $alias) or next;
816            $oalias->_update_aliases_cache;
817            $oalias->_update_aliases_ptr;
818        }
819    }
820
821    scalar(@updated_attributes);
822}
823
824sub PostSetAttribute {
825    my ($self) = @_;
826
827    $self->base->log(LA_DEBUG, "Running PostSetAttribute for %s/%s", $self->type, $self->id);
828
829    my %AttrToCompute;
830    foreach my $attr ($self->base->list_canonical_fields($self->type, 'r')) {
831        my $oattr = $self->base->get_attr_schema($self->type, $attr);
832        if ($oattr->{auto}) {
833            push(@{ $AttrToCompute { $oattr->{auto} } }, $attr);
834        }
835    }
836
837    my $res = 0;
838    foreach my $level (sort { $a <=> $b } keys %AttrToCompute) {
839        my %data = ();
840        foreach my $attr (@{ $AttrToCompute{ $level } }) {
841            my $source = "_$attr";
842            $data{$attr} = $self->_get_c_field($source);
843        }
844        $res += $self->set_fields(%data) || 0;
845    }
846
847    if ($res) {
848        if (my $obj = $self->ParentObject) {
849            $res += $obj->PostSetAttribute;
850        }
851    }
852
853    return $res ? $res : '0E0';
854}
855
856
857=head2 SetNoDelete($value)
858
859Set nodelete attribute to true or false
860
861=cut
862
863sub SetNoDelete {
864    my ($self, $value) = @_;
865
866    my $sthr = $self->db->prepare_cached(
867        sprintf(
868            q{update %s set nodelete = ? where %s = ?},
869            $self->db->quote_identifier($self->_object_table),
870            $self->db->quote_identifier($self->_key_field),
871        )
872    );
873
874    if (($sthr->execute($value ? 'true' : 'false', $self->id) || 0) != 1) {
875        $self->log(LA_ERR, "Erreur seting nodelete for %s/%s to %s",
876            $self->type,
877            $self->id,
878            $value,
879        );
880        return;
881    }
882
883    1;
884}
885
886=head2 find_next_numeric_id($class, $base, $field, $min, $max)
887
888An optimize version to speedup user/group creation
889
890=cut
891
892sub find_next_numeric_id {
893    my ($class, $base, $field, $min, $max) = @_;
894    $base->attribute($class->type, $field) or return;
895    $min ||=
896        $field eq 'uidNumber' ? 500 :
897        $field eq 'gidNumber' ? 500 :
898        1;
899    $max ||= 65635;
900    $base->log(LA_DEBUG, "Trying to find %s in range %d - %d",
901        $field, $min, $max);
902    my %existsid;
903    $base->temp_switch_unexported(sub {
904        foreach ($class->attributes_summary($base, $field)) {
905            $existsid{ $_ } = 1;
906        }
907    }, 1);
908    $min += 0;
909    $max += 0;
910    for(my $i = $min; $i <= $max; $i++) {
911        $existsid{$i + 0} or do {
912            $base->log(LA_DEBUG, "Next %s found: %d", $field, $i);
913            return $i;
914        };
915    }
916    return;
917}
918
919sub attributes_summary {
920    my ($class, $base, $dotAttribute) = @_;
921
922    my ($attribute, $recursiveAttr) = $dotAttribute =~ /(\w+)(?:\.(.*))?/;
923   
924    my $attr = $base->attribute($class->type, $attribute) or do {
925        $base->log(LA_WARN, "Cannot instantiate %s attribute for class %s", $attribute, $class->type);
926        return;
927    };
928    if (!$attr->readable) {
929        $base->log(LA_WARN, l('Attribute %s is not readable', $attribute));
930        return;
931    }
932    if (!$base->check_acl($class->type, $attribute, 'r')) {
933        $base->log(LA_WARN, l('Permission denied to read attribute %s', $attribute));
934        return;
935    }
936    if ($attr->{managed}) { 
937        return $class->SUPER::attributes_summary($base, $attribute);
938    }
939    my $sth = $base->db->prepare_cached(
940        $attr->{inline}
941            ? sprintf(
942                q{select %s as value from %s where internobject = false} . ($base->{wexported} ? '' : ' and "exported" = true'),
943                $base->db->quote_identifier($attr->iname),
944                $base->db->quote_identifier($class->_object_table),
945            )
946            : sprintf(
947                q{select value from %s join
948                %s on %s.ikey = %s.okey where attr = ? and internobject = false group by value} . 
949                    ($base->{wexported} ? '' : ' and "exported" = true'),
950                $base->db->quote_identifier($class->_object_table),
951                $base->db->quote_identifier($class->_object_table_attributes_read),
952                $base->db->quote_identifier($class->_object_table),
953                $base->db->quote_identifier($class->_object_table_attributes_read),
954            )
955    );
956    $sth->execute($attr->{inline} ? () : ($attr->iname));
957
958    my %values;
959    if ($recursiveAttr) {
960        my $otype = $attr->reference or do {
961            $base->log(LA_ERR, "Cannot do recursive search, no ref for attribute %s", $attribute);
962            return;
963        };
964        my %parentRes = $base->attributes_summary_by_object($otype, $recursiveAttr) or return;
965
966        while (my $res = $sth->fetchrow_hashref) {
967            defined($res->{value}) or next;
968            $values{ $parentRes{ $res->{value} } } = 1;
969        }
970    } else {
971        while (my $res = $sth->fetchrow_hashref) {
972            $values{$res->{value}} = 1 if ($res->{value});
973        }
974    }
975    sort keys %values
976}
977
978sub _filterToUser {
979    my ($self) = @_;
980
981    if (
982           !$self->get_field('autoMemberFilter')
983        && !$self->get_field('autoFromSutype')) {
984        return 0;
985    }
986    $self->base->log(LA_DEBUG,
987        "Populating group %s from autoMemberFilter/autoFromSutype attribute",
988        $self->id
989    );
990
991    my $autoin = $self->get_field('autoInclude');
992    my %include = map { $_ => 1 } grep { $_  } (ref $autoin ? @$autoin : $autoin);
993
994    my $autoex = $self->get_field('autoExclude');
995    my %exclude = map { $_ => 1 } grep { $_  } (ref $autoex ? @$autoex : $autoex);
996
997    my %users = %include;
998
999    if (my $filter = $self->get_field('autoFromSutype')) {
1000        my @suTypeFilter = map { "sutype=$_" } (ref $filter ? @{ $filter } : $filter);
1001        foreach my $group ($self->base->search_objects('group', @suTypeFilter)) {
1002            foreach ($self->base->search_objects('user', "memberOf=$group")) {
1003                $users{$_} = 1;
1004            }
1005        }
1006    }
1007
1008    if (my $filter = $self->get_field('autoMemberFilter')) {
1009        foreach ($self->base->search_objects(
1010                'user',
1011                'oalias=NULL',
1012                ref $filter ? @{ $filter } : $filter)) {
1013            $users{$_} = 1;
1014        }
1015    }
1016
1017    my @Userlist = grep { ! $exclude{ $_ } } keys %users;
1018
1019    @Userlist
1020}
1021 
1022
1023=head2 attributes_summary_by_object($base, $attribute)
1024
1025Return a hash containing object/value peer for C<$attribute>.
1026
1027=cut
1028
1029sub attributes_summary_by_object {
1030    my ($class, $base, $dotAttribute) = @_;
1031
1032    my ($attribute, $recursiveAttr) = $dotAttribute =~ /(\w+)(?:\.(.*))?/;
1033
1034    my $attr = $base->attribute($class->type, $attribute) or do {
1035        $base->log(LA_WARN, "Cannot instantiate %s attribute for class %s", $attribute, $class->type);
1036        return;
1037    };
1038    if (!$attr->readable) {
1039        $base->log(LA_WARN, l('Attribute %s is not readable', $attribute));
1040        return;
1041    }
1042    if (!$base->check_acl($class->type, $attribute, 'r')) {
1043        $base->log(LA_WARN, l('Permission denied to read attribute %s', $attribute));
1044        return;
1045    }
1046
1047    if ($attr->{managed}) {
1048        return $class->SUPER::attributes_summary_by_object($base, $attribute);
1049    }
1050    my $sth = $base->db->prepare_cached(
1051        $attr->{inline}
1052            ? sprintf(
1053                q{
1054                select name, %s as value from %s} . ($base->{wexported} ? '' : ' where "exported" = true'),
1055                $base->db->quote_identifier($attr->iname),
1056                $base->db->quote_identifier($class->_object_table),
1057            )
1058            : sprintf(
1059                q{select name, value from %s left join %s on %s.ikey = %s.okey and attr = ?} . ($base->{wexported} ? '' : ' and "exported" = true'),
1060                $base->db->quote_identifier($class->_object_table),
1061                $base->db->quote_identifier($class->_object_table_attributes_read),
1062                $base->db->quote_identifier($class->_object_table),
1063                $base->db->quote_identifier($class->_object_table_attributes_read),
1064            )
1065    );
1066    $sth->execute($attr->{inline} ? () : ($attr->iname));
1067
1068    my %values;
1069    if ($recursiveAttr) {
1070        my $otype = $attr->reference or do {
1071            $base->log(LA_ERR, "Cannot do recursive search, no ref for attribute %s", $attribute);
1072            return;
1073        };
1074        my %parentRes = $base->attributes_summary_by_object($otype, $recursiveAttr) or return;
1075
1076        while (my $res = $sth->fetchrow_hashref) {
1077            defined($res->{value}) or next;
1078            push(@{ $values{ $res->{name} } }, @{ $parentRes{ $res->{value} } || []});
1079        }
1080    } else {
1081        while (my $res = $sth->fetchrow_hashref) {
1082            defined($res->{value}) or next;
1083            push(@{ $values{ $res->{name} } }, $res->{value});
1084        }
1085    }
1086    %values
1087}
1088
1089sub search {
1090    my ($class, $base, @filter) = @_;
1091
1092    # Results groups by attr (OR filter)
1093    # foo=1 foo=1 => foo = 1 or foo = 2
1094    # foo=1 bar=1 => foo =1 and bar = 2
1095    my $results = {};
1096    my @attrsKeys = ();
1097    my $noalias = 0;
1098
1099    @filter = grep { defined($_) && $_ ne '' } @filter;
1100    if (!@filter) {
1101        my ($package, $filename, $line) = caller;
1102        $base->log(LA_DEBUG, "search() call w/o filter at %s:%d", $filename, $line);
1103        return $base->list_objects($class->type);
1104    }
1105
1106    my $FilterCounter = 0;
1107    while (my $item = shift(@filter)) {
1108        $FilterCounter++;
1109        # attr=foo => no extra white space !
1110        # \W is false, it is possible to have two char
1111        my ($OpFilter, $attr, $attrref, $operator, $val) = $item =~ /^([\!\+\-]?)(\w+)(?:\.([\.\w]+))?(?:([^\w*\\]+)(.+))?$/ or next;
1112        if (!$operator) {
1113            $operator = '~';
1114            $val = shift(@filter);
1115        }
1116
1117        if (my ($func, $args) = $val =~ /^(\w+)\((.*)\)$/) {
1118            $val = $base->QFunc( $func, $args );
1119        }
1120
1121        my $attribute = $base->attribute($class->type, $attr) or do {
1122            $base->log(LA_ERR, "Unknown attribute $attr");
1123            return;
1124        };
1125        $attribute->name eq 'oalias' and $noalias = 1;
1126        defined($val) or $val =  '';
1127
1128        $base->log(LA_DEBUG, "Search for %s %s (ref %s) %s %s", $class->type, $attr, $attrref || '(none)', $operator || '', $val);
1129
1130        # Invalid filter due to impossible value:
1131        if ($operator ne '~' && !($operator eq '=' && ($val eq 'NULL' || $val eq '*'))) {
1132            if (!$attribute->checkinputformat($val)) {
1133                $base->log(LA_ERR, "Invalid format value $val for attribute $attr");
1134                return;
1135            }
1136        }
1137
1138        $OpFilter ||= '';
1139        my $attrKey = $OpFilter . $attr;
1140
1141        if ($attrref) {
1142            my $otype = $attribute->reference or do {
1143                $base->log(LA_ERR, "Attribute $attr do not refer to another object");
1144                return;
1145            };
1146
1147            $attrKey .= '.' . $attrref;
1148            my @results = $base->search_objects($otype, "$attrref$operator$val");
1149            $base->log(LA_DEBUG, "Sub search %s res: %s", $otype, join(', ', @results));
1150
1151            if (!@results) {
1152                if ($OpFilter eq '!') {
1153                    $results->{$attrKey} ||= {};
1154                } else {
1155                    $results->{$attrKey} ||= {};
1156                }
1157                next;
1158            }
1159
1160            ($operator, $val) = ('=', join('||', @results));
1161        }
1162
1163        my @results = $class->_search_uniq_filter($base, $attr, $operator, $val);
1164
1165        $base->log(LA_DEBUG, "Search result: %s: %s", $attr, join(' ', @results));
1166
1167        # ! Add a list of object included only if
1168        # we create a result list that will not be cumulated with same attribute
1169        if ( $OpFilter eq '!') {
1170            $attrKey .= '%' . $FilterCounter;
1171        }
1172
1173        unshift(@attrsKeys, { key => $attrKey, op => $OpFilter || '' }) unless($results->{$attrKey});
1174        $results->{$attrKey} ||= {};
1175        if ($OpFilter eq '-') {
1176            # Filter result to filter from attribute result
1177            $results->{$attrKey}{$_} = -1 foreach (@results);
1178        } elsif ($OpFilter eq '+') {
1179            # Filter result to filter from attribute result
1180            $results->{$attrKey}{$_} = 2 foreach (@results);
1181        } else {
1182            $results->{$attrKey}{$_} ||=  1 foreach (@results);
1183        }
1184    }
1185
1186    # Merging filter result
1187    my @Results;
1188
1189    {
1190        my @allObjects = $base->list_objects($class->type);
1191
1192        foreach my $obj (sort @allObjects) {
1193            my $retain = 1;
1194            foreach my $attrInfo (@attrsKeys) {
1195                my $attr = $attrInfo->{key};
1196                my $v = $results->{$attr}{$obj} || 0;
1197                if ( $v < 0 ) {
1198                    $retain = -1;
1199                    last;
1200                } elsif ( $v == 0 ) {
1201                    $retain = 0 if ( $attrInfo->{op} ne '+' && $attrInfo->{op} ne '-' );
1202                } elsif ( $v >= 2 ) {
1203                    $retain = 2;
1204                    last;
1205                }
1206            }
1207            push(@Results, $obj) if ($retain > 0);
1208        }
1209    }
1210
1211    # We add to result aliases pointing to these object:
1212    if(scalar(@Results) && !$noalias) {
1213        my @alias = $class->_search_uniq_filter($base, 'oalias', '=', join('||', @Results));
1214        push(@Results, sort(@alias));
1215    }
1216
1217    return(@Results);
1218}
1219
1220sub _search_uniq_filter {
1221    my ($class, $base, $attr, $operator, $value) = @_;
1222
1223    my @attrsql;
1224    my @attrbind;
1225
1226    my $attribute = $base->attribute($class->type, $attr) or do {
1227        $base->log(LA_ERR, "Unknown attribute $attr");
1228        return;
1229    };
1230
1231    my @values = split(/([\|\&]+)/, $value);
1232
1233    $base->log(LA_DEBUG, "Uniq search for " . $class->type . "->$attr $operator (%s)", join(' ', @values));
1234
1235    return unless(@values);
1236   
1237    # We detect if we can do a very quick search:
1238    my $forRef = $operator eq '=' && scalar(@values) > 1 && ! grep { $_ eq '*' or $_ eq  '&&' or $_ eq 'NULL' } @values;
1239    if ($forRef) {
1240        # Improv perf
1241
1242        my @oaliases = ();
1243        if ($attr ne 'oaliascache' && $attribute->reference) {
1244            @oaliases = $base->search_objects($attribute->reference, "oaliascache=$value");
1245            $base->log(LA_DEBUG, "Uniq search will match oaliases: %s", join(' ', @oaliases) || '(none)');
1246        }
1247
1248        if ($attribute->{inline}) {
1249            my $sql = sprintf(
1250                q{select ikey from %s where %s = ANY (?)},
1251                $base->db->quote_identifier($class->_object_table),
1252                $base->db->quote_identifier($attribute->iname),
1253            );
1254            push(@attrsql, $sql);
1255        } else {
1256            my $sql = sprintf(
1257                q{select okey from %s where attr = ? and "value" = ANY (?) },
1258                    $base->db->quote_identifier($class->_object_table_attributes_read),
1259            );
1260            push(@attrbind, $attribute->iname);
1261            push(@attrsql, $sql);
1262        }
1263        push(@attrbind, [ @oaliases, grep { $_ ne '||' } @values ]);
1264    } else {
1265
1266    # No optimisation possible:
1267    while (defined(my $val = shift(@values))) {
1268
1269        if ($val eq '&&') {
1270            push(@attrsql, 'intersect');
1271            next;
1272        }
1273        if ($val eq '||') {
1274            push(@attrsql, 'union');
1275            next;
1276        }
1277
1278        $val = $attribute->input($val) unless($operator eq '=' && $val eq 'NULL');
1279
1280        my $sql;
1281
1282        # Specific case for unexported attribute, comming from exported value
1283        if ($attribute->iname eq 'unexported') {
1284            $sql = sprintf(
1285                q{select ikey from %s where %s},
1286                $base->db->quote_identifier($class->_object_table),
1287                $val ? q{exported='f'} : q{exported='t'}
1288            )
1289        } elsif ($attribute->iname eq 'exported') {
1290            $sql = sprintf(
1291                q{select ikey from %s where %s},
1292                $base->db->quote_identifier($class->_object_table),
1293                $val ? q{exported='t'} : q{exported='f'}
1294            )
1295        } elsif ($attribute->{inline}) {
1296            $sql = sprintf(
1297                q{select ikey from %s where %s%s %s},
1298                $base->db->quote_identifier($class->_object_table),
1299                $base->db->quote_identifier($attribute->iname),
1300                ($operator eq '~' ? '::text' : ''),
1301                $operator eq '=' && $val eq '*'
1302                    ? 'is not NULL'
1303                    : $operator eq '=' && $val eq 'NULL'
1304                    ? 'is NULL'
1305                    : $operator eq '~'
1306                        ? 'ILIKE ?'
1307                        : "$operator ?"
1308            );
1309            push(@attrbind, $operator eq '~' ? '%' . $val . '%' : $val) unless($operator eq '=' && ($val eq '*' || $val eq 'NULL'));
1310        } else {
1311            if ($operator eq '=' && $val eq 'NULL') {
1312                $sql = sprintf(q{ select ikey from %s where ikey
1313                          not in (select okey from %s where attr = ? and ("value" is NOT NULL and value != '')) },
1314                          $base->db->quote_identifier($class->_object_table),
1315                          $base->db->quote_identifier(
1316                              $class->_object_table_attributes_read
1317                          ),
1318                );
1319                push(@attrbind, $attribute->iname);
1320            } else {
1321                my @oaliases = ();
1322                if ($attr ne 'oaliascache' && $attribute->reference) {
1323                    @oaliases = $base->search_objects($attribute->reference, "oaliascache=$val");
1324                    $base->log(LA_DEBUG, "Uniq search will match oaliases for %s: %s", $val, join(' ', @oaliases) || '(none)');
1325                }
1326
1327                $sql = sprintf(
1328                    q{select okey from %s where attr = ? %s},
1329                    $base->db->quote_identifier(
1330                        $class->_object_table_attributes_read
1331                    ),
1332                    $val eq '*'
1333                        ? ''
1334                        : $operator eq '~'
1335                            ? q{and value::text ILIKE ANY(?)}
1336                            : qq{and value $operator ANY (?)}
1337
1338                );
1339                push(@attrbind, $attribute->iname);
1340                my @vals = ( $val, @oaliases );
1341                push(@attrbind, $operator eq '~'
1342                    ? [ map { '%' . $_ . '%' } @vals ]
1343                    : [ @vals ])
1344                    unless($val eq '*');
1345            }
1346        }
1347
1348        push(@attrsql, $sql);
1349    }
1350
1351    } # Perf
1352
1353    # building the query
1354    if (!$base->{wexported}) {
1355        push(@attrsql, 'intersect') if (@attrsql);
1356        push(@attrsql, sprintf(
1357                q{select ikey from %s where exported = true and internobject = false},
1358                $base->db->quote_identifier($class->_object_table)
1359            )
1360        );
1361    }
1362    my $sth = $base->db->prepare(
1363        sprintf(q{
1364            select name from %s
1365            where internobject = false
1366            %s
1367            order by name
1368            },
1369            $base->db->quote_identifier($class->_object_table),
1370            @attrsql
1371            ? "and ikey in (\n" . join(" ", @attrsql) . ")\n"
1372            : '',
1373        )
1374    );
1375    $sth->execute(@attrbind);
1376    my @results;
1377    while (my $res = $sth->fetchrow_hashref) {
1378        push(@results, $res->{name});
1379    }
1380    return(@results);
1381}
1382
1383sub _update_aliases_ptr {
1384    my ($self) = @_;
1385
1386    my $atype = $self->type;
1387    my $name  = $self->id;
1388    my $base  = $self->base;
1389
1390    foreach my $otype ($base->list_supported_objects) {
1391        foreach my $attr ($base->list_canonical_fields($otype, 'r')) {
1392            $attr =~ /^(oalias|modifiedby|createdby)$/ and next;
1393            my $attribute = $base->attribute($otype, $attr);
1394            my $ref = $attribute->reference or next;
1395
1396            if ($ref eq $atype) {
1397                $base->log(LA_DEBUG, "Searching object referencing alias %s/%s in %s->%s",
1398                    $atype, $name, $otype, $attr);
1399                foreach my $target ($base->search_objects($otype, "$attr\=$name", 'oalias=NULL')) {
1400                    $base->log(LA_DEBUG, "Update ref for object %s/%s", $otype, $target);
1401                    my $otarget = $base->get_object($otype, $target) or next;
1402                    $otarget->refreshRev;
1403                    if ($otype eq 'group' && grep { $_ eq 'dpmt' } $otarget->_get_attributes('sutype')) {
1404                        $otarget->_update_employment_manager;
1405                    }
1406                }
1407            }
1408        }
1409    }
1410}
1411
1412sub _update_aliases_cache {
1413    my ($self) = @_;
1414
1415    my $getoalias = $self->base->db->prepare(
1416        sprintf(
1417            q{ select * from %s where %s = ? },
1418            $self->base->db->quote_identifier($self->_object_table),
1419            $self->base->db->quote_identifier($self->_key_field),
1420        )
1421    );
1422    $getoalias->execute($self->id);
1423    my $res = $getoalias->fetchrow_hashref or do {
1424        $self->base->log(LA_ERR, "Cannot find alias %s / %s", $self->type, $self->id);
1425        return;
1426    };
1427    $getoalias->finish;
1428
1429    my $ref = $self->base->_derefObject($self->type, $res->{oalias});
1430    my $id = $ref ? $ref->id : undef;
1431
1432    if (($id || '') ne ($res->{oaliascache} || '')) {
1433        my $upd = $self->base->db->prepare(
1434            sprintf(
1435                q{update %s set oaliascache = ? where %s = ?},
1436                $self->base->db->quote_identifier($self->_object_table),
1437                $self->base->db->quote_identifier($self->_key_field),
1438            )
1439        );
1440        $self->base->log(LA_DEBUG, "Updating Cache for alias %s => %s", $self->id, $id || '(none)');
1441        return $upd->execute($id, $self->id);
1442    }
1443}
1444
1445sub ReportChange {
1446    my ($self, $changetype, $message, @args) = @_;
1447
1448    $self->base->ReportChange(
1449        $self->type,
1450        $self->id,
1451        $self->Iid,
1452        $changetype, $message, @args
1453    )
1454}
1455
1456
14571;
1458
1459__END__
1460
1461=head1 SEE ALSO
1462
1463L<LATMOS::Accounts::Bases::Sql>
1464
1465L<LATMOS::Accounts::Bases::Objects>
1466
1467=head1 AUTHOR
1468
1469Olivier Thauvin, E<lt>olivier.thauvin@latmos.ipsl.frE<gt>
1470
1471=head1 COPYRIGHT AND LICENSE
1472
1473Copyright (C) 2008, 2009 CNRS SA/CETP/LATMOS
1474
1475This library is free software; you can redistribute it and/or modify
1476it under the same terms as Perl itself, either Perl version 5.10.0 or,
1477at your option, any later version of Perl 5 you may have available.
1478
1479
1480=cut
Note: See TracBrowser for help on using the repository browser.