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

Last change on this file since 2290 was 2290, checked in by nanardon, 5 years ago

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