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

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

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