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

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

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