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

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

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