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

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

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