source: branches/4.0/LATMOS-Accounts/lib/LATMOS/Accounts/Bases/Sql/objects.pm @ 1284

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

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