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

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

Allow search for NULL value to any field (included not inline)
  • Property svn:keywords set to Id Rev
File size: 30.9 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_ERR, '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, $attribute) = @_;
642    my $attr = $base->attribute($class->type, $attribute) or do {
643        $base->log(LA_ERR, "Cannot instantiate %s attribute", $attribute);
644        return;
645    };
646    if (!$attr->readable) {
647        $base->log(LA_WARN, l('Attribute %s is not readable', $attribute));
648        return;
649    }
650    if (!$base->check_acl($class->type, $attribute, 'r')) {
651        $base->log(LA_WARN, l('Permission denied to read attribute %s', $attribute));
652        return;
653    }
654    if ($attr->{managed}) { 
655        return $class->SUPER::attributes_summary($base, $attribute);
656    }
657    my $sth = $base->db->prepare_cached(
658        $attr->{inline}
659            ? sprintf(
660                q{select %s as value from %s} . ($base->{wexported} ? '' : ' and "exported" = true'),
661                $base->db->quote_identifier($attr->iname),
662                $base->db->quote_identifier($class->_object_table),
663            )
664            : sprintf(
665                q{select value from %s join
666                %s on %s.ikey = %s.okey where attr = ? group by value} . ($base->{wexported} ? '' : ' and "exported" = true'),
667                $base->db->quote_identifier($class->_object_table),
668                $base->db->quote_identifier($class->_object_table .
669                    '_attributes'),
670                $base->db->quote_identifier($class->_object_table),
671                $base->db->quote_identifier($class->_object_table .
672                    '_attributes'),
673            )
674    );
675    $sth->execute($attr->{inline} ? () : ($attr->iname));
676
677    my %values;
678    while (my $res = $sth->fetchrow_hashref) {
679        $values{$res->{value}} = 1 if ($res->{value});
680    }
681    sort keys %values
682}
683
684=head2 attributes_summary_by_object($base, $attribute)
685
686Return a hash containing object/value peer for C<$attribute>.
687
688=cut
689
690sub attributes_summary_by_object {
691    my ($class, $base, $attribute) = @_;
692    my $attr = $base->attribute($class->type, $attribute) or do {
693        $base->log(LA_ERR, "Cannot instantiate %s attribute", $attribute);
694        return;
695    };
696    if (!$attr->readable) {
697        $base->log(LA_WARN, l('Attribute %s is not readable', $attribute));
698        return;
699    }
700    if (!$base->check_acl($class->type, $attribute, 'r')) {
701        $base->log(LA_WARN, l('Permission denied to read attribute %s', $attribute));
702        return;
703    }
704    if ($attr->{managed}) {
705        return $class->SUPER::attributes_summary_by_object($base, $attribute);
706    }
707    my $sth = $base->db->prepare_cached(
708        $attr->{inline}
709            ? sprintf(
710                q{
711                select name, %s as value from %s} . ($base->{wexported} ? '' : ' where "exported" = true'),
712                $base->db->quote_identifier($attr->iname),
713                $base->db->quote_identifier($class->_object_table),
714            )
715            : sprintf(
716                q{select name, value from %s left join %s on %s.ikey = %s.okey and attr = ?} . ($base->{wexported} ? '' : ' and "exported" = true'),
717                $base->db->quote_identifier($class->_object_table),
718                $base->db->quote_identifier($class->_object_table .
719                    '_attributes'),
720                $base->db->quote_identifier($class->_object_table),
721                $base->db->quote_identifier($class->_object_table .
722                    '_attributes'),
723            )
724    );
725    $sth->execute($attr->{inline} ? () : ($attr->iname));
726
727    my %values;
728    while (my $res = $sth->fetchrow_hashref) {
729        defined($res->{value}) or next;
730        push(@{ $values{ $res->{name} } }, $res->{value});
731    }
732    %values
733}
734
735sub search {
736    my ($class, $base, @filter) = @_;
737
738    my %attrsql;
739    my %attrbind;
740
741    while (my $item = shift(@filter)) {
742        # attr=foo => no extra white space !
743        # \W is false, it is possible to have two char
744        my ($attr, $mode, $val) = $item =~ /^(\w+)(?:([^\w*]+)(.+))?$/ or next;
745        if (!$mode) {
746            $mode = '~';
747            $val = shift(@filter);
748        }
749        my $attribute = $base->attribute($class->type, $attr) or do {
750            $base->log(LA_ERR, "Unknown attribute $attr");
751            return;
752        };
753        defined($val) or $val =  '';
754
755        # Invalid filter due to impossible value:
756        if (!$attribute->checkinputformat($val) && $mode ne '~') {
757            $base->log(LA_ERR, "Invalid format value $val for attribute $attr");
758            return;
759        }
760
761        $val = $attribute->input($val);
762
763        my $sql;
764
765        # Specific case for unexported attribute, comming from exported value
766        if ($attribute->iname eq 'unexported') {
767            $sql = sprintf(
768                q{select ikey from %s where %s},
769                $base->db->quote_identifier($class->_object_table),
770                $val ? q{exported='f'} : q{exported='t'}
771            )
772        } elsif ($attribute->{inline}) {
773            $sql = sprintf(
774                q{select ikey from %s where %s%s %s},
775                $base->db->quote_identifier($class->_object_table),
776                $base->db->quote_identifier($attribute->iname),
777                ($mode eq '~' ? '::text' : ''),
778                $mode eq '=' && $val eq '*'
779                    ? 'is not NULL'
780                    : $mode eq '=' && $val eq 'NULL'
781                    ? 'is NULL'
782                    : $mode eq '~'
783                        ? 'ILIKE ?'
784                        : "$mode ?"
785            );
786            push(@{$attrbind{$attr}}, $mode eq '~' ? '%' . $val . '%' : $val) unless($mode eq '=' && ($val eq '*' || $val eq 'NULL'));
787        } else {
788            if ($mode eq '=' && $val eq 'NULL') {
789                $sql = sprintf(q{ select ikey from %s where ikey
790                          not in (select okey from %s where attr = ? and value is not NULL) },
791                          $base->db->quote_identifier($class->_object_table),
792                          $base->db->quote_identifier(
793                              $class->_object_table . '_attributes'
794                          ),
795                );
796                push(@{$attrbind{$attr}}, $attribute->iname);
797            } else {
798                $sql = sprintf(
799                    q{select okey from %s where attr = ? %s},
800                    $base->db->quote_identifier(
801                        $class->_object_table . '_attributes'
802                    ),
803                    $val eq '*'
804                        ? ''
805                        : $mode eq '~'
806                            ? q{and value::text ILIKE ?}
807                            : qq{and value $mode ?}
808
809                );
810                push(@{$attrbind{$attr}}, $attribute->iname);
811                push(@{$attrbind{$attr}}, $mode eq '~' ? '%' . $val . '%' : $val) unless($val eq '*');
812            }
813        }
814
815        push(@{ $attrsql{$attr} }, $sql);
816    }
817
818    # building the query
819    my @sqlintersec;
820    if (!$base->{wexported}) {
821        push(@sqlintersec, sprintf(
822                q{select ikey from %s where exported = true},
823                $base->db->quote_identifier($class->_object_table)
824            )
825        );
826    }
827    my @bind;
828    foreach (keys %attrsql) {
829        push(@sqlintersec, '(' . join(" union ", @{$attrsql{$_}}) . ")\n");
830        push(@bind, @{$attrbind{$_} || []});
831    }
832    my $sth = $base->db->prepare(
833        sprintf(q{
834            select name from %s
835            %s
836            order by name
837            },
838            $base->db->quote_identifier($class->_object_table),
839            @sqlintersec 
840            ? "where ikey in (\n" . join("\n intersect\n", @sqlintersec) . ")\n"
841            : '',
842        )
843    );
844    $sth->execute(@bind);
845    my @results;
846    while (my $res = $sth->fetchrow_hashref) {
847        push(@results, $res->{name});
848    }
849    return(@results);
850}
851
852=head2 register_attribute
853
854Register attribute into base
855
856=cut
857
858sub register_attribute {
859    my ($class, $base, $attribute, $comment) = @_;
860
861    $class->is_registered_attribute($base, $attribute) and do {
862        $base->log(LA_ERR, "The attribute $attribute already exists");
863        return;
864    };
865    my $sth = $base->db->prepare(
866        sprintf(q{
867            insert into %s (canonical, description)
868            values (?,?)
869            }, $class->_attributes_table)
870    );
871    my $res = $sth->execute($attribute, $comment);
872}
873
874=head2 is_registered_attribute ($base, $attribute)
875
876Return true is attribute is registered into base
877
878=cut
879
880sub is_registered_attribute {
881    my ($class, $base, $attribute) = @_;
882
883    my $sth = $base->db->prepare(
884        sprintf(q{
885            select 1 from %s where canonical = ?
886            }, $class->_attributes_table
887        )
888    );
889    $sth->execute($attribute);
890    my $res = $sth->fetchrow_hashref;
891    return $res ? 1 : 0;
892}
893
894=head2 get_attribute_comment $base, $attribute)
895
896Return comment for C<$attribute>
897
898=cut
899
900# TODO: get_attribute_comment($attr, $base) { $base ||= $self->base ...
901
902sub get_attribute_comment {
903    my ($class, $base, $attribute) = @_;
904    $base->attribute($class->type, $attribute) or do {
905        $base->log(LA_ERR, "The attribute $attribute does not exists");
906        return;
907    };
908    my $sth = $base->db->prepare(
909        sprintf(q{
910            select description from %s
911            where canonical = ?
912            }, $class->_attributes_table)
913    );
914    $sth->execute($attribute);
915    if (my $res = $sth->fetchrow_hashref) {
916        $sth->finish;
917        return $res->{description};
918    } else {
919        return;
920    }
921}
922
923=head2 set_attribute_comment ($base, $attribute, $comment)
924
925Set comment to attribute
926
927=cut
928
929sub set_attribute_comment {
930    my ($class, $base, $attribute, $comment) = @_;
931
932    my $attr = $base->attribute($class->type, $attribute) or do {
933        $base->log(LA_ERR, "The attribute $attribute does not exists");
934        return;
935    };
936    $attr->{inline} and do {
937        $base->log(LA_ERR,
938            "Cannot set comment to inline attribute, sorry, blame the author !"
939        );
940        return;
941    };
942    my $sth = $base->db->prepare(
943        sprintf(q{
944            update %s set description = ?
945            where canonical = ?
946            }, $class->_attributes_table)
947    );
948    my $res = $sth->execute($comment, $attribute);
949}
950
9511;
952
953__END__
954
955=head1 SEE ALSO
956
957L<LATMOS::Accounts::Bases::Sql>
958
959L<LATMOS::Accounts::Bases::Objects>
960
961=head1 AUTHOR
962
963Olivier Thauvin, E<lt>olivier.thauvin@latmos.ipsl.frE<gt>
964
965=head1 COPYRIGHT AND LICENSE
966
967Copyright (C) 2008, 2009 CNRS SA/CETP/LATMOS
968
969This library is free software; you can redistribute it and/or modify
970it under the same terms as Perl itself, either Perl version 5.10.0 or,
971at your option, any later version of Perl 5 you may have available.
972
973
974=cut
Note: See TracBrowser for help on using the repository browser.