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

Last change on this file since 1806 was 1806, checked in by nanardon, 8 years ago

Search() w/o filter eq list_objects
  • Property svn:keywords set to Id Rev
File size: 35.0 KB
Line 
1package LATMOS::Accounts::Bases::Sql::objects;
2
3use 5.010000;
4use strict;
5use warnings;
6
7use base qw(LATMOS::Accounts::Bases::Objects);
8use LATMOS::Accounts::Log;
9use Crypt::RSA;
10use Crypt::RSA::Key::Public::SSH;
11use DateTime;
12use LATMOS::Accounts::I18N;
13
14our $VERSION = (q$Rev$ =~ /^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 list {
25    my ($class, $base) = @_;
26
27    my $sth = $base->db->prepare_cached(
28        sprintf(
29            q{select %s as k from %s %s order by %s},
30            $base->db->quote_identifier($class->_key_field),
31            $base->db->quote_identifier($class->_object_table),
32            ($base->{wexported} ? '' : 'where exported = true'),
33            $base->db->quote_identifier($class->_key_field),
34        )
35    );
36    $sth->execute;
37    my @keys;
38    while(my $res = $sth->fetchrow_hashref) {
39        push(@keys, $res->{k});
40    }
41    @keys
42}
43
44sub list_from_rev {
45    my ($class, $base, $rev) = @_;
46    my $sth = $base->db->prepare_cached(
47        sprintf(
48            q{select %s as k from %s where rev > ? %s order by %s},
49            $base->db->quote_identifier($class->_key_field),
50            $base->db->quote_identifier($class->_object_table),
51            ($base->{wexported} ? '' : 'and exported = true'),
52            $base->db->quote_identifier($class->_key_field),
53        )
54    );
55    $sth->execute($rev);
56    my @keys;
57    while(my $res = $sth->fetchrow_hashref) {
58        push(@keys, $res->{k});
59    }
60    @keys
61}
62
63sub _has_extended_attributes { 0 }
64
65sub _get_attr_schema {
66    my ($class, $base, $info) = @_;
67    $info ||= {};
68    if (!$base->{__cache}{$class->_object_table}{inline}) {
69        $base->{__cache}{$class->_object_table}{inline} = [];
70        my $sth = $base->db->prepare(
71            q{SELECT column_name FROM information_schema.columns
72              WHERE table_name = ?}
73        );
74        $sth->execute($class->_object_table);
75        while (my $res = $sth->fetchrow_hashref) {
76            push(@{$base->{__cache}{$class->_object_table}{inline}},
77                $res->{column_name});
78        }
79    }
80    foreach (@{$base->{__cache}{$class->_object_table}{inline}}) {
81        $info->{$_}{inline} = 1;
82        if (m/^(rev|date|create|ikey)$/) {
83            $info->{$_}{ro} = 1
84        }
85    }
86
87    # Common to all object attribute:
88    my %commons = (
89        name      => {
90            inline => 1,
91            ro => 1,
92            label => l('Name'),
93        },
94        create    => {
95            inline => 1,
96            ro => 1,
97            label => l('Created'),
98        },
99        date      => {
100            inline => 1,
101            ro => 1,
102            label => l('Last modified'),
103        },
104        exported   =>   { inline => 1, formtype => 'CHECKBOX', hide => 1, monitored => 1 },
105        unexported =>   {
106            inline => 1,
107            managed => 1,
108            formtype => 'CHECKBOX',
109            get => sub {
110                my ($self) = @_;
111                return $self->object->get_field('exported') ? undef : 1;
112            },
113            set => sub {
114                my ($self, $data) = @_;
115                $self->object->_set_c_fields('exported', $data ? 0 : 1);
116            },
117            label => l('Hidden'),
118        },
119        services   =>   {
120            managed => 1,
121            multiple => 1,
122            reference => 'service',
123            label => l('Service'),
124        },
125        modifiedby =>   {
126            inline  => 1,
127            reference => 'user',
128            ro => 1,
129            label => l('Modified by'),
130        },
131        createdby => {
132            inline  => 1,
133            reference => 'user',
134            ro => 1,
135            label => l('Created by'),
136        },
137    );
138
139    # Merging / overriding with common to all object attributes properties
140    foreach my $attr (keys %commons) {
141        foreach my $var (keys %{ $commons{$attr} }) {
142            $info->{$attr}{$var} = $commons{$attr}{$var};
143        }
144    }
145
146    # TODO kill this code: useless since everything is declared in perl code
147    if ($class->_has_extended_attributes) {
148        if (!$base->{__cache}{$class->_object_table}{extend}) {
149            $base->{__cache}{$class->_object_table}{extend} = [];
150            my $sth = $base->db->prepare_cached(
151                sprintf(
152                    q{select canonical from %s order by canonical},
153                    $base->db->quote_identifier($class->_attributes_table),
154                )
155            );
156            $sth->execute;
157            while (my $res = $sth->fetchrow_hashref) {
158                push(@{$base->{__cache}{$class->_object_table}{extend}},
159                        $res->{canonical});
160            }
161        }
162        foreach (@{$base->{__cache}{$class->_object_table}{extend}}) {
163            $base->log(LA_DEBUG, 'Attribute %s for %s not declared in code', $_, $class->type) if(!exists($info->{$_}));
164            $info->{$_} ||= {};
165        }
166    }
167
168    $info
169}
170
171# Everything managed by the perl code
172
173sub _managed_fields {
174    my ($class, $for, $base) = @_;
175    return();
176}
177
178sub new {
179    my ($class, $base, $id) = @_;
180
181    my $__cache = $base->{__cache}{"_" . $class->type};
182
183    if (!(exists($__cache->{$id})
184        && $__cache->{$id}{__time} >= time - 1)) {
185
186        my $sth = $base->db->prepare_cached(
187            sprintf(q{select 1 from %s where %s = ? %s},
188                $base->db->quote_identifier($class->_object_table),
189                $base->db->quote_identifier($class->_key_field),
190                ($base->{wexported} ? '' : 'and exported = true'),
191            ),
192        );
193        my $count = $sth->execute($id);
194        $sth->finish;
195        ($count || 0) == 1 or return;
196    }
197    $class->SUPER::new($base, $id);
198}
199
200sub Iid { $_[0]->_get_ikey }
201
202sub _get_ikey {
203    my ($class, $base, $id) = @_;
204    $base ||= $class->base;
205    $id ||= $class->id;
206    my $sth = $base->db->prepare_cached(
207        sprintf(
208            q{select ikey from %s where %s = ?},
209            $base->db->quote_identifier($class->_object_table),
210            $base->db->quote_identifier($class->_key_field),
211        )
212    );
213    $sth->execute($id);
214    my $res = $sth->fetchrow_hashref;
215    $sth->finish;
216    $res->{ikey}
217}
218
219sub _create {
220    my ($class, $base, $id, %data) = @_;
221
222    # splitting inline from extended
223    my (%first, %second);
224    # Ensure object is exported if not specified
225    $data{exported} = 1 if (!exists($data{exported}));
226    if (exists $data{unexported}) {
227        $data{exported} = $data{unexported} ? 0 : 1;
228        delete $data{unexported}
229    }
230    foreach (keys %data) {
231        my $attr = $base->attribute($class->type, $_) or next;
232        $_ =~ /^exported$/ and $data{$_} = $data{$_} ? 1 : 0;
233        my $formatted = ref($data{$_})
234            ? [ map { $attr->input($_) } @{ $data{$_} } ]
235            : $attr->input($data{$_});
236        if ($attr->{inline} && ! $attr->{delayed}) {
237            $first{$_} = $formatted;
238        } else {
239            $second{$_} = $formatted if(defined($formatted));
240        }
241    }
242    $first{$class->_key_field} = $id;
243    $first{createdby} =  $base->user || '@Console';
244    $first{modifiedby} = $base->user || '@Console';
245
246    my $lastid;
247    {
248        my $sthnextval = $base->db->prepare_cached("select nextval('ikey_seq') as c");
249        $sthnextval->execute;
250        $lastid = $sthnextval->fetchrow_hashref()->{c};
251        $first{ikey} = $lastid;
252        $sthnextval->finish;
253    }
254
255    my $sth = $base->db->prepare(
256        sprintf(
257            q{insert into %s (%s) values (%s)},
258            $base->db->quote_identifier($class->_object_table),
259            join(', ', map { $base->db->quote_identifier($_) } sort keys %first),
260            join(',', qw(?) x scalar(keys %first)),
261        )
262    );
263    $sth->execute(map { defined($first{$_}) ? $first{$_} : undef } sort keys %first) or return;
264
265    my $sthid = $base->db->prepare_cached(
266        sprintf(q{select %s as k from %s where ikey = ?},
267            $base->db->quote_identifier($class->_key_field),
268            $base->db->quote_identifier($class->_object_table),
269        )
270    );
271    $sthid->execute($lastid);
272    my $res = $sthid->fetchrow_hashref();
273    $sthid->finish;
274    $res or do {
275        $base->log(LA_DEBUG, 'Cannot retrieve SQL row from freshly create object %s/%s', $class->type, $id);
276        return;
277    };
278
279    my $obj = $class->new($base, $res->{k}) or return;
280    if (keys %second) {
281        $obj->_set_c_fields(%second) or do {
282            $base->log(LA_DEBUG, 'Cannot set atttributes to freshly create object %s/%s', $class->type, $id);
283            return;
284        };
285    }
286
287    return $res->{k};
288}
289
290sub _delete {
291    my ($class, $base, $id) = @_;
292
293    my $__cache = $base->{__cache}{"_" . $class->type};
294
295    my $obj = $base->get_object($class->type, $id)
296        or return;
297
298    my $sthd = $base->db->prepare_cached(
299        sprintf(
300            q{delete from %s where %s = ?},
301            $base->db->quote_identifier($class->_object_table),
302            $base->db->quote_identifier($class->_key_field),
303        )
304    );
305    my $res = $sthd->execute($id);
306    if ($res) {
307        delete($__cache->{$id});
308    }
309
310    $res
311}
312
313sub _rename {
314    my ($class, $base, $id, $newid) = @_;
315
316    my $sthr = $base->db->prepare_cached(
317        sprintf(
318            q{update %s set %s = ? where %s = ?},
319            $base->db->quote_identifier($class->_object_table),
320            $base->db->quote_identifier($class->_key_field),
321            $base->db->quote_identifier($class->_key_field),
322        )
323    );
324
325    if (($sthr->execute($newid, $id) || 0) != 1) {
326        $base->log(LA_ERR, "Erreur renaming %s %s to %s",
327            $class->type,
328            $id, $newid,
329        );
330        return;
331    }
332
333    1;
334}
335
336=head2 db
337
338Return reference to L<DBI> object.
339
340=cut
341
342sub db {
343    return $_[0]->base->db;
344}
345
346sub _quote_object_table {
347    my ($self) = @_;
348    my $table = $self->_object_table or return;
349    $self->db->quote_identifier($table);
350}
351sub _quote_key_field {
352    my ($self) = @_;
353    my $key_field = $self->_key_field or return;
354    $self->db->quote_identifier($key_field);
355}
356
357sub get_field {
358    my ($self, $field) = @_;
359    if ($field eq 'services') {
360        my @services;
361        my $sth = $self->db->prepare_cached(
362            q{ select name from service join service_attributes
363               on okey = ikey
364               where service_attributes.attr = 'dependOn' and value = ?
365               });
366        $sth->execute($self->type . '.' . $self->id);
367        while(my $res = $sth->fetchrow_hashref) {
368            push(@services, $res->{name});
369        }
370        return \@services; 
371    }
372    my $attr = $self->attribute($field) or return;
373    if ($attr->{inline}) {
374    my $sth = $self->db->prepare_cached(
375        sprintf(
376            q{select %s from %s where %s = ?},
377            $self->db->quote_identifier(lc($field)),
378            $self->_quote_object_table,
379            $self->_quote_key_field,
380        )
381    );
382    $sth->execute($self->id);
383    my $res = $sth->fetchrow_hashref or $self->db->rollback;
384    $sth->finish;
385    return $res->{$field};
386    } elsif ($self->_has_extended_attributes) { # else, then we mandatory have extend attr
387        $self->base->{__cache}{"_" . $self->type} ||= {};
388        my $__cache = $self->base->{__cache}{"_" . $self->type};
389        if (!(exists($__cache->{$self->id})
390            && $__cache->{$self->id}{__time} >= time - 1)) {
391        my $sth = $self->db->prepare_cached(
392            sprintf(
393                q{
394                select attr, value from %s
395                join %s on okey = ikey
396                where %s = ?
397                },
398                $self->db->quote_identifier($self->_object_table. '_attributes'),
399                $self->db->quote_identifier($self->_object_table),
400                $self->db->quote_identifier($self->_key_field),
401            )
402        );
403        $sth->execute($self->id);
404        delete($__cache->{$self->id});
405        $__cache->{$self->id}{__time} = time;
406        while(my $res = $sth->fetchrow_hashref) {
407            push(@{$__cache->{$self->id}{$res->{attr}}}, $res->{value});
408        }
409        #return @values > 1 ? \@values : $values[0];
410        }
411        my $val = $__cache->{$self->id}{$field};
412        return @{$val || []} > 1 ? $val : $val->[0];
413    }
414}
415
416sub set_fields {
417    my ($self, %data) = @_;
418    my @updated_attributes = ();
419    my @fields;
420    my @vals;
421    my %ext;
422    if (exists($data{services})) {
423        my %old = map { $_ => 0 } $self->get_attributes('services');
424        foreach my $serv (grep { $_ } ref $data{services} ? @{ $data{services} } : $data{services}) {
425            if (!exists($old{$serv})) {
426                my $oserv = $self->base->get_object('service', $serv) or next;
427                $oserv->addAttributeValue('dependOn', $self->type . '.' . $self->id);
428            }
429            $old{$serv} = 1;
430        }
431        foreach my $serv (keys %old) {
432            if (!$old{$serv}) {
433                my $oserv = $self->base->get_object('service', $serv) or next;
434                $oserv->delAttributeValue('dependOn', $self->type . '.' . $self->id);
435            }
436        }
437        delete($data{services});
438    }
439    if (exists($data{services})) {
440        my %old = map { $_ => 0 } $self->get_attributes('services');
441        foreach my $serv (grep { $_ } ref $data{services} ? @{ $data{services} } : $data{services}) {
442            if (!exists($old{$serv})) {
443                my $oserv = $self->base->get_object('service', $serv) or next;
444                $oserv->addAttributeValue('dependOn', $self->type . '.' . $self->id);
445            }
446            $old{$serv} = 1;
447        }
448        foreach my $serv (keys %old) {
449            if (!$old{$serv}) {
450                my $oserv = $self->base->get_object('service', $serv) or next;
451                $oserv->delAttributeValue('dependOn', $self->type . '.' . $self->id);
452            }
453        }
454        delete($data{services});
455    }
456    foreach my $field (keys %data) {
457        my $attr = $self->attribute($field);
458        my $oldval = $self->get_field($field);
459        next if (($data{$field} || '') eq ($oldval || ''));
460        if ($attr->{inline}) {
461        # TODO check fields exists !
462            push(@fields, sprintf("%s = ?", $self->db->quote_identifier($field)));
463            # undef mean unset, handling null for exported:
464            if ($field eq 'exported') {
465                push(@vals, $data{$field} ? 1 : 0);
466            } else {
467                push(@vals, $data{$field} || undef);
468            }
469            push(@updated_attributes, $field);
470        } else {
471            $ext{$field} = $data{$field};
472        }
473    }
474    if (@fields) {
475        my $sth = $self->db->prepare_cached(
476            sprintf(
477                q{update %s set %s where %s = ?},
478                $self->_quote_object_table,
479                join(', ', @fields),
480                $self->_quote_key_field,
481            )
482        );
483        $sth->execute(@vals, $self->id) or do {
484            $self->base->log(LA_ERR,
485                "Cannot update inline field for object %s, %s: %s",
486                $self->type,
487                $self->id,
488                $self->base->db->errstr);
489            return;
490        };
491    }
492   
493    if ($self->_has_extended_attributes) {
494        my $sthd = $self->db->prepare_cached(
495            sprintf(
496                q{delete from %s where okey = ? and attr = ?},
497                $self->db->quote_identifier($self->_object_table. '_attributes'),
498            ),
499        );
500        my $sthd1 = $self->db->prepare_cached(
501            sprintf(
502                q{delete from %s where okey = ? and attr = ? and value = ?},
503                $self->db->quote_identifier($self->_object_table. '_attributes'),
504            ),
505        );
506        my $sthx = $self->db->prepare_cached(
507            sprintf(
508                q{insert into %s (okey, attr, value) values (?,?,?)},
509                $self->db->quote_identifier($self->_object_table. '_attributes'),
510            )
511        );
512        my $sthu = $self->db->prepare_cached(
513            sprintf(
514                q{update %s set value = ? where okey = ? and attr = ?},
515                $self->db->quote_identifier($self->_object_table. '_attributes'),
516            )
517        );
518
519        my $okey = $self->_get_ikey($self->base, $self->id);
520        foreach my $uattr (keys %ext) {
521            my $attr = $self->attribute($uattr);
522            if ($ext{$uattr}) {
523                if ($attr->{multiple}) {
524                    my $updated = 0;
525                    my $oldvalue = $self->get_field($uattr);
526                    my %newvalues = map { $_ => 1 } (ref $ext{$uattr}
527                        ? @{$ext{$uattr}}
528                        : $ext{$uattr});
529                    foreach (grep { $_ } ref $oldvalue ? @{$oldvalue} : $oldvalue) {
530                        if(exists($newvalues{$_})) {
531                            $newvalues{$_} = 0;
532                        } else {
533                            defined($sthd1->execute($okey, $uattr, $_)) or do {
534                                $self->base->log(LA_ERR,
535                                    "Error while updating attributes on %s/%s %s: %s",
536                                    $self->type,
537                                    $self->id,
538                                    $uattr,
539                                    $self->base->db->errstr
540                                );
541                                return;
542                            };
543                            $updated++;
544                        }
545                    }
546                    foreach (grep { $newvalues{$_} } keys %newvalues) {
547                        $sthx->execute($okey, $uattr, $_) or do {
548                            $self->base->log(LA_ERR,
549                                "Error while updating attributes: %s/%s %s: %s",
550                                $self->type,
551                                $self->id,
552                                $uattr,
553                                $self->base->db->errstr
554                            );
555                            return;
556                        };
557                        $updated++;
558                    }
559                    push(@updated_attributes, $uattr) if ($updated);
560                } else {
561                    my $res = $sthu->execute($ext{$uattr}, $okey, $uattr);
562                    defined($res) or do {
563                        $self->base->log(LA_ERR,
564                            "Error while udapting attributes: %s/%s %s: %s",
565                            $self->type,
566                            $self->id,
567                            $uattr,
568                            $self->base->db->errstr
569                        );
570                        return;
571                    };
572                    if ($res == 0) {
573                        $res = $sthx->execute($okey, $uattr, $ext{$uattr});
574                        defined($res) or do {
575                            $self->base->log(LA_ERR,
576                                "Error while updating attributes: %s/%s %s: %s",
577                                $self->type,
578                                $self->id,
579                                $uattr,
580                                $self->base->db->errstr
581                            );
582                            return;
583                        };
584                    }
585                    push(@updated_attributes, $uattr);
586                }
587            } else {
588                defined($sthd->execute($okey, $uattr)) or do {
589                    $self->base->log(LA_ERR,
590                        "Error while deleting attributes: %s/%s %s: %s",
591                        $self->otype,
592                        $self->id,
593                        $uattr,
594                        $self->base->db->errstr
595                    );
596                    return;
597                };
598                push(@updated_attributes, $uattr);
599            }
600        }
601    }
602
603    delete($self->base->{__cache}{"_" . $self->type}{$self->id});
604    scalar(@updated_attributes);
605}
606
607=head2 find_next_numeric_id($class, $base, $field, $min, $max)
608
609An optimize version to speedup user/group creation
610
611=cut
612
613sub find_next_numeric_id {
614    my ($class, $base, $field, $min, $max) = @_;
615    $base->attribute($class->type, $field) or return;
616    $min ||=
617        $field eq 'uidNumber' ? 500 :
618        $field eq 'gidNumber' ? 500 :
619        1;
620    $max ||= 65635;
621    $base->log(LA_DEBUG, "Trying to find %s in range %d - %d",
622        $field, $min, $max);
623    my %existsid;
624    $base->temp_switch_unexported(sub {
625        foreach ($class->attributes_summary($base, $field)) {
626            $existsid{ $_ } = 1;
627        }
628    }, 1);
629    $min += 0;
630    $max += 0;
631    for(my $i = $min; $i <= $max; $i++) {
632        $existsid{$i + 0} or do {
633            $base->log(LA_DEBUG, "Next %s found: %d", $field, $i);
634            return $i;
635        };
636    }
637    return;
638}
639
640sub attributes_summary {
641    my ($class, $base, $dotAttribute) = @_;
642
643    my ($attribute, $recursiveAttr) = $dotAttribute =~ /(\w+)(?:\.(.*))?/;
644   
645    my $attr = $base->attribute($class->type, $attribute) or do {
646        $base->log(LA_ERR, "Cannot instantiate %s attribute", $attribute);
647        return;
648    };
649    if (!$attr->readable) {
650        $base->log(LA_WARN, l('Attribute %s is not readable', $attribute));
651        return;
652    }
653    if (!$base->check_acl($class->type, $attribute, 'r')) {
654        $base->log(LA_WARN, l('Permission denied to read attribute %s', $attribute));
655        return;
656    }
657    if ($attr->{managed}) { 
658        return $class->SUPER::attributes_summary($base, $attribute);
659    }
660    my $sth = $base->db->prepare_cached(
661        $attr->{inline}
662            ? sprintf(
663                q{select %s as value from %s} . ($base->{wexported} ? '' : ' and "exported" = true'),
664                $base->db->quote_identifier($attr->iname),
665                $base->db->quote_identifier($class->_object_table),
666            )
667            : sprintf(
668                q{select value from %s join
669                %s on %s.ikey = %s.okey where attr = ? group by value} . ($base->{wexported} ? '' : ' and "exported" = true'),
670                $base->db->quote_identifier($class->_object_table),
671                $base->db->quote_identifier($class->_object_table .
672                    '_attributes'),
673                $base->db->quote_identifier($class->_object_table),
674                $base->db->quote_identifier($class->_object_table .
675                    '_attributes'),
676            )
677    );
678    $sth->execute($attr->{inline} ? () : ($attr->iname));
679
680    my %values;
681    if ($recursiveAttr) {
682        my $otype = $attr->reference or do {
683            $base->log(LA_ERR, "Cannot do recursive search, no ref for attribute %s", $attribute);
684            return;
685        };
686        my %parentRes = $base->attributes_summary_by_object($otype, $recursiveAttr) or return;
687
688        while (my $res = $sth->fetchrow_hashref) {
689            defined($res->{value}) or next;
690            $values{ $parentRes{ $res->{value} } } = 1;
691        }
692    } else {
693        while (my $res = $sth->fetchrow_hashref) {
694            $values{$res->{value}} = 1 if ($res->{value});
695        }
696    }
697    sort keys %values
698}
699
700=head2 attributes_summary_by_object($base, $attribute)
701
702Return a hash containing object/value peer for C<$attribute>.
703
704=cut
705
706sub attributes_summary_by_object {
707    my ($class, $base, $dotAttribute) = @_;
708
709    my ($attribute, $recursiveAttr) = $dotAttribute =~ /(\w+)(?:\.(.*))?/;
710
711    my $attr = $base->attribute($class->type, $attribute) or do {
712        $base->log(LA_ERR, "Cannot instantiate %s attribute", $attribute);
713        return;
714    };
715    if (!$attr->readable) {
716        $base->log(LA_WARN, l('Attribute %s is not readable', $attribute));
717        return;
718    }
719    if (!$base->check_acl($class->type, $attribute, 'r')) {
720        $base->log(LA_WARN, l('Permission denied to read attribute %s', $attribute));
721        return;
722    }
723
724    if ($attr->{managed}) {
725        return $class->SUPER::attributes_summary_by_object($base, $attribute);
726    }
727    my $sth = $base->db->prepare_cached(
728        $attr->{inline}
729            ? sprintf(
730                q{
731                select name, %s as value from %s} . ($base->{wexported} ? '' : ' where "exported" = true'),
732                $base->db->quote_identifier($attr->iname),
733                $base->db->quote_identifier($class->_object_table),
734            )
735            : sprintf(
736                q{select name, value from %s left join %s on %s.ikey = %s.okey and attr = ?} . ($base->{wexported} ? '' : ' and "exported" = true'),
737                $base->db->quote_identifier($class->_object_table),
738                $base->db->quote_identifier($class->_object_table .
739                    '_attributes'),
740                $base->db->quote_identifier($class->_object_table),
741                $base->db->quote_identifier($class->_object_table .
742                    '_attributes'),
743            )
744    );
745    $sth->execute($attr->{inline} ? () : ($attr->iname));
746
747    my %values;
748    if ($recursiveAttr) {
749        my $otype = $attr->reference or do {
750            $base->log(LA_ERR, "Cannot do recursive search, no ref for attribute %s", $attribute);
751            return;
752        };
753        my %parentRes = $base->attributes_summary_by_object($otype, $recursiveAttr) or return;
754
755        while (my $res = $sth->fetchrow_hashref) {
756            defined($res->{value}) or next;
757            push(@{ $values{ $res->{name} } }, @{ $parentRes{ $res->{value} } || []});
758        }
759    } else {
760        while (my $res = $sth->fetchrow_hashref) {
761            defined($res->{value}) or next;
762            push(@{ $values{ $res->{name} } }, $res->{value});
763        }
764    }
765    %values
766}
767
768sub search {
769    my ($class, $base, @filter) = @_;
770
771    # Results groups by attr (OR filter)
772    # foo=1 foo=1 => foo = 1 or foo = 2
773    # foo=1 bar=1 => foo =1 and bar = 2
774    my $results = {};
775
776    if (!@filter) {
777        my ($package, $filename, $line) = caller;
778        $base->log(LA_DEBUG, "search() call w/o filter at %s:%d", $filename, $line);
779        return $base->list_objects($class->type);
780    }
781
782    while (my $item = shift(@filter)) {
783        # attr=foo => no extra white space !
784        # \W is false, it is possible to have two char
785        my ($attr, $attrref, $operator, $val) = $item =~ /^(\w+)(?:\.([\.\w]+))?(?:([^\w*]+)(.+))?$/ or next;
786        if (!$operator) {
787            $operator = '~';
788            $val = shift(@filter);
789        }
790        my $attribute = $base->attribute($class->type, $attr) or do {
791            $base->log(LA_ERR, "Unknown attribute $attr");
792            return;
793        };
794        defined($val) or $val =  '';
795
796        $base->log(LA_DEBUG, "Search for %s %s (ref %s) %s %s", $class->type, $attr, $attrref || '(none)', $operator || '', $val);
797
798        # Invalid filter due to impossible value:
799        if ($operator ne '~' && !($operator eq '=' && $val eq 'NULL')) {
800            if (!$attribute->checkinputformat($val)) {
801                $base->log(LA_ERR, "Invalid format value $val for attribute $attr");
802                return;
803            }
804        }
805
806        if ($attrref) {
807            my $otype = $attribute->reference or do {
808                $base->log(LA_ERR, "Attribute $attr do not refer to another object");
809                return;
810            };
811
812            my @results = $base->search_objects($otype, "$attrref$operator$val");
813            $base->log(LA_DEBUG, "Sub search %s res: %s", $otype, join(', ', @results));
814
815            if (!@results) {
816                $results->{$attr} ||= {};
817                next;
818            }
819
820            ($operator, $val) = ('=', join('||', @results));
821        }
822
823        my @results = $class->_search_uniq_filter($base, $attr, $operator, $val);
824
825        $results->{$attr} ||= {};
826        $results->{$attr}{$_} = 1 foreach (@results) 
827    }
828
829    # Merging filter result
830    my ($attrRef) = keys %{ $results } or return;
831
832    my %mresults = %{ $results->{$attrRef} };
833
834    foreach my $attr (keys %{ $results }) {
835        my @values = keys %mresults;
836        foreach (@values) {
837            $results->{$attr}{$_} or delete($mresults{$_});
838        }
839    }
840
841    return(sort keys %mresults);
842}
843
844
845sub _search_uniq_filter {
846    my ($class, $base, $attr, $operator, $value) = @_;
847
848    my @attrsql;
849    my @attrbind;
850
851    my $attribute = $base->attribute($class->type, $attr) or do {
852        $base->log(LA_ERR, "Unknown attribute $attr");
853        return;
854    };
855
856    my @values = split(/([\|\&]+)/, $value);
857   
858    # We detect if we can do a very quick search:
859    my $forRef = $operator eq '=' && scalar(@values) > 1 && ! grep { $_ eq '*' or $_ eq  '&&' or $_ eq 'NULL' } @values;
860    if ($forRef) {
861        # Improv perf
862        if ($attribute->{inline}) {
863            my $sql = sprintf(
864                q{select ikey from %s where %s = ANY (?)},
865                $base->db->quote_identifier($class->_object_table),
866                $base->db->quote_identifier($attribute->iname),
867            );
868            push(@attrsql, $sql);
869        } else {
870            my $sql = sprintf(
871                q{select okey from %s where attr = ? and "value" = ANY (?) },
872                    $base->db->quote_identifier($class->_object_table . '_attributes'),
873            );
874            push(@attrbind, $attribute->iname);
875            push(@attrsql, $sql);
876        }
877        push(@attrbind, [ grep { $_ ne '||' } @values ]);
878    } else {
879
880    # No optimisation possible:
881    while (defined(my $val = shift(@values))) {
882
883        if ($val eq '&&') {
884            push(@attrsql, 'intersect');
885            next;
886        }
887        if ($val eq '||') {
888            push(@attrsql, 'union');
889            next;
890        }
891
892        $val = $attribute->input($val) unless($operator eq '=' && $val eq 'NULL');
893
894        my $sql;
895
896        # Specific case for unexported attribute, comming from exported value
897        if ($attribute->iname eq 'unexported') {
898            $sql = sprintf(
899                q{select ikey from %s where %s},
900                $base->db->quote_identifier($class->_object_table),
901                $val ? q{exported='f'} : q{exported='t'}
902            )
903        } elsif ($attribute->{inline}) {
904            $sql = sprintf(
905                q{select ikey from %s where %s%s %s},
906                $base->db->quote_identifier($class->_object_table),
907                $base->db->quote_identifier($attribute->iname),
908                ($operator eq '~' ? '::text' : ''),
909                $operator eq '=' && $val eq '*'
910                    ? 'is not NULL'
911                    : $operator eq '=' && $val eq 'NULL'
912                    ? 'is NULL'
913                    : $operator eq '~'
914                        ? 'ILIKE ?'
915                        : "$operator ?"
916            );
917            push(@attrbind, $operator eq '~' ? '%' . $val . '%' : $val) unless($operator eq '=' && ($val eq '*' || $val eq 'NULL'));
918        } else {
919            if ($operator eq '=' && $val eq 'NULL') {
920                $sql = sprintf(q{ select ikey from %s where ikey
921                          not in (select okey from %s where attr = ? and ("value" is NOT NULL and value != '')) },
922                          $base->db->quote_identifier($class->_object_table),
923                          $base->db->quote_identifier(
924                              $class->_object_table . '_attributes'
925                          ),
926                );
927                push(@attrbind, $attribute->iname);
928            } else {
929                $sql = sprintf(
930                    q{select okey from %s where attr = ? %s},
931                    $base->db->quote_identifier(
932                        $class->_object_table . '_attributes'
933                    ),
934                    $val eq '*'
935                        ? ''
936                        : $operator eq '~'
937                            ? q{and value::text ILIKE ?}
938                            : qq{and value $operator ?}
939
940                );
941                push(@attrbind, $attribute->iname);
942                push(@attrbind, $operator eq '~' ? '%' . $val . '%' : $val) unless($val eq '*');
943            }
944        }
945
946        push(@attrsql, $sql);
947    }
948
949    } # Perf
950
951    # building the query
952    if (!$base->{wexported}) {
953        push(@attrsql, 'intersect', sprintf(
954                q{select ikey from %s where exported = true},
955                $base->db->quote_identifier($class->_object_table)
956            )
957        );
958    }
959    my $sth = $base->db->prepare(
960        sprintf(q{
961            select name from %s
962            %s
963            order by name
964            },
965            $base->db->quote_identifier($class->_object_table),
966            @attrsql
967            ? "where ikey in (\n" . join(" ", @attrsql) . ")\n"
968            : '',
969        )
970    );
971    $sth->execute(@attrbind);
972    my @results;
973    while (my $res = $sth->fetchrow_hashref) {
974        push(@results, $res->{name});
975    }
976    return(@results);
977}
978
979=head2 register_attribute
980
981Register attribute into base
982
983=cut
984
985sub register_attribute {
986    my ($class, $base, $attribute, $comment) = @_;
987
988    $class->is_registered_attribute($base, $attribute) and do {
989        $base->log(LA_ERR, "The attribute $attribute already exists");
990        return;
991    };
992    my $sth = $base->db->prepare(
993        sprintf(q{
994            insert into %s (canonical, description)
995            values (?,?)
996            }, $class->_attributes_table)
997    );
998    my $res = $sth->execute($attribute, $comment);
999}
1000
1001=head2 is_registered_attribute ($base, $attribute)
1002
1003Return true is attribute is registered into base
1004
1005=cut
1006
1007sub is_registered_attribute {
1008    my ($class, $base, $attribute) = @_;
1009
1010    my $sth = $base->db->prepare(
1011        sprintf(q{
1012            select 1 from %s where canonical = ?
1013            }, $class->_attributes_table
1014        )
1015    );
1016    $sth->execute($attribute);
1017    my $res = $sth->fetchrow_hashref;
1018    return $res ? 1 : 0;
1019}
1020
1021=head2 get_attribute_comment $base, $attribute)
1022
1023Return comment for C<$attribute>
1024
1025=cut
1026
1027# TODO: get_attribute_comment($attr, $base) { $base ||= $self->base ...
1028
1029sub get_attribute_comment {
1030    my ($class, $base, $attribute) = @_;
1031    $base->attribute($class->type, $attribute) or do {
1032        $base->log(LA_ERR, "The attribute $attribute does not exists");
1033        return;
1034    };
1035    my $sth = $base->db->prepare(
1036        sprintf(q{
1037            select description from %s
1038            where canonical = ?
1039            }, $class->_attributes_table)
1040    );
1041    $sth->execute($attribute);
1042    if (my $res = $sth->fetchrow_hashref) {
1043        $sth->finish;
1044        return $res->{description};
1045    } else {
1046        return;
1047    }
1048}
1049
1050=head2 set_attribute_comment ($base, $attribute, $comment)
1051
1052Set comment to attribute
1053
1054=cut
1055
1056sub set_attribute_comment {
1057    my ($class, $base, $attribute, $comment) = @_;
1058
1059    my $attr = $base->attribute($class->type, $attribute) or do {
1060        $base->log(LA_ERR, "The attribute $attribute does not exists");
1061        return;
1062    };
1063    $attr->{inline} and do {
1064        $base->log(LA_ERR,
1065            "Cannot set comment to inline attribute, sorry, blame the author !"
1066        );
1067        return;
1068    };
1069    my $sth = $base->db->prepare(
1070        sprintf(q{
1071            update %s set description = ?
1072            where canonical = ?
1073            }, $class->_attributes_table)
1074    );
1075    my $res = $sth->execute($comment, $attribute);
1076}
1077
10781;
1079
1080__END__
1081
1082=head1 SEE ALSO
1083
1084L<LATMOS::Accounts::Bases::Sql>
1085
1086L<LATMOS::Accounts::Bases::Objects>
1087
1088=head1 AUTHOR
1089
1090Olivier Thauvin, E<lt>olivier.thauvin@latmos.ipsl.frE<gt>
1091
1092=head1 COPYRIGHT AND LICENSE
1093
1094Copyright (C) 2008, 2009 CNRS SA/CETP/LATMOS
1095
1096This library is free software; you can redistribute it and/or modify
1097it under the same terms as Perl itself, either Perl version 5.10.0 or,
1098at your option, any later version of Perl 5 you may have available.
1099
1100
1101=cut
Note: See TracBrowser for help on using the repository browser.