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

Last change on this file since 2045 was 2019, checked in by nanardon, 7 years ago

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