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

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

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