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

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

Fix search results when one of the filter return nothing
  • Property svn:keywords set to Id Rev
File size: 34.8 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    while (my $item = shift(@filter)) {
777        # attr=foo => no extra white space !
778        # \W is false, it is possible to have two char
779        my ($attr, $attrref, $operator, $val) = $item =~ /^(\w+)(?:\.([\.\w]+))?(?:([^\w*]+)(.+))?$/ or next;
780        if (!$operator) {
781            $operator = '~';
782            $val = shift(@filter);
783        }
784        my $attribute = $base->attribute($class->type, $attr) or do {
785            $base->log(LA_ERR, "Unknown attribute $attr");
786            return;
787        };
788        defined($val) or $val =  '';
789
790        $base->log(LA_DEBUG, "Search for %s %s (ref %s) %s %s", $class->type, $attr, $attrref || '(none)', $operator || '', $val);
791
792        # Invalid filter due to impossible value:
793        if ($operator ne '~' && !($operator eq '=' && $val eq 'NULL')) {
794            if (!$attribute->checkinputformat($val)) {
795                $base->log(LA_ERR, "Invalid format value $val for attribute $attr");
796                return;
797            }
798        }
799
800        if ($attrref) {
801            my $otype = $attribute->reference or do {
802                $base->log(LA_ERR, "Attribute $attr do not refer to another object");
803                return;
804            };
805
806            my @results = $base->search_objects($otype, "$attrref$operator$val");
807            $base->log(LA_DEBUG, "Sub search %s res: %s", $otype, join(', ', @results));
808
809            if (!@results) {
810                $results->{$attr} ||= {};
811                next;
812            }
813
814            ($operator, $val) = ('=', join('||', @results));
815        }
816
817        my @results = $class->_search_uniq_filter($base, $attr, $operator, $val);
818
819        $results->{$attr} = {};
820        $results->{$attr}{$_} = 1 foreach (@results) 
821    }
822
823    # Merging filter result
824    my ($attrRef) = keys %{ $results } or return;
825
826    my %mresults = %{ $results->{$attrRef} };
827
828    foreach my $attr (keys %{ $results }) {
829        my @values = keys %mresults;
830        foreach (@values) {
831            $results->{$attr}{$_} or delete($mresults{$_});
832        }
833    }
834
835    return(sort keys %mresults);
836}
837
838
839sub _search_uniq_filter {
840    my ($class, $base, $attr, $operator, $value) = @_;
841
842    my @attrsql;
843    my @attrbind;
844
845    my $attribute = $base->attribute($class->type, $attr) or do {
846        $base->log(LA_ERR, "Unknown attribute $attr");
847        return;
848    };
849
850    my @values = split(/([\|\&]+)/, $value);
851   
852    # We detect if we can do a very quick search:
853    my $forRef = $operator eq '=' && scalar(@values) > 1 && ! grep { $_ eq '*' or $_ eq  '&&' or $_ eq 'NULL' } @values;
854    if ($forRef) {
855        # Improv perf
856        if ($attribute->{inline}) {
857            my $sql = sprintf(
858                q{select ikey from %s where %s = ANY (?)},
859                $base->db->quote_identifier($class->_object_table),
860                $base->db->quote_identifier($attribute->iname),
861            );
862            push(@attrsql, $sql);
863        } else {
864            my $sql = sprintf(
865                q{select okey from %s where attr = ? and "value" = ANY (?) },
866                    $base->db->quote_identifier($class->_object_table . '_attributes'),
867            );
868            push(@attrbind, $attribute->iname);
869            push(@attrsql, $sql);
870        }
871        push(@attrbind, [ grep { $_ ne '||' } @values ]);
872    } else {
873
874    # No optimisation possible:
875    while (defined(my $val = shift(@values))) {
876
877        if ($val eq '&&') {
878            push(@attrsql, 'intersect');
879            next;
880        }
881        if ($val eq '||') {
882            push(@attrsql, 'union');
883            next;
884        }
885
886        $val = $attribute->input($val) unless($operator eq '=' && $val eq 'NULL');
887
888        my $sql;
889
890        # Specific case for unexported attribute, comming from exported value
891        if ($attribute->iname eq 'unexported') {
892            $sql = sprintf(
893                q{select ikey from %s where %s},
894                $base->db->quote_identifier($class->_object_table),
895                $val ? q{exported='f'} : q{exported='t'}
896            )
897        } elsif ($attribute->{inline}) {
898            $sql = sprintf(
899                q{select ikey from %s where %s%s %s},
900                $base->db->quote_identifier($class->_object_table),
901                $base->db->quote_identifier($attribute->iname),
902                ($operator eq '~' ? '::text' : ''),
903                $operator eq '=' && $val eq '*'
904                    ? 'is not NULL'
905                    : $operator eq '=' && $val eq 'NULL'
906                    ? 'is NULL'
907                    : $operator eq '~'
908                        ? 'ILIKE ?'
909                        : "$operator ?"
910            );
911            push(@attrbind, $operator eq '~' ? '%' . $val . '%' : $val) unless($operator eq '=' && ($val eq '*' || $val eq 'NULL'));
912        } else {
913            if ($operator eq '=' && $val eq 'NULL') {
914                $sql = sprintf(q{ select ikey from %s where ikey
915                          not in (select okey from %s where attr = ? and ("value" is NOT NULL and value != '')) },
916                          $base->db->quote_identifier($class->_object_table),
917                          $base->db->quote_identifier(
918                              $class->_object_table . '_attributes'
919                          ),
920                );
921                push(@attrbind, $attribute->iname);
922            } else {
923                $sql = sprintf(
924                    q{select okey from %s where attr = ? %s},
925                    $base->db->quote_identifier(
926                        $class->_object_table . '_attributes'
927                    ),
928                    $val eq '*'
929                        ? ''
930                        : $operator eq '~'
931                            ? q{and value::text ILIKE ?}
932                            : qq{and value $operator ?}
933
934                );
935                push(@attrbind, $attribute->iname);
936                push(@attrbind, $operator eq '~' ? '%' . $val . '%' : $val) unless($val eq '*');
937            }
938        }
939
940        push(@attrsql, $sql);
941    }
942
943    } # Perf
944
945    # building the query
946    if (!$base->{wexported}) {
947        push(@attrsql, 'intersect', sprintf(
948                q{select ikey from %s where exported = true},
949                $base->db->quote_identifier($class->_object_table)
950            )
951        );
952    }
953    my $sth = $base->db->prepare(
954        sprintf(q{
955            select name from %s
956            %s
957            order by name
958            },
959            $base->db->quote_identifier($class->_object_table),
960            @attrsql
961            ? "where ikey in (\n" . join(" ", @attrsql) . ")\n"
962            : '',
963        )
964    );
965    $sth->execute(@attrbind);
966    my @results;
967    while (my $res = $sth->fetchrow_hashref) {
968        push(@results, $res->{name});
969    }
970    return(@results);
971}
972
973=head2 register_attribute
974
975Register attribute into base
976
977=cut
978
979sub register_attribute {
980    my ($class, $base, $attribute, $comment) = @_;
981
982    $class->is_registered_attribute($base, $attribute) and do {
983        $base->log(LA_ERR, "The attribute $attribute already exists");
984        return;
985    };
986    my $sth = $base->db->prepare(
987        sprintf(q{
988            insert into %s (canonical, description)
989            values (?,?)
990            }, $class->_attributes_table)
991    );
992    my $res = $sth->execute($attribute, $comment);
993}
994
995=head2 is_registered_attribute ($base, $attribute)
996
997Return true is attribute is registered into base
998
999=cut
1000
1001sub is_registered_attribute {
1002    my ($class, $base, $attribute) = @_;
1003
1004    my $sth = $base->db->prepare(
1005        sprintf(q{
1006            select 1 from %s where canonical = ?
1007            }, $class->_attributes_table
1008        )
1009    );
1010    $sth->execute($attribute);
1011    my $res = $sth->fetchrow_hashref;
1012    return $res ? 1 : 0;
1013}
1014
1015=head2 get_attribute_comment $base, $attribute)
1016
1017Return comment for C<$attribute>
1018
1019=cut
1020
1021# TODO: get_attribute_comment($attr, $base) { $base ||= $self->base ...
1022
1023sub get_attribute_comment {
1024    my ($class, $base, $attribute) = @_;
1025    $base->attribute($class->type, $attribute) or do {
1026        $base->log(LA_ERR, "The attribute $attribute does not exists");
1027        return;
1028    };
1029    my $sth = $base->db->prepare(
1030        sprintf(q{
1031            select description from %s
1032            where canonical = ?
1033            }, $class->_attributes_table)
1034    );
1035    $sth->execute($attribute);
1036    if (my $res = $sth->fetchrow_hashref) {
1037        $sth->finish;
1038        return $res->{description};
1039    } else {
1040        return;
1041    }
1042}
1043
1044=head2 set_attribute_comment ($base, $attribute, $comment)
1045
1046Set comment to attribute
1047
1048=cut
1049
1050sub set_attribute_comment {
1051    my ($class, $base, $attribute, $comment) = @_;
1052
1053    my $attr = $base->attribute($class->type, $attribute) or do {
1054        $base->log(LA_ERR, "The attribute $attribute does not exists");
1055        return;
1056    };
1057    $attr->{inline} and do {
1058        $base->log(LA_ERR,
1059            "Cannot set comment to inline attribute, sorry, blame the author !"
1060        );
1061        return;
1062    };
1063    my $sth = $base->db->prepare(
1064        sprintf(q{
1065            update %s set description = ?
1066            where canonical = ?
1067            }, $class->_attributes_table)
1068    );
1069    my $res = $sth->execute($comment, $attribute);
1070}
1071
10721;
1073
1074__END__
1075
1076=head1 SEE ALSO
1077
1078L<LATMOS::Accounts::Bases::Sql>
1079
1080L<LATMOS::Accounts::Bases::Objects>
1081
1082=head1 AUTHOR
1083
1084Olivier Thauvin, E<lt>olivier.thauvin@latmos.ipsl.frE<gt>
1085
1086=head1 COPYRIGHT AND LICENSE
1087
1088Copyright (C) 2008, 2009 CNRS SA/CETP/LATMOS
1089
1090This library is free software; you can redistribute it and/or modify
1091it under the same terms as Perl itself, either Perl version 5.10.0 or,
1092at your option, any later version of Perl 5 you may have available.
1093
1094
1095=cut
Note: See TracBrowser for help on using the repository browser.