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

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

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