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

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

Finish the DB handle to avoid warning
  • Property svn:keywords set to Id Rev
File size: 26.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    );
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;
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},
555                $base->db->quote_identifier($attr->iname),
556                $base->db->quote_identifier($class->_object_table),
557            )
558            : sprintf(
559                q{select value from %s where attr = ? group by value},
560                $base->db->quote_identifier($class->_object_table .
561                    '_attributes'),
562            )
563    );
564    $sth->execute($attr->{inline} ? () : ($attribute));
565
566    my @values;
567    while (my $res = $sth->fetchrow_hashref) {
568        push(@values, $res->{value});
569    }
570    @values
571}
572
573sub _set_password {
574    my ($self, $clear_pass) = @_;
575    if (my $attr = $self->base->attribute($self->type, 'userPassword')) {
576        my $field = $attr->iname;
577        my @salt_char = (('a' .. 'z'), ('A' .. 'Z'), (0 .. 9), '/', '.');
578        my $salt = join('', map { $salt_char[rand(scalar(@salt_char))] } (1 .. 8));
579        my $res = $self->set_fields($field, crypt($clear_pass, '$1$' . $salt));
580        if ($res) {
581            if ($self->base->get_global_value('rsa_public_key')) {
582                $self->setCryptPassword($clear_pass) or return;
583            }
584        }
585
586        $self->set_fields('passwordLastSet', DateTime->now->datetime);
587        $self->base->log(LA_NOTICE,
588            'Mot de passe changé pour %s',
589            $self->id
590        );
591        return $res;
592    } else {
593        $self->log(LA_WARN,
594            "Cannot set password: userPassword attributes is unsupported");
595    }
596}
597
598=head2 setCryptPassword($clear_pass)
599
600Store password encrypted using RSA encryption.
601
602=cut
603
604sub setCryptPassword {
605    my ($self, $clear_pass) = @_;
606    if (my $serialize = $self->base->get_global_value('rsa_public_key')) {
607        my $public = Crypt::RSA::Key::Public->new;
608        $public = $public->deserialize(String => [ $serialize ]);
609        my $rsa = new Crypt::RSA ES => 'PKCS1v15';
610        my $rsa_password = $rsa->encrypt (
611            Message    => $clear_pass,
612            Key        => $public,
613            Armour     => 1,
614        ) || die $rsa->errstr();
615        if (!$self->_set_c_fields('encryptedPassword', $rsa_password)) {
616            $self->log(LA_ERR,
617                "Cannot set 'encryptedPassword' attribute for object %s/%s",
618                $self->type, $self->id,
619            );
620            return;
621        }
622    }
623    $self->ReportChange('Password', 'Password stored using internal key');
624    return 1;
625}
626
627
628sub search {
629    my ($class, $base, @filter) = @_;
630
631    my %attrsql;
632    my %attrbind;
633
634    while (my $item = shift(@filter)) {
635        # attr=foo => no extra white space !
636        # \W is false, it is possible to have two char
637        my ($attr, $mode, $val) = $item =~ /^(\w+)(?:(\W)(.+))?$/ or next;
638        if (!$mode) {
639            $mode = '~';
640            $val = shift(@filter);
641        }
642        my $attribute = $base->attribute($class->type, $attr) or do {
643            $base->log(LA_ERR, "Unknown attribute $attr");
644            return;
645        };
646        defined($val) or $val =  '';
647
648        # Invalid filter due to impossible value:
649        $attribute->checkinput($val) or do {
650            $base->log(LA_ERR, "Invalid value $val for attribute $attr");
651            return;
652        };
653
654        $val = $attribute->input($val);
655
656        my $sql;
657
658        # Specific case for unexported attribute, comming from exported value
659        if ($attribute->iname eq 'unexported') {
660            $sql = sprintf(
661                q{select ikey from %s where %s},
662                $base->db->quote_identifier($class->_object_table),
663                $val ? q{exported='f'} : q{exported='t'}
664            )
665        } elsif ($attribute->{inline}) {
666            $sql = sprintf(
667                q{select ikey from %s where %s %s},
668                $base->db->quote_identifier($class->_object_table),
669                $base->db->quote_identifier($attribute->iname),
670                $val eq '*'
671                    ? 'is not NULL'
672                    : $mode eq '~'
673                        ? 'ILIKE ?'
674                        : '= ?' 
675            );
676            push(@{$attrbind{$attr}}, $mode eq '~' ? '%' . $val . '%' : $val) unless($val eq '*');
677        } else {
678            $sql = sprintf(
679                q{select okey from %s where attr = ? %s},
680                $base->db->quote_identifier(
681                    $class->_object_table . '_attributes'
682                ),
683                $val eq '*'
684                    ? ''
685                    : $mode eq '~'
686                        ? q{and value ILIKE ?}
687                        : q{and value = ?}
688
689            );
690            push(@{$attrbind{$attr}}, $attribute->iname);
691            push(@{$attrbind{$attr}}, $mode eq '~' ? '%' . $val . '%' : $val) unless($val eq '*');
692        }
693
694        push(@{ $attrsql{$attr} }, $sql);
695    }
696
697    # building the query
698    my @sqlintersec;
699    if (!$base->{wexported}) {
700        push(@sqlintersec, sprintf(
701                q{select ikey from %s where exported = true},
702                $base->db->quote_identifier($class->_object_table)
703            )
704        );
705    }
706    my @bind;
707    foreach (keys %attrsql) {
708        push(@sqlintersec, '(' . join(" union ", @{$attrsql{$_}}) . ")\n");
709        push(@bind, @{$attrbind{$_} || []});
710    }
711    my $sth = $base->db->prepare(
712        sprintf(q{
713            select name from %s
714            %s
715            order by name
716            },
717            $base->db->quote_identifier($class->_object_table),
718            @sqlintersec 
719            ? "where ikey in (\n" . join("\n intersect\n", @sqlintersec) . ")\n"
720            : '',
721        )
722    );
723    $sth->execute(@bind);
724    my @results;
725    while (my $res = $sth->fetchrow_hashref) {
726        push(@results, $res->{name});
727    }
728    return(@results);
729}
730
731=head2 register_attribute
732
733Register attribute into base
734
735=cut
736
737sub register_attribute {
738    my ($class, $base, $attribute, $comment) = @_;
739
740    $class->is_registered_attribute($base, $attribute) and do {
741        $base->log(LA_ERR, "The attribute $attribute already exists");
742        return;
743    };
744    my $sth = $base->db->prepare(
745        sprintf(q{
746            insert into %s (canonical, description)
747            values (?,?)
748            }, $class->_attributes_table)
749    );
750    my $res = $sth->execute($attribute, $comment);
751}
752
753=head2 is_registered_attribute ($base, $attribute)
754
755Return true is attribute is registered into base
756
757=cut
758
759sub is_registered_attribute {
760    my ($class, $base, $attribute) = @_;
761
762    my $sth = $base->db->prepare(
763        sprintf(q{
764            select 1 from %s where canonical = ?
765            }, $class->_attributes_table
766        )
767    );
768    $sth->execute($attribute);
769    my $res = $sth->fetchrow_hashref;
770    return $res ? 1 : 0;
771}
772
773=head2 get_attribute_comment $base, $attribute)
774
775Return comment for C<$attribute>
776
777=cut
778
779# TODO: get_attribute_comment($attr, $base) { $base ||= $self->base ...
780
781sub get_attribute_comment {
782    my ($class, $base, $attribute) = @_;
783    $base->attribute($class->type, $attribute) or do {
784        $base->log(LA_ERR, "The attribute $attribute does not exists");
785        return;
786    };
787    my $sth = $base->db->prepare(
788        sprintf(q{
789            select description from %s
790            where canonical = ?
791            }, $class->_attributes_table)
792    );
793    $sth->execute($attribute);
794    if (my $res = $sth->fetchrow_hashref) {
795        $sth->finish;
796        return $res->{description};
797    } else {
798        return;
799    }
800}
801
802=head2 set_attribute_comment ($base, $attribute, $comment)
803
804Set comment to attribute
805
806=cut
807
808sub set_attribute_comment {
809    my ($class, $base, $attribute, $comment) = @_;
810
811    my $attr = $base->attribute($class->type, $attribute) or do {
812        $base->log(LA_ERR, "The attribute $attribute does not exists");
813        return;
814    };
815    $attr->{inline} and do {
816        $base->log(LA_ERR,
817            "Cannot set comment to inline attribute, sorry, blame the author !"
818        );
819        return;
820    };
821    my $sth = $base->db->prepare(
822        sprintf(q{
823            update %s set description = ?
824            where canonical = ?
825            }, $class->_attributes_table)
826    );
827    my $res = $sth->execute($comment, $attribute);
828}
829
8301;
831
832__END__
833
834=head1 SEE ALSO
835
836L<LATMOS::Accounts::Bases::Sql>
837
838L<LATMOS::Accounts::Bases::Objects>
839
840=head1 AUTHOR
841
842Olivier Thauvin, E<lt>olivier.thauvin@latmos.ipsl.frE<gt>
843
844=head1 COPYRIGHT AND LICENSE
845
846Copyright (C) 2008, 2009 CNRS SA/CETP/LATMOS
847
848This library is free software; you can redistribute it and/or modify
849it under the same terms as Perl itself, either Perl version 5.10.0 or,
850at your option, any later version of Perl 5 you may have available.
851
852
853=cut
Note: See TracBrowser for help on using the repository browser.