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

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

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