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

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

Always create internal at db load

  • Property svn:keywords set to Id Rev
File size: 28.0 KB
Line 
1package LATMOS::Accounts::Bases::Sql;
2
3use 5.010000;
4use strict;
5use warnings;
6
7use base qw(LATMOS::Accounts::Bases);
8use LATMOS::Accounts::Log;
9use DBI;
10use Crypt::RSA;
11use Crypt::RSA::Key::Public::SSH;
12use Crypt::RSA::Key::Private::SSH;
13use Crypt::RSA::Key::Public;
14use Crypt::RSA::Key::Private;
15use Crypt::Blowfish;
16use MIME::Base64;
17
18our $VERSION = (q$Rev: 2149 $ =~ /^Rev: (\d+) /)[0];
19
20sub SCHEMA_VERSION { 28 };
21
22=head1 NAME
23
24LATMOS::Ad - Perl extension for blah blah blah
25
26=head1 SYNOPSIS
27
28  use LATMOS::Accounts::Bases;
29  my $base = LATMOS::Accounts::Bases->new('unix');
30  ...
31
32=head1 DESCRIPTION
33
34Account base access over standard unix file format.
35
36=head1 FUNCTIONS
37
38=cut
39
40=head2 SCHEMA_VERSION
41
42Return the SQL schema version to use for this software version.
43
44=head2 new(%config)
45
46Create a new LATMOS::Ad object for windows AD $domain.
47
48domain / server: either the Ad domain or directly the server
49
50ldap_args is an optionnal list of arguments to pass to L<Net::LDAP>.
51
52=cut
53
54sub new {
55    my ($class, %config) = @_;
56   
57    my $base = {
58        db_conn => $config{db_conn},
59    };
60
61    bless($base, $class);
62}
63
64sub DESTROY {
65    my ($self) = @_;
66    $self->{_db} && $self->{_db}->rollback;
67}
68
69=head2 db
70
71Return a L<DBI> handle over database, load it if need.
72
73=cut
74
75sub db {
76    my ($self) = @_;
77
78    if ($self->{_db} && $self->{_db}->ping) {
79        return $self->{_db};
80    } else {
81        $self->{_db} = DBI->connect_cached(
82            'dbi:Pg:' . $self->{db_conn},
83            undef, undef,
84            {
85                RaiseError => 0,
86                AutoCommit => 0,
87                PrintWarn => 1,
88                PrintError => 1,
89                ($self->config('no_pg_utf8') ? (pg_enable_utf8 => 0) : ()),
90            }
91        ) or do {
92            $self->log(LA_ERR, "Cannot connect to database: %s", $DBI::errstr);   
93            return;
94        };
95        $self->{_db}->do(q{set DATESTYLE to 'DMY'});
96        $self->log(LA_DEBUG, 'New connection to DB');
97
98        {
99            my $sv = $self->get_global_value('schema_version') || 1;
100            if ($sv < SCHEMA_VERSION) {
101                require LATMOS::Accounts::Bases::Sql::upgrade;
102                if ($self->SchemaUpgrade()) {
103                    $self->commit;
104                } else {
105                    $self->rollback;
106                    return;
107                }
108            }
109        }
110
111        foreach my $otype ($self->list_supported_objects) {
112            my %attrlist = map { $_ => 1 } $self->list_registered_attributes($otype);
113            foreach my $attribute ($self->list_canonical_fields($otype, 'r')) {
114                my $attr = $self->attribute($otype, $attribute);
115                $attr->{inline} and next;
116                $attr->{managed} and next;
117
118                if ($attrlist{$attribute}) {
119                } else {
120                    if($self->register_attribute($otype, $attribute, $attr->{comment})) {
121                        $self->log(LA_NOTICE, "Attr. $attribute for object type $otype registred");
122                    } else {
123                        $self->log(LA_ERR, "Can't register attribute $attribute");
124                        $self->{_db}->rollback;
125                        return;
126                    }
127                }
128            }
129        }
130
131        $self->{_db}->commit;
132        return $self->{_db};
133    }
134}
135
136=head2 load
137
138Read file and load data into memory
139
140=cut
141
142sub load {
143    my ($self) = @_;
144    if (!$self->db) { return 0 };
145
146    my $sv = $self->get_global_value('schema_version') || 1;
147    if ($sv < SCHEMA_VERSION) {
148        $self->log(LA_CRIT,
149            "Schema version %d found, %d is need, please update db using " .
150            "`la-sql-upgrade' tool for `%s' base",
151            $sv,
152            SCHEMA_VERSION,
153            $self->label,
154        );
155        # return;
156    }
157    $self->_CreateInternalObjects;
158
159    1;
160}
161
162sub _CreateInternalObjects {
163    my ($self) = @_;
164
165    my $dbi = $self->{_db};
166
167    my @objects = (
168        {
169            name => 'dpmt',
170            otype => 'sutype',
171            attrs => {
172                description => 'Department',
173            },
174        },
175        {
176            name => 'contrattype',
177            otype => 'sutype',
178            attrs => {
179                description => 'Contract',
180            },
181        },
182        {
183            name => '-useralias',
184            otype => 'group',
185            attrs => {
186                description => 'Internal group for user alias object',
187                gidnumber => -1,
188                unexported => 1,
189            },
190            intern => 1,
191        },
192    );
193
194    $self->temp_switch_unexported( sub {
195
196            my $setnodel  = $dbi->prepare('UPDATE objects SET nodelete     = true where name = ?');
197            my $setintern = $dbi->prepare('UPDATE objects SET internobject = true where name = ?');
198
199            foreach (@objects) {
200                if (!$self->GetRawObject($_->{otype}, $_->{name})) {
201                    printf("Creating object %s/%s\n", $_->{otype}, $_->{name});
202                    $self->create_object($_->{otype}, $_->{name}, %{$_->{attrs} || {}})
203                        or warn sprintf("cannot create %s/%s\n", $_->{otype}, $_->{name});
204
205                }
206
207                $setnodel->execute($_->{name});
208                $setintern->execute($_->{name}) if ($_->{intern});
209            }
210
211    }, 1);
212    $self->commit;
213
214    return 1;
215}
216
217=head2 ListInternalObjects($otype)
218
219List objects flags as internal for type C<$otype>
220
221=cut
222
223sub ListInternalObjects {
224    my ($self, $otype) = @_;
225
226    my $pclass = $self->_load_obj_class($otype) or return;
227
228    # Object Alias: checking if object is alias, then returning it:
229    my $sth = $self->db->prepare_cached(
230        sprintf(q{select %s as k from %s where and internobject = true},
231            $self->db->quote_identifier($pclass->_key_field),
232            $self->db->quote_identifier($pclass->_object_table),
233        ),
234    );
235    $sth->execute();
236    my @list;
237    while (my $res = $sth->fetchrow_hashref) {
238       push(@list, $_->{k});
239   }
240   return(@list);
241}
242
243=head2 GetRawObject($otype, $id)
244
245Return an object even it is internal, alias are not follow and even
246unexported object are returned
247
248This function must be used only for maintenance operation.
249
250=cut
251
252sub GetRawObject {
253    my ($self, $otype, $id) = @_;
254
255    my $pclass = $self->_load_obj_class($otype) or return;
256
257    return $self->SUPER::get_object($otype, $id);
258}
259
260sub _derefObject {
261    my ($self, $otype, $oalias) = @_;
262    $oalias or return;
263    if (my ($aliasotype, $aliasoname, $aliasattr) = $oalias =~ m/^([^\/]+)\.([^\.]+)\.(.*)$/) {
264        my $attribute = $self->attribute($aliasotype, $aliasattr) or do {
265            $self->log(LA_DEBUG, "Oalias %s (%s): can fetch attibute %s/%s",
266                $otype, $oalias, $aliasotype, $aliasattr);
267            return;
268        };
269        my $refotype = $attribute->reference or do {
270            $self->log(LA_DEBUG, "Oalias %s (%s): Attribute does not reference an object",
271                $otype, $oalias);
272            return;
273        };
274        $refotype eq $otype or do {
275            $self->log(LA_DEBUG, "Oalias %s (%s): Attribute does not reference same object type",
276                $otype, $oalias, $refotype);
277            return;
278        };
279        my $robj = $self->get_object($aliasotype, $aliasoname) or do {
280            $self->log(LA_DEBUG, "Oalias %s (%s): can fetch object %s/%s",
281                $otype, $oalias, $aliasotype, $aliasoname);
282            return;
283        };
284        my $rvalue = $robj->get_attributes($aliasattr) or do {
285            $self->log(LA_DEBUG, "Oalias %s (%s): attribute value is empty",
286                $otype, $oalias);
287            return;
288        };
289        return $self->get_object($refotype, $rvalue);
290    } else {
291        return $self->get_object($otype, $oalias);
292    }
293}
294
295sub get_object {
296    my ($self, $otype, $id) = @_;
297
298    my $pclass = $self->_load_obj_class($otype) or return;
299
300    # Object Alias: checking if object is alias, then returning it:
301    my $sth = $self->db->prepare_cached(
302        sprintf(q{select oalias from %s where %s = ? and internobject = false %s},
303            $self->db->quote_identifier($pclass->_object_table),
304            $self->db->quote_identifier($pclass->_key_field),
305            ($self->{wexported} ? '' : 'and exported = true'),
306        ),
307    );
308    $sth->execute($id);
309    my $res = $sth->fetchrow_hashref;
310    $sth->finish;
311    if (my $oalias = $res->{oalias}) {
312        # Cross reference over object/attribute
313        $self->_derefObject($otype, $oalias);
314    } else {
315        return $self->SUPER::get_object($otype, $id);
316    }
317}
318
319=head2 getObjectFromOKey ($okey)
320
321Return the object from the db internal key
322
323=cut
324
325sub getObjectFromOKey {
326    my ($self, $okey) = @_;
327
328    my $findobj = $self->{_db}->prepare_cached(q{
329        select * from objects_table where ikey = ?
330    });
331
332    $findobj->execute($okey);
333
334    my $res = $findobj->fetchrow_hashref;
335    $findobj->finish;
336
337    if ($res) {
338        return $self->get_object($res->{relname}, $res->{name});
339    } else {
340        return;
341    }
342}
343
344sub _sync_dyn_group {
345    my ($self) = @_;
346
347    my @groups = $self->search_objects('group', 'autoMemberFilter=*');
348
349    my $res = 0;
350    foreach (@groups) {
351        my $g = $self->get_object('group', $_) or next;
352        $res += $g->populate_dyn_group;
353    }
354
355    $self->log(LA_DEBUG, "Group Dyn res %d", $res);
356    $res
357}
358
359sub _sync_dyn_aliases {
360    my ($self) = @_;
361
362    my @groups = $self->search_objects('aliases', 'autoMemberFilter=*');
363
364    my $res = 0;
365    foreach (@groups) {
366        my $g = $self->get_object('aliases', $_) or next;
367        $res += $g->populate_dyn_aliases;
368    }
369
370    $self->log(LA_DEBUG, "Aliases Dyn res %d", $res);
371    $res
372}
373
374=head2 PopulateDynData
375
376Recomputate dynamics attributes (autoMembersFilters) if need
377
378=cut
379
380sub PopulateDynData {
381    my ($self) = @_;
382
383    $self->temp_switch_unexported(sub {
384
385        foreach (1 .. 5) {
386            $self->log(LA_DEBUG, "%d loop for PopulateDynData", $_);
387            my $res = 0;
388            $res += $self->_sync_dyn_group   || 0;
389            $res += $self->_sync_dyn_aliases || 0;
390
391            if ($res == 0) {
392                last;
393            }
394        }
395
396    }, 0);
397
398    return 1;
399}
400
401sub _commit {
402    my ($self) = @_;
403
404    $self->PopulateDynData;
405
406    if ($ENV{LA_NO_COMMIT}) {
407        $self->log(LA_DEBUG, 'DB::COMMIT (ignore due to LA_NO_COMMIT)');
408        return 1;
409    } else {
410        $self->log(LA_DEBUG, 'DB::COMMIT');
411    }
412    $self->{__cache} = undef;
413    $self->db->commit;
414}
415
416sub _rollback {
417    my ($self) = @_;
418    if ($ENV{LA_NO_COMMIT}) {
419        $self->log(LA_DEBUG, 'DB::ROLLBACK (ignore due to LA_NO_COMMIT)');
420        return 1
421    } else {
422        $self->log(LA_DEBUG, 'DB::ROLLBACK');
423    }
424    $self->{__cache} = undef;
425    $self->db->rollback;
426}
427
428sub list_supported_objects {
429    my ($self, @otype) = @_;
430    $self->SUPER::list_supported_objects(qw(site), @otype);
431}
432
433# For SQL listRealObjects != list_objects
434sub listRealObjects {
435    my ($self, $otype) = @_;
436    my $pclass = $self->_load_obj_class($otype) or return;
437    $pclass->listReal($self);
438}
439
440sub current_rev {
441    my ($self) = @_;
442    my $sth = $self->db->prepare_cached(
443        q{select max(rev) from revisions}
444    );
445    $sth->execute;
446    my $res = $sth->fetchrow_hashref;
447    $sth->finish;
448    return ($res->{max});
449} 
450
451sub authenticate_user {
452    my ($self, $username, $passwd) = @_;
453    $username or return;
454    my $uobj = $self->get_object('user', $username) or do {
455        la_log(LA_ERR, "Cannot authenticate non existing SQL user $username");
456        return;
457    };
458
459    if ($self->attribute('user', 'exported')) {
460        if (!$uobj->_get_c_field('exported')) {
461            la_log(LA_ERR, "User $username found but currently unexported");
462            return;
463        }
464    }
465
466    $self->SUPER::authenticate_user($username, $passwd);
467}
468
469=head1 SPECIFICS FUNCTIONS
470
471=head2 GetAlias($base, $id)
472
473Return object having id C<$id> only if it is an object alias
474
475=cut
476
477sub GetAlias {
478    my ($self, $otype, $id) = @_;
479
480    my $pclass = $self->_load_obj_class($otype) or return;
481
482    # Object Alias: checking if object is alias, then returning it:
483    my $sth = $self->db->prepare_cached(
484        sprintf(q{select oalias from %s where %s = ? and oalias IS NOT NULL and internobject = false %s},
485            $self->db->quote_identifier($pclass->_object_table),
486            $self->db->quote_identifier($pclass->_key_field),
487            ($self->{wexported} ? '' : 'and exported = true'),
488        ),
489    );
490    $sth->execute($id);
491    my $res = $sth->fetchrow_hashref;
492    $sth->finish;
493    if ($res) {
494        return $self->SUPER::get_object($otype, $id);
495    } else {
496        return;
497    }
498}
499
500=head2 CreateAlias($otype, $name, $for)
501
502Create an object alias named C<$name> for ovbject C<$for>
503
504=cut
505
506sub CreateAlias {
507    my ($self, $otype, $name, $for) = @_;
508
509    my $pclass = $self->_load_obj_class($otype) or return;
510
511    $for or die "Cannot create alias without giving object to point";
512
513    my $res = $pclass->CreateAlias($self, $name, $for);
514
515    if ($res) {
516        $self->ReportChange(
517            $otype,
518            $name,
519            $pclass->_get_ikey($self, $name),
520            'Create', "Alias %s %s => %s", $otype, $name, $for
521        );
522        $self->log(LA_DEBUG, "Alias $otype $name => $for created");
523        my $oalias = $self->GetAlias($otype, $name);
524        $oalias->_update_aliases_ptr();
525        return 1;
526    } else {
527        $self->log(LA_ERR, "Error when creating alias $otype $name");
528        return;
529    }
530}
531
532=head2 RenameAlias($otype, $name, $to)
533
534Rename an object alias
535
536=cut
537
538sub RenameAlias {
539    my ($self, $otype, $name, $to) = @_;
540
541    my $pclass = $self->_load_obj_class($otype) or return;
542
543    my $obj = $self->GetAlias($otype, $name) or do {
544        $self->log('Cannot get alias %s/%s for removal', $otype, $name);
545        return;
546    };
547
548    my $sth = $self->db->prepare_cached(sprintf(
549        'UPDATE %s SET %s = ? WHERE %s = ?',
550        $self->db->quote_identifier($pclass->_key_field),
551        $self->db->quote_identifier($pclass->_object_table),
552        $self->db->quote_identifier($pclass->_key_field),
553    ));
554
555    my $res = $sth->execute($to, $name);
556
557    return $res;
558}
559
560=head2 RemoveAlias($otype, $name, $for)
561
562Create an object alias named C<$name> for ovbject C<$for>
563
564=cut
565
566sub RemoveAlias {
567    my ($self, $otype, $name) = @_;
568
569    my $pclass = $self->_load_obj_class($otype) or return;
570
571    my $obj = $self->GetAlias($otype, $name) or do {
572        $self->log('Cannot get alias %s/%s for removal', $otype, $name);
573        return;
574    };
575
576    if ($obj->_get_attributes('internobject')) {
577        # Cannot happend: internal are not fetchable
578        $self->log(LA_ERR,'Cannot delete %s/%s: is an internal object', $pclass->type, $name);
579        return;
580    }
581    if ($obj->_get_attributes('nodelete')) {
582        $self->log(LA_ERR,'Cannot delete %s/%s: is write protected', $pclass->type, $name);
583        return;
584    }
585
586    my $id = $obj->Iid;
587
588    my $sth = $self->db->prepare_cached(sprintf(
589        'DELETE FROM %s WHERE %s = ?',
590        $self->db->quote_identifier($pclass->_object_table),
591        $self->db->quote_identifier($pclass->_key_field),
592    ));
593
594    $obj->_update_aliases_ptr;
595    my $res = $sth->execute($name);
596
597    if ($res) {
598        $self->ReportChange(
599            $otype,
600            $name,
601            $id,
602            'Delete', "Alias %s %s deleted", $otype, $name
603        );
604        $self->log(LA_DEBUG, "Alias $otype $name removed");
605        return 1;
606    } else {
607        $self->log(LA_ERR, "Error when removing alias $otype $name");
608        return;
609    }
610}
611
612=head2 get_global_value ($varname)
613
614Return global value set into base
615
616=cut
617
618sub get_global_value {
619    my ($self, $varname) = @_;
620
621    my $sth = $self->db->prepare_cached(q{
622        select val from settings where varname = ?
623        });
624    $sth->execute($varname);
625    my $res = $sth->fetchrow_hashref;
626    $sth->finish;
627    $res->{val}
628}
629
630=head2 set_global_value ($varname, $value)
631
632Set global value.
633
634=cut
635
636sub set_global_value {
637    my ($self, $varname, $value) = @_;
638    my $sth = $self->db->prepare(q{
639        update settings set val = ? where varname = ?
640        });
641    $sth->execute($value, $varname) == 0 and do {
642        my $sth2 = $self->db->prepare(q{
643            insert into settings (val, varname) values (?,?)
644            });
645        $sth2->execute($value, $varname);
646    };
647}
648
649=head2 del_global_value ($varname)
650
651Delete global value from base
652
653=cut
654
655sub del_global_value {
656    my ($self, $varname) = @_;
657
658    my $sth = $self->db->prepare_cached(q{
659        delete from settings where varname = ?
660        });
661    return $sth->execute($varname);
662}
663
664=head2 generate_rsa_key ($password)
665
666Return public and private peer rsa keys
667
668=cut
669
670sub generate_rsa_key {
671    my ($self, $password) = @_;
672
673    my $rsa = new Crypt::RSA ES => 'PKCS1v15';
674    my ($public, $private) = $rsa->keygen (
675        Identity  => 'LATMOS-Accounts',
676        Size      => 2048,
677        Password  => $password,
678        Verbosity => 0,
679    ) or die $rsa->errstr(); # TODO avoid die
680    return ($public, $private);
681}
682
683=head2 private_key ($password)
684
685Load and return private rsa key
686
687=cut
688
689sub private_key {
690    my ($self, $password) = @_;
691    my $base = $self;
692    my $serialize = $base->get_global_value('rsa_private_key') or return;
693    my $string = decode_base64($serialize);
694    my $privkey = $string =~ /^SSH PRIVATE KEY FILE/
695        ? Crypt::RSA::Key::Private::SSH->new
696        : Crypt::RSA::Key::Private->new;
697    $privkey = $privkey->deserialize(
698        String => [ $string ],
699        Password => $password
700    );
701    $privkey->reveal( Password => $password );
702    $privkey;
703}
704
705=head2 get_rsa_password
706
707Return hash with peer username => encryptedPassword
708
709=cut
710
711sub get_rsa_password {
712    my ($self) = @_;
713    my $base = $self;
714    my $sth = $base->db->prepare(q{
715        select "name", value from "user" join user_attributes_base
716        on "user".ikey = user_attributes_base.okey
717        where user_attributes_base.attr = 'encryptedPassword'
718    });
719    $sth->execute;
720    my %users;
721    while (my $res = $sth->fetchrow_hashref) {
722        $users{$res->{name}} = $res->{value};
723    }
724    %users
725}
726
727=head2 store_rsa_key ($public, $private)
728
729Store public and private RSA key info data base
730
731=cut
732
733sub store_rsa_key {
734    my ($self, $public, $private) = @_;
735    my $base = $self;
736    $private->hide;
737    $base->set_global_value('rsa_private_key',
738        encode_base64($private->serialize));
739    $base->set_global_value('rsa_public_key',
740        $public->serialize);
741    return;
742}
743
744=head2 find_next_expire_users ($expire)
745
746Search user expiring in C<$expire> delay
747
748=cut
749
750sub find_next_expire_users {
751    my ($self, $expire) = @_;
752
753    my $sth= $self->db->prepare(q{
754        select name from "user" where
755            expire < now() + ?::interval
756            and expire > now()
757            and expire is not null
758            and internobject = false
759            } . ($self->{wexported} ? '' : 'and exported = true') . q{
760            order by expire
761        }
762    );
763    $sth->execute($expire || '1 month');
764    my @users;
765    while (my $res = $sth->fetchrow_hashref) {
766        push(@users, $res->{name});
767    }
768    @users
769}
770
771=head2 find_expired_users ($expire)
772
773Return list of user going to expires in C<$expire> delay
774
775=cut
776
777sub find_expired_users {
778    my ($self, $expire) = @_;
779
780    my $sth= $self->db->prepare(q{
781        select name from "user" where
782            expire < now() - ?::interval
783            and expire is not null
784            and internobject = false
785        } . ($self->{wexported} ? '' : 'and exported = true') . q{
786            order by expire
787        }
788    );
789    $sth->execute($expire || '1 second');
790    my @users;
791    while (my $res = $sth->fetchrow_hashref) {
792        push(@users, $res->{name});
793    }
794    @users
795}
796
797=head2 rename_nethost ($nethostname, $to, %config)
798
799Facility function to rename computer to new name
800
801=cut
802
803sub rename_nethost {
804    my ($self, $nethostname, $to, %config) = @_;
805    {
806        my $obj = $self->get_object('nethost', $nethostname) or do {
807            $self->log(LA_ERR, 'Unable to rename non exisant host %s', $nethostname);
808            return;
809        };
810        $obj->_delAttributeValue(cname => $to);
811    }
812    $self->rename_object('nethost', $nethostname, $to) or return;
813    if ($config{'addcname'}) {
814        my $obj = $self->get_object('nethost', $to);
815        $obj->_addAttributeValue(cname => $nethostname);
816    }
817    return 1;
818}
819
820=head2 nethost_exchange_ip ($ip1, $ip2)
821
822Exchange ip1 with ip2 in base
823
824=cut
825
826sub nethost_exchange_ip {
827    my ($self, $ip1, $ip2) = @_;
828    my ($obj1, $obj2);
829    if (my ($host1) = $self->search_objects('nethost', "ip=$ip1")) {
830        $obj1 = $self->get_object('nethost', $host1);
831    } else {
832        $self->log(LA_ERR, "Cannot find host having $ip1");
833        return;
834    }
835    if (my ($host2) = $self->search_objects('nethost', "ip=$ip2")) {
836        $obj2 = $self->get_object('nethost', $host2);
837    } else {
838        $self->log(LA_ERR, "Cannot find host having $ip2");
839        return;
840    }
841    if ($obj1->id eq $obj2->id) {
842        $self->log(LA_ERR, "Both ip belong to same host (%s)", $obj1->id);
843        return;
844    }
845
846    $self->log(LA_NOTICE, "Exchanging IP between %s and %s", $obj1->id, $obj2->id);
847    $obj1->delAttributeValue('ip', $ip1) ;
848    $obj2->delAttributeValue('ip', $ip2) ;
849    $obj1->addAttributeValue('ip', $ip2) ;
850    $obj2->addAttributeValue('ip', $ip1) ;
851    return 1;
852}
853
854=head1 ATTRIBUTES FUNCTIONS
855
856=cut
857
858sub obj_attr_allowed_values {
859    my ($self, $otype, $attr) = @_;
860    if (my @values = $self->SUPER::obj_attr_allowed_values("$otype.$attr", 'allowed')) {
861        return @values;
862    } else {
863        $self->ListAttrValue($otype, $attr);
864    }
865}
866
867=head2 ListAttrValue($otype, $attribute)
868
869List values allow for an attribute set into SQL database
870
871=cut
872
873sub ListAttrValue {
874    my ($self, $otype, $attr) = @_;
875
876    my @sqlvalues;
877    my $getAllow = $self->db->prepare_cached(q{
878        SELECT * FROM attributes_values WHERE otype = ? AND attributes = ?
879        ORDER BY "value"
880    });
881    $getAllow->execute($otype, $attr);
882    while (my $res = $getAllow->fetchrow_hashref) {
883        push(@sqlvalues, $res->{value});
884    }
885    return @sqlvalues;
886}
887
888=head2 AddAttrValue($otype, $attr, @values)
889
890Add given values to allowed attribute list
891
892=cut
893
894sub AddAttrValue {
895    my ($self, $otype, $attr, @values) = @_;
896   
897    my $addAllow = $self->db->prepare_cached(q{
898        INSERT INTO attributes_values (otype, attributes, "value") values (?,?,?)
899    });
900   
901    foreach my $value (@values) {
902        if ($addAllow->execute($otype, $attr, $value)) {
903        } else {
904            $self->rollback;
905            return;
906        }
907    }
908
909    return 1;
910}
911
912=head2 DelAttrValue
913
914Delete a
915
916=cut
917
918sub DelAttrValue {
919    my ($self, $otype, $attr, @values) = @_;
920
921    if (@values) {
922        my $delAllow = $self->db->prepare_cached(q{
923            DELETE FROM attributes_values WHERE otype = ? and attributes = ? and "value" = ?
924        });
925
926        foreach my $value (@values) {
927
928            if ($delAllow->execute($otype, $attr, $value)) {
929            } else {
930                $self->rollback;
931                return;
932            }
933
934        }
935        return 1;
936    } else {
937        my $delAllow = $self->db->prepare_cached(q{
938            DELETE FROM attributes_values WHERE otype = ? and attributes = ?
939        });
940        if ($delAllow->execute($otype, $attr)) {
941            return 1;
942        } else {
943            $self->rollback;
944            return;
945        }
946    }
947}
948
949=head2 register_attribute ($otype, $attribute, $comment)
950
951Register a new attribute in base
952
953=cut
954
955sub register_attribute {
956    my ($self, $otype, $attribute, $comment) = @_;
957    my $pclass = $self->_load_obj_class($otype) or return;
958    $pclass->register_attribute($self, $attribute, $comment);
959}
960
961=head2 is_registered_attribute ($otype, $attribute)
962
963Return true is attribute already exists
964
965=cut
966
967sub is_registered_attribute {
968    my ($self, $otype, $attribute) = @_;
969    my $pclass = $self->_load_obj_class($otype) or return;
970    $pclass->is_registered_attribute($self, $attribute);
971}
972
973=head2 list_registered_attributes ($otype)
974
975List all regiestered attribute
976
977=cut
978
979sub list_registered_attributes {
980    my ($self, $otype) = @_;
981    my $pclass = $self->_load_obj_class($otype) or return;
982    if ($pclass->_has_extended_attributes) {
983        return $pclass->list_registered_attributes($self);
984    } else {
985        return ();
986    }
987}
988
989=head2 get_attribute_comment ($otype, $attribute)
990
991Return the comment associated to attribute
992
993=cut
994
995sub get_attribute_comment {
996    my ($self, $otype, $attribute) = @_;
997    my $pclass = $self->_load_obj_class($otype) or return;
998    $pclass->get_attribute_comment($self, $attribute);
999}
1000
1001=head2 set_attribute_comment ($otype, $attribute, $comment)
1002
1003Set comment to attribute
1004
1005=cut
1006
1007sub set_attribute_comment {
1008    my ($self, $otype, $attribute, $comment) = @_;
1009    my $pclass = $self->_load_obj_class($otype) or return;
1010    $pclass->set_attribute_comment($self, $attribute, $comment);
1011}
1012
1013=head2 getEmploymentRange
1014
1015Return date range within employment can be found in database
1016
1017=cut
1018
1019sub getEmploymentRange {
1020    my ($self, @filters) = @_;
1021
1022    my ($min,$max);
1023
1024    if (@filters) {
1025        my @flist = $self->search_objects('employment', @filters);
1026        my $minSql = $self->db->prepare(q{
1027            SELECT min(firstday) as min FROM employment
1028            WHERE name = ANY (?)
1029        });
1030        $minSql->execute(\@flist);
1031        if (my $res = $minSql->fetchrow_hashref) {
1032            $min = $res->{min}
1033        }
1034        my $maxSql = $self->db->prepare(q{
1035            SELECT max(lastday) as max FROM employment
1036            WHERE name = ANY (?)
1037        });
1038        $maxSql->execute(\@flist);
1039        if (my $res = $maxSql->fetchrow_hashref) {
1040            $max = $res->{max}
1041        }
1042    } else {
1043        my $minSql = $self->db->prepare(q{
1044            SELECT min(firstday) as min FROM employment
1045        });
1046        $minSql->execute;
1047        if (my $res = $minSql->fetchrow_hashref) {
1048            $min = $res->{min}
1049        }
1050        my $maxSql = $self->db->prepare(q{
1051            SELECT max(lastday) as max FROM employment
1052        });
1053        $maxSql->execute;
1054        if (my $res = $maxSql->fetchrow_hashref) {
1055            $max = $res->{max}
1056        }
1057    }
1058
1059    return ($min,$max);
1060}
1061
1062sub ReportChange {
1063    my ($self, $otype, $name, $ref, $changetype, $message, @args) = @_;
1064
1065    my $sthmodifiedby = $self->db->prepare(q{
1066        UPDATE objects set modifiedby = ? where ikey = ?
1067    });
1068
1069    $sthmodifiedby->execute(
1070        $self->user || '@Console',
1071        $ref,
1072    );
1073
1074    my $sth = $self->db->prepare(q{
1075        INSERT into objectslogs (ikey, irev, otype, name, changetype, username, message)
1076        VALUES (?,?,?,?,?,?,?)
1077        });
1078
1079    $sth->execute(
1080        $ref,
1081        $self->current_rev,
1082        $otype,
1083        $name,
1084        $changetype,
1085        $self->user || '@Console',
1086        sprintf($message, @args),
1087    );
1088}
1089
1090=head2 getobjectlogs($otype, $name)
1091
1092Return logs for object type C<$otype> having C<$name>.
1093
1094=cut 
1095
1096sub getobjectlogs {
1097    my ($self, $otype, $name) = @_;
1098
1099    my $sth = $self->db->prepare(q{
1100        select ikey from objectslogs where
1101            otype = ? and
1102            name  = ?
1103        group by ikey
1104    });
1105    $sth->execute($otype, $name);
1106    my @ids;
1107    while (my $res = $sth->fetchrow_hashref) {
1108        push(@ids, $res->{ikey});
1109    }
1110    @ids or return;
1111
1112    my $sth2 = $self->db->prepare(sprintf(
1113        q{
1114            select * from objectslogs where ikey IN (%s)
1115            order by logdate asc
1116        },
1117        join(',', ('?') x scalar(@ids))
1118    ));
1119
1120    $sth2->execute(@ids);
1121    my @logs;
1122    while (my $res = $sth2->fetchrow_hashref) {
1123        push(@logs, $res);
1124    }
1125
1126    return @logs;
1127}
1128
1129=head2 getlogs
1130
1131Return logs for last year
1132
1133=cut
1134
1135sub getlogs {
1136    my ($self) = @_;
1137    my $sth2 = $self->db->prepare(
1138        q{
1139            select * from objectslogs
1140            where logdate > now() - '1 year'::interval
1141            order by logdate asc
1142        },
1143    );
1144
1145    $sth2->execute();
1146    my @logs;
1147    while (my $res = $sth2->fetchrow_hashref) {
1148        push(@logs, $res);
1149    }
1150
1151    return @logs;
1152}
1153
1154
11551;
1156
1157__END__
1158
1159=head1 SEE ALSO
1160
1161=head1 AUTHOR
1162
1163Olivier Thauvin, E<lt>olivier.thauvin@latmos.ipsl.frE<gt>
1164
1165=head1 COPYRIGHT AND LICENSE
1166
1167Copyright (C) 2008, 2009 CNRS SA/CETP/LATMOS
1168
1169This library is free software; you can redistribute it and/or modify
1170it under the same terms as Perl itself, either Perl version 5.10.0 or,
1171at your option, any later version of Perl 5 you may have available.
1172
1173
1174=cut
Note: See TracBrowser for help on using the repository browser.