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

Last change on this file since 1457 was 1457, checked in by nanardon, 9 years ago

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