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

Last change on this file since 2234 was 2234, checked in by nanardon, 5 years ago

Allow to use functions in queryformat
  • Property svn:keywords set to Id Rev
File size: 46.8 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: 2105 $ =~ /^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
24# Write extend attribute table
25sub _object_table_attributes      { $_[0]->_object_table . '_attributes' }
26# Read search table (with compute attribute)
27sub _object_table_attributes_read { $_[0]->_object_table . '_attributes' }
28
29sub listReal {
30    my ($class, $base) = @_;
31
32    my $sth = $base->db->prepare_cached(
33        sprintf(
34            q{select %s as k from %s where internobject = false
35                and oalias IS NULL %s order by %s},
36            $base->db->quote_identifier($class->_key_field),
37            $base->db->quote_identifier($class->_object_table),
38            ($base->{wexported} ? '' : 'and exported = true'),
39            $base->db->quote_identifier($class->_key_field),
40        )
41    );
42    $sth->execute;
43    my @keys;
44    while(my $res = $sth->fetchrow_hashref) {
45        push(@keys, $res->{k});
46    }
47    @keys
48}
49
50sub list {
51    my ($class, $base) = @_;
52
53    my $sth = $base->db->prepare_cached(
54        sprintf(
55            q{select %s as k from %s where internobject = false %s order by %s},
56            $base->db->quote_identifier($class->_key_field),
57            $base->db->quote_identifier($class->_object_table),
58            ($base->{wexported} ? '' : 'and exported = true'),
59            $base->db->quote_identifier($class->_key_field),
60        )
61    );
62    $sth->execute;
63    my @keys;
64    while(my $res = $sth->fetchrow_hashref) {
65        push(@keys, $res->{k});
66    }
67    @keys
68}
69
70sub list_from_rev {
71    my ($class, $base, $rev) = @_;
72    my $sth = $base->db->prepare_cached(
73        sprintf(
74            q{select %s as k from %s where rev > ? and internobject = false
75                and oalias IS NULL  %s order by %s},
76            $base->db->quote_identifier($class->_key_field),
77            $base->db->quote_identifier($class->_object_table),
78            ($base->{wexported} ? '' : 'and exported = true'),
79            $base->db->quote_identifier($class->_key_field),
80        )
81    );
82    $sth->execute($rev);
83    my @keys;
84    while(my $res = $sth->fetchrow_hashref) {
85        push(@keys, $res->{k});
86    }
87    @keys
88}
89
90sub _has_extended_attributes { 0 }
91
92sub _get_attr_schema {
93    my ($class, $base, $info) = @_;
94    $info ||= {};
95    if (!$base->{__cache}{$class->_object_table}{inline}) {
96        $base->{__cache}{$class->_object_table}{inline} = [];
97        my $sth = $base->db->prepare(
98            q{SELECT column_name FROM information_schema.columns
99              WHERE table_name = ?}
100        );
101        $sth->execute($class->_object_table);
102        while (my $res = $sth->fetchrow_hashref) {
103            push(@{$base->{__cache}{$class->_object_table}{inline}},
104                $res->{column_name});
105        }
106    }
107    foreach (@{$base->{__cache}{$class->_object_table}{inline}}) {
108        $info->{$_}{inline} = 1;
109        if (m/^(rev|date|create|ikey)$/) {
110            $info->{$_}{ro} = 1
111        }
112    }
113
114    # Common to all object attribute:
115    my %commons = (
116        name      => {
117            inline => 1,
118            ro => 1,
119            label => l('Name'),
120        },
121        create    => {
122            inline => 1,
123            ro => 1,
124            label => l('Created'),
125        },
126        date      => {
127            inline => 1,
128            ro => 1,
129            label => l('Last modified'),
130        },
131        exported   =>   { inline => 1, formtype => 'CHECKBOX', hide => 1, monitored => 1 },
132        unexported =>   {
133            inline => 1,
134            managed => 1,
135            formtype => 'CHECKBOX',
136            get => sub {
137                my ($self) = @_;
138                return $self->object->get_field('exported') ? undef : 1;
139            },
140            set => sub {
141                my ($self, $data) = @_;
142                $self->object->_set_c_fields('exported', $data ? 0 : 1);
143            },
144            label => l('Hidden'),
145        },
146        services   =>   {
147            managed => 1,
148            multiple => 1,
149            reference => 'service',
150            label => l('Service'),
151        },
152        modifiedby =>   {
153            inline  => 1,
154            reference => 'user',
155            ro => 1,
156            label => l('Modified by'),
157        },
158        createdby => {
159            inline  => 1,
160            reference => 'user',
161            ro => 1,
162            label => l('Created by'),
163        },
164        oalias => {
165            inline  => 1,
166            reference => $class->type,
167            label => l('Object alias for'),
168            post => sub {
169                my ($self, $value) = @_;
170                $self->object->_update_aliases_ptr();
171                $self->object->_update_aliases_cache();
172            },
173            checkinput => sub {
174                my ($oalias) = @_;
175                my $otype = $class->type;
176                $oalias ||= '';
177
178                if (my ($aliasotype, $aliasoname, $aliasattr) = $oalias =~ m/^([^\/]+)\.([^\.]+)\.(.*)$/) {
179                    my $attribute = $base->attribute($aliasotype, $aliasattr) or do {
180                        $base->log(LA_DEBUG, "Oalias %s (%s): can fetch attibute %s/%s",
181                            $otype, $oalias, $aliasotype, $aliasattr);
182                        return;
183                    };
184                    my $refotype = $attribute->reference or do {
185                        $base->log(LA_DEBUG, "Oalias %s (%s): Attribute does not reference an object",
186                            $otype, $oalias);
187                        return;
188                    };
189
190                    if ($attribute->multiple) {
191                        $base->log(LA_DEBUG, "Oalias %s (%s): Attribute must not be multiple",
192                            $otype, $oalias);
193                        return;
194                    };
195                } elsif(!$base->get_object($otype, $oalias)) {
196                    $base->log(LA_DEBUG, "Cannot get object $otype/$oalias");
197                    return;
198                }
199                return 1;
200            },
201        },
202        oaliascache => {
203            inline  => 1,
204            reference => $class->type,
205            label => l('Cache for oalias data'),
206            hide => 1,
207        },
208        internobject => {
209            inline  => 1,
210            label => l('Internal object'),
211            hide => 1,
212        },
213        nodelete => {
214            inline => 1,
215            label => l('Deletion protection'),
216            hide => 1,
217        },
218        setReftoMe  => {
219            multiple => 1,
220            managed => 1,
221            delayed => 1,
222            set => sub {
223                my ($self, $data) = @_;
224                my $count = 0;
225                foreach (ref $data ? @{$data} : $data) {
226                    my ($otype, $oname, $attribute) = $_ =~ m/^([^\.]+)\.(.+)\.([^\.]+)$/ or next;
227                    my $object = $base->get_object($otype, $oname) or next;
228                    my $attr = $base->attribute($otype, $attribute) or next;
229                    if ($attr->reference ne $self->object->type) {
230                        $base->log(LA_ERR, "Cannot set $_ pointing to " . $self->object->id . ": attribute does not reference " . $self->object->type);
231                        return;
232                    }
233                    if ($attr->multiple) {
234                        my @values = $object->get_attributes($attribute);
235                        $count += $object->set_c_fields($attribute => [ @values, $self->object->id ]);
236                    } else {
237                        $count += $object->set_c_fields($attribute => $self->object->id);
238                    }
239                }
240                return $count;
241            },
242            label => l('Set me as reference'),
243        },
244    );
245
246    # Merging / overriding with common to all object attributes properties
247    foreach my $attr (keys %commons) {
248        foreach my $var (keys %{ $commons{$attr} }) {
249            $info->{$attr}{$var} = $commons{$attr}{$var};
250        }
251    }
252
253    # TODO kill this code: useless since everything is declared in perl code
254    if ($class->_has_extended_attributes) {
255        if (!$base->{__cache}{$class->_object_table}{extend}) {
256            $base->{__cache}{$class->_object_table}{extend} = [];
257            my $sth = $base->db->prepare_cached(
258                sprintf(
259                    q{select canonical from %s order by canonical},
260                    $base->db->quote_identifier($class->_attributes_table),
261                )
262            );
263            $sth->execute;
264            while (my $res = $sth->fetchrow_hashref) {
265                push(@{$base->{__cache}{$class->_object_table}{extend}},
266                        $res->{canonical});
267            }
268        }
269        foreach (@{$base->{__cache}{$class->_object_table}{extend}}) {
270            #$base->log(LA_DEBUG, 'Attribute %s for %s not declared in code', $_, $class->type) if(!exists($info->{$_}));
271            $info->{$_} ||= {};
272        }
273    }
274
275    $info
276}
277
278# Everything managed by the perl code
279
280sub _managed_fields {
281    my ($class, $for, $base) = @_;
282    return();
283}
284
285sub new {
286    my ($class, $base, $id) = @_;
287
288    my $__cache = $base->{__cache}{"_" . $class->type};
289
290    if (!(exists($__cache->{$id})
291        && $__cache->{$id}{__time} >= time - 1)) {
292
293        my $sth = $base->db->prepare_cached(
294            sprintf(q{ select 1 from %s where %s = ? %s},
295                $base->db->quote_identifier($class->_object_table),
296                $base->db->quote_identifier($class->_key_field),
297                ($base->{wexported} ? '' : 'and exported = true'),
298            ),
299        );
300        my $count = $sth->execute($id);
301        $sth->finish;
302        ($count || 0) == 1 or return;
303    }
304    $class->SUPER::new($base, $id);
305}
306
307sub Iid { $_[0]->_get_ikey }
308
309=head2 ParentObject
310
311When object is part of another return the parent object, return undef otherwise.
312
313=cut
314
315sub ParentObject { }
316
317sub _get_ikey {
318    my ($class, $base, $id) = @_;
319    $base ||= $class->base;
320    $id ||= $class->id;
321    my $sth = $base->db->prepare_cached(
322        sprintf(
323            q{select ikey from %s where %s = ?},
324            $base->db->quote_identifier($class->_object_table),
325            $base->db->quote_identifier($class->_key_field),
326        )
327    );
328    $sth->execute($id);
329    my $res = $sth->fetchrow_hashref;
330    $sth->finish;
331    $res->{ikey}
332}
333
334sub _create {
335    my ($class, $base, $id, %data) = @_;
336
337    # splitting inline from extended
338    my (%first, %second);
339    # Ensure object is exported if not specified
340    $data{exported} = 1 if (!exists($data{exported}));
341    if (exists $data{unexported}) {
342        $data{exported} = $data{unexported} ? 0 : 1;
343        delete $data{unexported}
344    }
345    foreach (keys %data) {
346        my $attr = $base->attribute($class->type, $_) or next;
347        $_ =~ /^exported$/ and $data{$_} = $data{$_} ? 1 : 0;
348        my $formatted = ref($data{$_})
349            ? [ map { $attr->input($_) } @{ $data{$_} } ]
350            : $attr->input($data{$_});
351        if ($attr->{inline} && ! $attr->{delayed}) {
352            my $iname = $attr->iname;
353            $first{$iname} = $formatted;
354        } else {
355            # the real internal name will be translate by _set_c_field
356            $second{$_} = $formatted if(defined($formatted));
357        }
358    }
359    $first{$class->_key_field} = $id;
360    $first{createdby} =  $base->user || '@Console';
361    $first{modifiedby} = $base->user || '@Console';
362
363    my $lastid;
364    {
365        my $sthnextval = $base->db->prepare_cached("select nextval('ikey_seq') as c");
366        $sthnextval->execute;
367        $lastid = $sthnextval->fetchrow_hashref()->{c};
368        $first{ikey} = $lastid;
369        $sthnextval->finish;
370    }
371
372    my $sth = $base->db->prepare(
373        sprintf(
374            q{insert into %s (%s) values (%s)},
375            $base->db->quote_identifier($class->_object_table),
376            join(', ', map { $base->db->quote_identifier($_) } sort keys %first),
377            join(',', qw(?) x scalar(keys %first)),
378        )
379    );
380    $sth->execute(map { defined($first{$_}) ? $first{$_} : undef } sort keys %first) or return;
381
382    my $sthid = $base->db->prepare_cached(
383        sprintf(q{select %s as k from %s where ikey = ?},
384            $base->db->quote_identifier($class->_key_field),
385            $base->db->quote_identifier($class->_object_table),
386        )
387    );
388    $sthid->execute($lastid);
389    my $res = $sthid->fetchrow_hashref();
390    $sthid->finish;
391    $res or do {
392        $base->log(LA_DEBUG, 'Cannot retrieve SQL row from freshly create object %s/%s', $class->type, $id);
393        return;
394    };
395
396    my $obj = $class->new($base, $res->{k}) or return;
397    if (keys %second) {
398        $obj->_set_c_fields(%second) or do {
399            $base->log(LA_DEBUG, 'Cannot set attributes to freshly create object %s/%s', $class->type, $id);
400            return;
401        };
402    }
403
404    return $res->{k};
405}
406
407=head2 refreshRev
408
409Increase revision of the object to force synchronisation
410
411=cut
412
413sub refreshRev {
414    my ($self) = @_;
415
416    my $sth = $self->db->prepare_cached(
417        sprintf(q{
418                UPDATE %s SET rev = nextval('revisions_rev_seq'::regclass)  WHERE %s = ?
419            },
420            $self->db->quote_identifier($self->_object_table),
421            $self->db->quote_identifier($self->_key_field),
422        )
423    );
424    $sth->execute($self->id);
425}
426
427=head2 CreateAlias($base, $name, $for)
428
429Create an alias named C<$name> with pointing to C<$for>
430
431=cut
432
433sub CreateAlias {
434    my ($class, $base, $name, $for) = @_;
435
436    $base->log(LA_ERR, '%s does not support alias object, alias %s not created', $class->type, $name);
437}
438
439sub _delete {
440    my ($class, $base, $id) = @_;
441
442    my $__cache = $base->{__cache}{"_" . $class->type};
443
444    my $obj = $base->get_object($class->type, $id)
445        or return;
446
447    if ($obj->_get_attributes('internobject')) {
448        # Cannot happend: internal are not fetchable
449        $base->log(LA_ERR,'Cannot delete %s/%s: is an internal object', $class->type, $id);
450        return;
451    }
452    if ($obj->_get_attributes('nodelete')) {
453        $base->log(LA_ERR,'Cannot delete %s/%s: is write protected', $class->type, $id);
454        return;
455    }
456
457    my $sthd = $base->db->prepare_cached(
458        sprintf(
459            q{delete from %s where %s = ?},
460            $base->db->quote_identifier($class->_object_table),
461            $base->db->quote_identifier($class->_key_field),
462        )
463    );
464    my $res = $sthd->execute($id);
465    if ($res) {
466        delete($__cache->{$id});
467    }
468
469    $res
470}
471
472sub _rename {
473    my ($class, $base, $id, $newid) = @_;
474
475    my $sthr = $base->db->prepare_cached(
476        sprintf(
477            q{update %s set %s = ? where %s = ?},
478            $base->db->quote_identifier($class->_object_table),
479            $base->db->quote_identifier($class->_key_field),
480            $base->db->quote_identifier($class->_key_field),
481        )
482    );
483
484    if (($sthr->execute($newid, $id) || 0) != 1) {
485        $base->log(LA_ERR, "Erreur renaming %s %s to %s",
486            $class->type,
487            $id, $newid,
488        );
489        return;
490    }
491
492    1;
493}
494
495=head2 db
496
497Return reference to L<DBI> object.
498
499=cut
500
501sub db {
502    return $_[0]->base->db;
503}
504
505sub _quote_object_table {
506    my ($self) = @_;
507    my $table = $self->_object_table or return;
508    $self->db->quote_identifier($table);
509}
510sub _quote_key_field {
511    my ($self) = @_;
512    my $key_field = $self->_key_field or return;
513    $self->db->quote_identifier($key_field);
514}
515
516sub get_field {
517    my ($self, $field) = @_;
518    if ($field eq 'services') {
519        my @services;
520        my $sth = $self->db->prepare_cached(
521            q{ select name from service join service_attributes
522               on okey = ikey
523               where service_attributes.attr = 'dependOn' and value = ?
524               });
525        $sth->execute($self->type . '.' . $self->id);
526        while(my $res = $sth->fetchrow_hashref) {
527            push(@services, $res->{name});
528        }
529        return \@services; 
530    }
531    my $attr = $self->attribute($field) or return;
532    if ($attr->{inline}) {
533    my $sth = $self->db->prepare_cached(
534        sprintf(
535            q{select %s from %s where %s = ?},
536            $self->db->quote_identifier(lc($field)),
537            $self->_quote_object_table,
538            $self->_quote_key_field,
539        )
540    );
541    $sth->execute($self->id);
542    my $res = $sth->fetchrow_hashref or $self->db->rollback;
543    $sth->finish;
544    return $res->{$field};
545    } elsif ($self->_has_extended_attributes) { # else, then we mandatory have extend attr
546        $self->base->{__cache}{"_" . $self->type} ||= {};
547        my $__cache = $self->base->{__cache}{"_" . $self->type};
548        if (!(exists($__cache->{$self->id})
549            && $__cache->{$self->id}{__time} >= time - 1)) {
550        my $sth = $self->db->prepare_cached(
551            sprintf(
552                q{
553                select attr, value from %s
554                join %s on okey = ikey
555                where %s = ?
556                },
557                $self->db->quote_identifier($self->_object_table_attributes_read),
558                $self->db->quote_identifier($self->_object_table),
559                $self->db->quote_identifier($self->_key_field),
560            )
561        );
562        $sth->execute($self->id);
563        delete($__cache->{$self->id});
564        $__cache->{$self->id}{__time} = time;
565        while(my $res = $sth->fetchrow_hashref) {
566            push(@{$__cache->{$self->id}{$res->{attr}}}, $res->{value});
567        }
568        #return @values > 1 ? \@values : $values[0];
569        }
570        my $val = $__cache->{$self->id}{$field};
571        return @{$val || []} > 1 ? $val : $val->[0];
572    }
573}
574
575sub GetAttributeValue {
576    my ($self, $cfield) = @_;
577
578    my $res = $self->SUPER::GetAttributeValue($cfield) or return;
579
580    my $attribute = $self->attribute($cfield) or do {
581        $self->base->log(LA_WARN, "Unknow attribute $cfield");
582        return;
583    };
584
585    if (my $ref = $attribute->reference) {
586        my @deref;
587        foreach my $v (ref $res ? @{ $res } : $res) {
588            my $derefobj = $self->base->_derefObject($ref, $v);
589            push(@deref, $derefobj->id) if ($derefobj);
590        }
591        return scalar(@deref) > 1 ? \@deref : $deref[0];
592    } else {
593        return $res;
594    }
595}
596
597sub set_fields {
598    my ($self, %data) = @_;
599    my @updated_attributes = ();
600    my @fields;
601    my @vals;
602    my %ext;
603    if (exists($data{services})) {
604        my %old = map { $_ => 0 } $self->get_attributes('services');
605        foreach my $serv (grep { $_ } ref $data{services} ? @{ $data{services} } : $data{services}) {
606            if (!exists($old{$serv})) {
607                my $oserv = $self->base->get_object('service', $serv) or next;
608                $oserv->addAttributeValue('dependOn', $self->type . '.' . $self->id);
609            }
610            $old{$serv} = 1;
611        }
612        foreach my $serv (keys %old) {
613            if (!$old{$serv}) {
614                my $oserv = $self->base->get_object('service', $serv) or next;
615                $oserv->delAttributeValue('dependOn', $self->type . '.' . $self->id);
616            }
617        }
618        delete($data{services});
619    }
620    foreach my $field (keys %data) {
621        my $attr = $self->attribute($field);
622        my $oldval = $self->get_field($field);
623        next if (($data{$field} || '') eq ($oldval || ''));
624        if ($attr->{inline}) {
625        # TODO check fields exists !
626            push(@fields, sprintf("%s = ?", $self->db->quote_identifier($field)));
627            # undef mean unset, handling null for exported:
628            if ($field eq 'exported') {
629                push(@vals, $data{$field} ? 1 : 0);
630            } else {
631                push(@vals, $data{$field} || undef);
632            }
633            push(@updated_attributes, $field);
634        } else {
635            $ext{$field} = $data{$field};
636        }
637    }
638    if (@fields) {
639        my $sth = $self->db->prepare_cached(
640            sprintf(
641                q{update %s set %s where %s = ?},
642                $self->_quote_object_table,
643                join(', ', @fields),
644                $self->_quote_key_field,
645            )
646        );
647        $sth->execute(@vals, $self->id) or do {
648            $self->base->log(LA_ERR,
649                "Cannot update inline field for object %s, %s: %s",
650                $self->type,
651                $self->id,
652                $self->base->db->errstr);
653            return;
654        };
655    }
656   
657    if ($self->_has_extended_attributes) {
658        my $sthd = $self->db->prepare_cached(
659            sprintf(
660                q{delete from %s where okey = ? and attr = ?},
661                $self->db->quote_identifier($self->_object_table_attributes),
662            ),
663        );
664        my $sthd1 = $self->db->prepare_cached(
665            sprintf(
666                q{delete from %s where okey = ? and attr = ? and value = ?},
667                $self->db->quote_identifier($self->_object_table_attributes),
668            ),
669        );
670        my $sthx = $self->db->prepare_cached(
671            sprintf(
672                q{insert into %s (okey, attr, value) values (?,?,?)},
673                $self->db->quote_identifier($self->_object_table_attributes),
674            )
675        );
676        my $sthu = $self->db->prepare_cached(
677            sprintf(
678                q{update %s set value = ? where okey = ? and attr = ?},
679                $self->db->quote_identifier($self->_object_table_attributes),
680            )
681        );
682
683        my $okey = $self->_get_ikey($self->base, $self->id);
684        foreach my $uattr (keys %ext) {
685            my $attr = $self->attribute($uattr);
686            if ($ext{$uattr}) {
687                if ($attr->{multiple}) {
688                    my $updated = 0;
689                    my $oldvalue = $self->get_field($uattr);
690                    my %newvalues = map { $_ => 1 } (ref $ext{$uattr}
691                        ? @{$ext{$uattr}}
692                        : $ext{$uattr});
693                    foreach (grep { $_ } ref $oldvalue ? @{$oldvalue} : $oldvalue) {
694                        if(exists($newvalues{$_})) {
695                            $newvalues{$_} = 0;
696                        } else {
697                            defined($sthd1->execute($okey, $uattr, $_)) or do {
698                                $self->base->log(LA_ERR,
699                                    "Error while updating attributes on %s/%s %s: %s",
700                                    $self->type,
701                                    $self->id,
702                                    $uattr,
703                                    $self->base->db->errstr
704                                );
705                                return;
706                            };
707                            $updated++;
708                        }
709                    }
710                    foreach (grep { $newvalues{$_} } keys %newvalues) {
711                        $sthx->execute($okey, $uattr, $_) or do {
712                            $self->base->log(LA_ERR,
713                                "Error while updating attributes: %s/%s %s: %s",
714                                $self->type,
715                                $self->id,
716                                $uattr,
717                                $self->base->db->errstr
718                            );
719                            return;
720                        };
721                        $updated++;
722                    }
723                    push(@updated_attributes, $uattr) if ($updated);
724                } else {
725                    my $res = $sthu->execute($ext{$uattr}, $okey, $uattr);
726                    defined($res) or do {
727                        $self->base->log(LA_ERR,
728                            "Error while udapting attributes: %s/%s %s: %s",
729                            $self->type,
730                            $self->id,
731                            $uattr,
732                            $self->base->db->errstr
733                        );
734                        return;
735                    };
736                    if ($res == 0) {
737                        $res = $sthx->execute($okey, $uattr, $ext{$uattr});
738                        defined($res) or do {
739                            $self->base->log(LA_ERR,
740                                "Error while updating attributes: %s/%s %s: %s",
741                                $self->type,
742                                $self->id,
743                                $uattr,
744                                $self->base->db->errstr
745                            );
746                            return;
747                        };
748                    }
749                    push(@updated_attributes, $uattr);
750                }
751            } else {
752                defined($sthd->execute($okey, $uattr)) or do {
753                    $self->base->log(LA_ERR,
754                        "Error while deleting attributes: %s/%s %s: %s",
755                        $self->otype,
756                        $self->id,
757                        $uattr,
758                        $self->base->db->errstr
759                    );
760                    return;
761                };
762                push(@updated_attributes, $uattr);
763            }
764        }
765    }
766
767    delete($self->base->{__cache}{"_" . $self->type}{$self->id});
768
769    foreach my $attr (@updated_attributes) {
770        my $oattr = $self->attribute($attr);
771        my $ref = $oattr->reference or next;
772        my $refname = sprintf('%s.%s.%s', $self->type, $self->id, $attr);
773        my $attrref = "oalias=$refname";
774
775        foreach my $alias ($self->base->search_objects($ref, $attrref)) {
776            my $oalias = $self->base->GetAlias($ref, $alias) or next;
777            $oalias->_update_aliases_cache;
778            $oalias->_update_aliases_ptr;
779        }
780    }
781
782    scalar(@updated_attributes);
783}
784
785sub PostSetAttribute {
786    my ($self) = @_;
787
788    my %data;
789    foreach my $attr ($self->base->list_canonical_fields($self->type, 'r')) {
790        my $oattr = $self->base->get_attr_schema($self->type, $attr);
791        if ($oattr->{auto}) {
792            my $source = "_$attr";
793            $data{$attr} = $self->_get_c_field($source);
794        }
795    }
796    my $res =  $self->set_fields(%data);
797
798    return $res ? $res : 'OEO';
799}
800
801
802=head2 SetNoDelete($value)
803
804Set nodelete attribute to true or false
805
806=cut
807
808sub SetNoDelete {
809    my ($self, $value) = @_;
810
811    my $sthr = $self->db->prepare_cached(
812        sprintf(
813            q{update %s set nodelete = ? where %s = ?},
814            $self->db->quote_identifier($self->_object_table),
815            $self->db->quote_identifier($self->_key_field),
816        )
817    );
818
819    if (($sthr->execute($value ? 'true' : 'false', $self->id) || 0) != 1) {
820        $self->log(LA_ERR, "Erreur seting nodelete for %s/%s to %s",
821            $self->type,
822            $self->id,
823            $value,
824        );
825        return;
826    }
827
828    1;
829}
830
831=head2 find_next_numeric_id($class, $base, $field, $min, $max)
832
833An optimize version to speedup user/group creation
834
835=cut
836
837sub find_next_numeric_id {
838    my ($class, $base, $field, $min, $max) = @_;
839    $base->attribute($class->type, $field) or return;
840    $min ||=
841        $field eq 'uidNumber' ? 500 :
842        $field eq 'gidNumber' ? 500 :
843        1;
844    $max ||= 65635;
845    $base->log(LA_DEBUG, "Trying to find %s in range %d - %d",
846        $field, $min, $max);
847    my %existsid;
848    $base->temp_switch_unexported(sub {
849        foreach ($class->attributes_summary($base, $field)) {
850            $existsid{ $_ } = 1;
851        }
852    }, 1);
853    $min += 0;
854    $max += 0;
855    for(my $i = $min; $i <= $max; $i++) {
856        $existsid{$i + 0} or do {
857            $base->log(LA_DEBUG, "Next %s found: %d", $field, $i);
858            return $i;
859        };
860    }
861    return;
862}
863
864sub attributes_summary {
865    my ($class, $base, $dotAttribute) = @_;
866
867    my ($attribute, $recursiveAttr) = $dotAttribute =~ /(\w+)(?:\.(.*))?/;
868   
869    my $attr = $base->attribute($class->type, $attribute) or do {
870        $base->log(LA_ERR, "Cannot instantiate %s attribute", $attribute);
871        return;
872    };
873    if (!$attr->readable) {
874        $base->log(LA_WARN, l('Attribute %s is not readable', $attribute));
875        return;
876    }
877    if (!$base->check_acl($class->type, $attribute, 'r')) {
878        $base->log(LA_WARN, l('Permission denied to read attribute %s', $attribute));
879        return;
880    }
881    if ($attr->{managed}) { 
882        return $class->SUPER::attributes_summary($base, $attribute);
883    }
884    my $sth = $base->db->prepare_cached(
885        $attr->{inline}
886            ? sprintf(
887                q{select %s as value from %s where internobject = false} . ($base->{wexported} ? '' : ' and "exported" = true'),
888                $base->db->quote_identifier($attr->iname),
889                $base->db->quote_identifier($class->_object_table),
890            )
891            : sprintf(
892                q{select value from %s join
893                %s on %s.ikey = %s.okey where attr = ? and internobject = false group by value} . 
894                    ($base->{wexported} ? '' : ' and "exported" = true'),
895                $base->db->quote_identifier($class->_object_table),
896                $base->db->quote_identifier($class->_object_table_attributes_read),
897                $base->db->quote_identifier($class->_object_table),
898                $base->db->quote_identifier($class->_object_table_attributes_read),
899            )
900    );
901    $sth->execute($attr->{inline} ? () : ($attr->iname));
902
903    my %values;
904    if ($recursiveAttr) {
905        my $otype = $attr->reference or do {
906            $base->log(LA_ERR, "Cannot do recursive search, no ref for attribute %s", $attribute);
907            return;
908        };
909        my %parentRes = $base->attributes_summary_by_object($otype, $recursiveAttr) or return;
910
911        while (my $res = $sth->fetchrow_hashref) {
912            defined($res->{value}) or next;
913            $values{ $parentRes{ $res->{value} } } = 1;
914        }
915    } else {
916        while (my $res = $sth->fetchrow_hashref) {
917            $values{$res->{value}} = 1 if ($res->{value});
918        }
919    }
920    sort keys %values
921}
922
923=head2 attributes_summary_by_object($base, $attribute)
924
925Return a hash containing object/value peer for C<$attribute>.
926
927=cut
928
929sub attributes_summary_by_object {
930    my ($class, $base, $dotAttribute) = @_;
931
932    my ($attribute, $recursiveAttr) = $dotAttribute =~ /(\w+)(?:\.(.*))?/;
933
934    my $attr = $base->attribute($class->type, $attribute) or do {
935        $base->log(LA_ERR, "Cannot instantiate %s attribute", $attribute);
936        return;
937    };
938    if (!$attr->readable) {
939        $base->log(LA_WARN, l('Attribute %s is not readable', $attribute));
940        return;
941    }
942    if (!$base->check_acl($class->type, $attribute, 'r')) {
943        $base->log(LA_WARN, l('Permission denied to read attribute %s', $attribute));
944        return;
945    }
946
947    if ($attr->{managed}) {
948        return $class->SUPER::attributes_summary_by_object($base, $attribute);
949    }
950    my $sth = $base->db->prepare_cached(
951        $attr->{inline}
952            ? sprintf(
953                q{
954                select name, %s as value from %s} . ($base->{wexported} ? '' : ' where "exported" = true'),
955                $base->db->quote_identifier($attr->iname),
956                $base->db->quote_identifier($class->_object_table),
957            )
958            : sprintf(
959                q{select name, value from %s left join %s on %s.ikey = %s.okey and attr = ?} . ($base->{wexported} ? '' : ' and "exported" = true'),
960                $base->db->quote_identifier($class->_object_table),
961                $base->db->quote_identifier($class->_object_table_attributes_read),
962                $base->db->quote_identifier($class->_object_table),
963                $base->db->quote_identifier($class->_object_table_attributes_read),
964            )
965    );
966    $sth->execute($attr->{inline} ? () : ($attr->iname));
967
968    my %values;
969    if ($recursiveAttr) {
970        my $otype = $attr->reference or do {
971            $base->log(LA_ERR, "Cannot do recursive search, no ref for attribute %s", $attribute);
972            return;
973        };
974        my %parentRes = $base->attributes_summary_by_object($otype, $recursiveAttr) or return;
975
976        while (my $res = $sth->fetchrow_hashref) {
977            defined($res->{value}) or next;
978            push(@{ $values{ $res->{name} } }, @{ $parentRes{ $res->{value} } || []});
979        }
980    } else {
981        while (my $res = $sth->fetchrow_hashref) {
982            defined($res->{value}) or next;
983            push(@{ $values{ $res->{name} } }, $res->{value});
984        }
985    }
986    %values
987}
988
989sub search {
990    my ($class, $base, @filter) = @_;
991
992    # Results groups by attr (OR filter)
993    # foo=1 foo=1 => foo = 1 or foo = 2
994    # foo=1 bar=1 => foo =1 and bar = 2
995    my $results = {};
996    my $noalias = 0;
997
998    @filter = grep { defined($_) && $_ ne '' } @filter;
999    if (!@filter) {
1000        my ($package, $filename, $line) = caller;
1001        $base->log(LA_DEBUG, "search() call w/o filter at %s:%d", $filename, $line);
1002        return $base->list_objects($class->type);
1003    }
1004
1005    while (my $item = shift(@filter)) {
1006        # attr=foo => no extra white space !
1007        # \W is false, it is possible to have two char
1008        my ($attr, $attrref, $operator, $val) = $item =~ /^(\w+)(?:\.([\.\w]+))?(?:([^\w*]+)(.+))?$/ or next;
1009        if (!$operator) {
1010            $operator = '~';
1011            $val = shift(@filter);
1012        }
1013
1014        if (my ($func, $args) = $val =~ /^(\w+)\((.*)\)$/) {
1015            $val = $base->QFunc( $func, $args );
1016        }
1017
1018        my $attribute = $base->attribute($class->type, $attr) or do {
1019            $base->log(LA_ERR, "Unknown attribute $attr");
1020            return;
1021        };
1022        $attribute->name eq 'oalias' and $noalias = 1;
1023        defined($val) or $val =  '';
1024
1025        $base->log(LA_DEBUG, "Search for %s %s (ref %s) %s %s", $class->type, $attr, $attrref || '(none)', $operator || '', $val);
1026
1027        # Invalid filter due to impossible value:
1028        if ($operator ne '~' && !($operator eq '=' && ($val eq 'NULL' || $val eq '*'))) {
1029            if (!$attribute->checkinputformat($val)) {
1030                $base->log(LA_ERR, "Invalid format value $val for attribute $attr");
1031                return;
1032            }
1033        }
1034        my $attrKey = $attr;
1035
1036        if ($attrref) {
1037            my $otype = $attribute->reference or do {
1038                $base->log(LA_ERR, "Attribute $attr do not refer to another object");
1039                return;
1040            };
1041
1042            $attrKey .= '.' . $attrref;
1043            my @results = $base->search_objects($otype, "$attrref$operator$val");
1044            $base->log(LA_DEBUG, "Sub search %s res: %s", $otype, join(', ', @results));
1045
1046            if (!@results) {
1047                $results->{$attrKey} ||= {};
1048                next;
1049            }
1050
1051            ($operator, $val) = ('=', join('||', @results));
1052        }
1053
1054        my @results = $class->_search_uniq_filter($base, $attr, $operator, $val);
1055
1056        $base->log(LA_DEBUG, "Search result: %s: %s", $attr, join(' ', @results));
1057        $results->{$attrKey} ||= {};
1058        $results->{$attrKey}{$_} = 1 foreach (@results);
1059    }
1060
1061    # Merging filter result
1062
1063    my %mresults = map { $_ => 1 } $base->list_objects($class->type);
1064
1065    foreach my $attr (keys %{ $results }) {
1066        my @values = keys %mresults;
1067        foreach my $value (sort(@values)) {
1068            if (!$results->{$attr}{$value}) {
1069                delete($mresults{$value});
1070            }
1071        }
1072    }
1073
1074    # We add to result aliases pointing to these object:
1075    if(scalar(keys %mresults) && !$noalias) {
1076        my @alias = $class->_search_uniq_filter($base, 'oalias', '=', join('||', keys %mresults));
1077        foreach(@alias) {
1078            $mresults{$_} = 1;
1079        }
1080    }
1081
1082    return(sort keys %mresults);
1083}
1084
1085sub _search_uniq_filter {
1086    my ($class, $base, $attr, $operator, $value) = @_;
1087
1088    my @attrsql;
1089    my @attrbind;
1090
1091    my $attribute = $base->attribute($class->type, $attr) or do {
1092        $base->log(LA_ERR, "Unknown attribute $attr");
1093        return;
1094    };
1095
1096    my @values = split(/([\|\&]+)/, $value);
1097
1098    $base->log(LA_DEBUG, "Uniq search for " . $class->type . "->$attr $operator (%s)", join(' ', @values));
1099
1100    return unless(@values);
1101   
1102    # We detect if we can do a very quick search:
1103    my $forRef = $operator eq '=' && scalar(@values) > 1 && ! grep { $_ eq '*' or $_ eq  '&&' or $_ eq 'NULL' } @values;
1104    if ($forRef) {
1105        # Improv perf
1106
1107        my @oaliases = ();
1108        if ($attr ne 'oaliascache' && $attribute->reference) {
1109            @oaliases = $base->search_objects($attribute->reference, "oaliascache=$value");
1110            $base->log(LA_DEBUG, "Uniq search will match oaliases: %s", join(' ', @oaliases) || '(none)');
1111        }
1112
1113        if ($attribute->{inline}) {
1114            my $sql = sprintf(
1115                q{select ikey from %s where %s = ANY (?)},
1116                $base->db->quote_identifier($class->_object_table),
1117                $base->db->quote_identifier($attribute->iname),
1118            );
1119            push(@attrsql, $sql);
1120        } else {
1121            my $sql = sprintf(
1122                q{select okey from %s where attr = ? and "value" = ANY (?) },
1123                    $base->db->quote_identifier($class->_object_table_attributes_read),
1124            );
1125            push(@attrbind, $attribute->iname);
1126            push(@attrsql, $sql);
1127        }
1128        push(@attrbind, [ @oaliases, grep { $_ ne '||' } @values ]);
1129    } else {
1130
1131    # No optimisation possible:
1132    while (defined(my $val = shift(@values))) {
1133
1134        if ($val eq '&&') {
1135            push(@attrsql, 'intersect');
1136            next;
1137        }
1138        if ($val eq '||') {
1139            push(@attrsql, 'union');
1140            next;
1141        }
1142
1143        $val = $attribute->input($val) unless($operator eq '=' && $val eq 'NULL');
1144
1145        my $sql;
1146
1147        # Specific case for unexported attribute, comming from exported value
1148        if ($attribute->iname eq 'unexported') {
1149            $sql = sprintf(
1150                q{select ikey from %s where %s},
1151                $base->db->quote_identifier($class->_object_table),
1152                $val ? q{exported='f'} : q{exported='t'}
1153            )
1154        } elsif ($attribute->iname eq 'exported') {
1155            $sql = sprintf(
1156                q{select ikey from %s where %s},
1157                $base->db->quote_identifier($class->_object_table),
1158                $val ? q{exported='t'} : q{exported='f'}
1159            )
1160        } elsif ($attribute->{inline}) {
1161            $sql = sprintf(
1162                q{select ikey from %s where %s%s %s},
1163                $base->db->quote_identifier($class->_object_table),
1164                $base->db->quote_identifier($attribute->iname),
1165                ($operator eq '~' ? '::text' : ''),
1166                $operator eq '=' && $val eq '*'
1167                    ? 'is not NULL'
1168                    : $operator eq '=' && $val eq 'NULL'
1169                    ? 'is NULL'
1170                    : $operator eq '~'
1171                        ? 'ILIKE ?'
1172                        : "$operator ?"
1173            );
1174            push(@attrbind, $operator eq '~' ? '%' . $val . '%' : $val) unless($operator eq '=' && ($val eq '*' || $val eq 'NULL'));
1175        } else {
1176            if ($operator eq '=' && $val eq 'NULL') {
1177                $sql = sprintf(q{ select ikey from %s where ikey
1178                          not in (select okey from %s where attr = ? and ("value" is NOT NULL and value != '')) },
1179                          $base->db->quote_identifier($class->_object_table),
1180                          $base->db->quote_identifier(
1181                              $class->_object_table_attributes_read
1182                          ),
1183                );
1184                push(@attrbind, $attribute->iname);
1185            } else {
1186                my @oaliases = ();
1187                if ($attr ne 'oaliascache' && $attribute->reference) {
1188                    @oaliases = $base->search_objects($attribute->reference, "oaliascache=$val");
1189                    $base->log(LA_DEBUG, "Uniq search will match oaliases for %s: %s", $val, join(' ', @oaliases) || '(none)');
1190                }
1191
1192                $sql = sprintf(
1193                    q{select okey from %s where attr = ? %s},
1194                    $base->db->quote_identifier(
1195                        $class->_object_table_attributes_read
1196                    ),
1197                    $val eq '*'
1198                        ? ''
1199                        : $operator eq '~'
1200                            ? q{and value::text ILIKE ANY(?)}
1201                            : qq{and value $operator ANY (?)}
1202
1203                );
1204                push(@attrbind, $attribute->iname);
1205                my @vals = ( $val, @oaliases );
1206                push(@attrbind, $operator eq '~'
1207                    ? [ map { '%' . $_ . '%' } @vals ]
1208                    : [ @vals ])
1209                    unless($val eq '*');
1210            }
1211        }
1212
1213        push(@attrsql, $sql);
1214    }
1215
1216    } # Perf
1217
1218    # building the query
1219    if (!$base->{wexported}) {
1220        push(@attrsql, 'intersect') if (@attrsql);
1221        push(@attrsql, sprintf(
1222                q{select ikey from %s where exported = true and internobject = false},
1223                $base->db->quote_identifier($class->_object_table)
1224            )
1225        );
1226    }
1227    my $sth = $base->db->prepare(
1228        sprintf(q{
1229            select name from %s
1230            where internobject = false
1231            %s
1232            order by name
1233            },
1234            $base->db->quote_identifier($class->_object_table),
1235            @attrsql
1236            ? "and ikey in (\n" . join(" ", @attrsql) . ")\n"
1237            : '',
1238        )
1239    );
1240    $sth->execute(@attrbind);
1241    my @results;
1242    while (my $res = $sth->fetchrow_hashref) {
1243        push(@results, $res->{name});
1244    }
1245    return(@results);
1246}
1247
1248=head2 register_attribute
1249
1250Register attribute into base
1251
1252=cut
1253
1254sub register_attribute {
1255    my ($class, $base, $attribute, $comment) = @_;
1256
1257    $class->is_registered_attribute($base, $attribute) and do {
1258        $base->log(LA_ERR, "The attribute $attribute already exists");
1259        return;
1260    };
1261    my $sth = $base->db->prepare(
1262        sprintf(q{
1263            insert into %s (canonical, description)
1264            values (?,?)
1265            }, $class->_attributes_table)
1266    );
1267    my $res = $sth->execute($attribute, $comment);
1268}
1269
1270=head2 is_registered_attribute ($base, $attribute)
1271
1272Return true is attribute is registered into base
1273
1274=cut
1275
1276sub is_registered_attribute {
1277    my ($class, $base, $attribute) = @_;
1278
1279    my $sth = $base->db->prepare(
1280        sprintf(q{
1281            select 1 from %s where canonical = ?
1282            }, $class->_attributes_table
1283        )
1284    );
1285    $sth->execute($attribute);
1286    my $res = $sth->fetchrow_hashref;
1287    return $res ? 1 : 0;
1288}
1289
1290=head2 list_registered_attributes
1291
1292Return the list for all registered attribute
1293
1294=cut
1295
1296sub list_registered_attributes {
1297    my ($class, $base) = @_;
1298
1299    my $sth = $base->db->prepare(
1300        sprintf(q{
1301            select canonical from %s
1302            }, $class->_attributes_table
1303        )
1304    );
1305    $sth->execute();
1306    my @attrs = ();
1307
1308    while (my $res = $sth->fetchrow_hashref) {
1309        push(@attrs, $res->{canonical});
1310    }
1311    return @attrs;
1312}
1313
1314
1315=head2 get_attribute_comment $base, $attribute)
1316
1317Return comment for C<$attribute>
1318
1319=cut
1320
1321# TODO: get_attribute_comment($attr, $base) { $base ||= $self->base ...
1322
1323sub get_attribute_comment {
1324    my ($class, $base, $attribute) = @_;
1325    $base->attribute($class->type, $attribute) or do {
1326        $base->log(LA_ERR, "The attribute $attribute does not exists");
1327        return;
1328    };
1329    my $sth = $base->db->prepare(
1330        sprintf(q{
1331            select description from %s
1332            where canonical = ?
1333            }, $class->_attributes_table)
1334    );
1335    $sth->execute($attribute);
1336    if (my $res = $sth->fetchrow_hashref) {
1337        $sth->finish;
1338        return $res->{description};
1339    } else {
1340        return;
1341    }
1342}
1343
1344=head2 set_attribute_comment ($base, $attribute, $comment)
1345
1346Set comment to attribute
1347
1348=cut
1349
1350sub set_attribute_comment {
1351    my ($class, $base, $attribute, $comment) = @_;
1352
1353    my $attr = $base->attribute($class->type, $attribute) or do {
1354        $base->log(LA_ERR, "The attribute $attribute does not exists");
1355        return;
1356    };
1357    $attr->{inline} and do {
1358        $base->log(LA_ERR,
1359            "Cannot set comment to inline attribute, sorry, blame the author !"
1360        );
1361        return;
1362    };
1363    my $sth = $base->db->prepare(
1364        sprintf(q{
1365            update %s set description = ?
1366            where canonical = ?
1367            }, $class->_attributes_table)
1368    );
1369    my $res = $sth->execute($comment, $attribute);
1370}
1371
1372sub _update_aliases_ptr {
1373    my ($self) = @_;
1374
1375    my $atype = $self->type;
1376    my $name  = $self->id;
1377    my $base  = $self->base;
1378
1379    foreach my $otype ($base->list_supported_objects) {
1380        foreach my $attr ($base->list_canonical_fields($otype, 'r')) {
1381            $attr =~ /^(oalias|modifiedby|createdby)$/ and next;
1382            my $attribute = $base->attribute($otype, $attr);
1383            my $ref = $attribute->reference or next;
1384
1385            if ($ref eq $atype) {
1386                $base->log(LA_DEBUG, "Searching object referencing alias %s/%s in %s->%s",
1387                    $atype, $name, $otype, $attr);
1388                foreach my $target ($base->search_objects($otype, "$attr\=$name", 'oalias=NULL')) {
1389                    $base->log(LA_DEBUG, "Update ref for object %s/%s", $otype, $target);
1390                    my $otarget = $base->get_object($otype, $target) or next;
1391                    $otarget->refreshRev;
1392                    if ($otype eq 'group' && grep { $_ eq 'dpmt' } $otarget->_get_attributes('sutype')) {
1393                        $otarget->_update_employment_manager;
1394                    }
1395                }
1396            }
1397        }
1398    }
1399}
1400
1401sub _update_aliases_cache {
1402    my ($self) = @_;
1403
1404    my $getoalias = $self->base->db->prepare(
1405        sprintf(
1406            q{ select * from %s where %s = ? },
1407            $self->base->db->quote_identifier($self->_object_table),
1408            $self->base->db->quote_identifier($self->_key_field),
1409        )
1410    );
1411    $getoalias->execute($self->id);
1412    my $res = $getoalias->fetchrow_hashref or do {
1413        $self->base->log(LA_ERR, "Cannot find alias %s / %s", $self->type, $self->id);
1414        return;
1415    };
1416    $getoalias->finish;
1417
1418    my $ref = $self->base->_derefObject($self->type, $res->{oalias});
1419    my $id = $ref ? $ref->id : undef;
1420
1421    if (($id || '') ne ($res->{oaliascache} || '')) {
1422        my $upd = $self->base->db->prepare(
1423            sprintf(
1424                q{update %s set oaliascache = ? where %s = ?},
1425                $self->base->db->quote_identifier($self->_object_table),
1426                $self->base->db->quote_identifier($self->_key_field),
1427            )
1428        );
1429        $self->base->log(LA_DEBUG, "Updating Cache for alias %s => %s", $self->id, $id || '(none)');
1430        return $upd->execute($id, $self->id);
1431    }
1432}
1433
1434sub ReportChange {
1435    my ($self, $changetype, $message, @args) = @_;
1436
1437    $self->base->ReportChange(
1438        $self->type,
1439        $self->id,
1440        $self->Iid,
1441        $changetype, $message, @args
1442    )
1443}
1444
1445
14461;
1447
1448__END__
1449
1450=head1 SEE ALSO
1451
1452L<LATMOS::Accounts::Bases::Sql>
1453
1454L<LATMOS::Accounts::Bases::Objects>
1455
1456=head1 AUTHOR
1457
1458Olivier Thauvin, E<lt>olivier.thauvin@latmos.ipsl.frE<gt>
1459
1460=head1 COPYRIGHT AND LICENSE
1461
1462Copyright (C) 2008, 2009 CNRS SA/CETP/LATMOS
1463
1464This library is free software; you can redistribute it and/or modify
1465it under the same terms as Perl itself, either Perl version 5.10.0 or,
1466at your option, any later version of Perl 5 you may have available.
1467
1468
1469=cut
Note: See TracBrowser for help on using the repository browser.