Ignore:
Timestamp:
12/21/16 15:07:28 (8 years ago)
Author:
nanardon
Message:

Merge branch

Location:
trunk/LATMOS-Accounts/lib/LATMOS/Accounts
Files:
14 edited

Legend:

Unmodified
Added
Removed

  • trunk/LATMOS-Accounts/lib/LATMOS/Accounts/Acls/Acl.pm

    r1048 r1865  
    100100        # any user 
    101101        } elsif ($u->{user} eq '*' || $u->{user} eq $who) { 
     102            # TODO deference alias for SQL base 
     103            # $obj->base->get_objects(...) ? 
    102104            return $u->{$perm} if (defined($u->{$perm})); 
    103105        # any authenticated user 

  • trunk/LATMOS-Accounts/lib/LATMOS/Accounts/Bases.pm

    r1839 r1865  
    278278} 
    279279 
    280 =head2 list_objects($otype) 
     280=head2 list_objects($otype, %options) 
    281281 
    282282Return the list of UID for object of $otype. 
    … …  
    290290} 
    291291 
     292=head2 listRealObjects 
     293 
     294Return the list of UID for object of $otype, alias objects are not return 
     295 
     296Options depend of database support 
     297 
     298=cut 
     299 
     300sub listRealObjects { 
     301    my ($self, $otype) = @_; 
     302    $self->list_objects($otype); 
     303} 
     304 
    292305=head2 get_object($type, $id) 
    293306 
    … …  
    300313    my ($self, $otype, $id) = @_; 
    301314 
    302     return LATMOS::Accounts::Bases::Objects->_new($self, $otype, $id); 
     315    # finding perl class: 
     316    my $pclass = $self->_load_obj_class($otype) or return; 
     317    my $newobj = "$pclass"->new($self, $id); 
     318 
     319    defined($newobj) or do { 
     320        $self->log(LA_DEBUG, "$pclass->new() returned undef for $otype / %s", $id || '(none)'); 
     321        return; 
     322    }; 
     323 
     324    $newobj->{_base} = $self; 
     325    $newobj->{_type} = lc($otype); 
     326    $newobj->{_id} ||= $id; 
     327 
     328    return $newobj; 
    303329} 
    304330 
    … …  
    411437    } else { 
    412438        my $last = LATMOS::Accounts::Log::lastmessage(LA_ERR); 
    413         warn $last; 
    414439        la_log(LA_ERR, 
    415440            'Object creation %s (%s) in base %s (%s) failed%s', 
    … …  
    906931            } 
    907932        } 
    908         $data{$_} = $srcobj->_get_c_field($_); 
     933        $data{$_} = $srcobj->GetAttributeValue($_); 
    909934    } 
    910935    if (my $dstobj = $self->get_object($srcobj->type, $srcobj->id)) { 

  • trunk/LATMOS-Accounts/lib/LATMOS/Accounts/Bases/Attributes.pm

    r1839 r1865  
    261261    } 
    262262 
     263    if (ref $values eq 'ARRAY' && ! $self->multiple) { 
     264        $self->base->log(LA_WARN, 'Attribute %s is not multi valuesd', $self->name); 
     265        # TODO: really return an error 
     266        # return; 
     267    } 
     268 
     269    if ($self->{checkinput}) { 
     270        foreach my $val (ref $values ? @{ $values } : $values) { 
     271            if (!$self->{checkinput}->($val)) { 
     272                return; 
     273            } 
     274        } 
     275        return 1; 
     276    } 
     277 
    263278    if ($self->has_values_list && $values) { 
    264279        my @possible = $self->can_values; 
    … …  
    281296    } 
    282297 
    283     if (ref $values eq 'ARRAY' && ! $self->multiple) { 
    284         $self->base->log(LA_WARN, 'Attribute %s is not multi valuesd', $self->name); 
    285         # TODO: really return an error 
    286         # return; 
    287     } 
    288  
    289     if ($self->{checkinput}) { 
    290         foreach my $val (ref $values ? @{ $values } : $values) { 
    291             if (!$self->{checkinput}->($val)) { 
    292                 return; 
    293             } 
    294         } 
    295     } 
    296298 
    297299    return 1; 

  • trunk/LATMOS-Accounts/lib/LATMOS/Accounts/Bases/Ldap/Group.pm

    r1120 r1865  
    100100    while (my ($f, $val) = each(%data)) { 
    101101        $f eq 'memberUID' and do { 
     102            $val = [ $val ] unless(ref $val); 
    102103            my %users; 
    103104            $users{$_}{e} = 1 foreach (@{ $self->get_field('memberUID') || []}); 

  • trunk/LATMOS-Accounts/lib/LATMOS/Accounts/Bases/Ldap/User.pm

    r1706 r1865  
    232232                ? $self->get_attributes('memberOf') 
    233233                : ()); 
     234            $val = [ $val ] unless(ref $val); 
    234235            $users{$_}{n} = 1 foreach (@{ $val || []}); 
    235236            foreach (keys %users) { 

  • trunk/LATMOS-Accounts/lib/LATMOS/Accounts/Bases/Objects.pm

    r1840 r1865  
    4545 
    4646=cut 
     47 
     48=head2 listReal($base) 
     49 
     50List object supported by this module existing in base $base 
     51 
     52Can be override by base driver. The result must exclude specials object such alias. 
     53 
     54=cut 
     55 
     56sub listReal { 
     57    my ($class, $base) = @_; 
     58    $class->list($base); 
     59} 
    4760 
    4861=head2 list_from_rev($base, $rev) 
    … …  
    6881} 
    6982 
    70 # _new($base, $type, $id, ...) 
    71  
    72 # Return a new object of type $type having unique identifier 
    73 # $id, all remaining arguments are passed to the subclass. 
    74  
    75 sub _new { 
    76     my ($class, $base, $otype, $id, @args) = @_; 
    77  
    78     # finding perl class: 
    79     my $pclass = $base->_load_obj_class($otype) or return; 
    80     my $newobj = "$pclass"->new($base, $id, @args); 
    81  
    82     defined($newobj) or do { 
    83         $base->log(LA_DEBUG, "$pclass->new() returned undef for $otype / %s", $id || '(none)'); 
    84         return; 
    85     }; 
    86  
    87     $newobj->{_base} = $base; 
    88     $newobj->{_type} = lc($otype); 
    89     $newobj->{_id} ||= $id; 
    90  
    91     return $newobj; 
    92 } 
    93  
    9483=head2 _create($class, $base, $id, %data) 
    9584 
    … …  
    265254} 
    266255 
    267 =head2 get_state ($state) 
    268  
    269 Return an on fly computed value 
    270  
    271 =cut 
    272  
    273 sub get_state { 
    274     my ($self, $state) = @_; 
    275     # hum... 
    276     if (defined(my $res = $self->_get_state($state))) { 
    277         return $res; 
    278     } 
    279     for ($state) { 
    280     } 
    281     return; 
    282 } 
    283  
    284 sub _get_state { 
    285     my ($self, $state) = @_; 
    286     return; 
    287 } 
    288  
    289256sub _get_c_field { 
    290257    my ($self, $cfield) = @_; 
    … …  
    299266    return $attribute->get;  
    300267} 
     268 
     269=head2 GetAttributeValue($cfield) 
     270 
     271Return the value to exposed to other base 
     272 
     273=cut 
     274 
     275sub GetAttributeValue { 
     276    my ($self, $cfield) = @_; 
     277 
     278    return $self->get_c_field($cfield); 
     279} 
     280 
    301281 
    302282=head2 queryformat ($fmt) 

  • trunk/LATMOS-Accounts/lib/LATMOS/Accounts/Bases/Sql.pm

    r1843 r1865  
    147147} 
    148148 
     149=head2 ListInternalObjects($otype) 
     150 
     151List objects flags as internal for type C<$otype> 
     152 
     153=cut 
     154 
     155sub ListInternalObjects { 
     156    my ($self, $otype) = @_; 
     157 
     158    my $pclass = $self->_load_obj_class($otype) or return; 
     159 
     160    # Object Alias: checking if object is alias, then returning it: 
     161    my $sth = $self->db->prepare_cached( 
     162        sprintf(q{select %s as k from %s where and internobject = true}, 
     163            $self->db->quote_identifier($pclass->_key_field), 
     164            $self->db->quote_identifier($pclass->_object_table), 
     165        ), 
     166    ); 
     167    $sth->execute(); 
     168    my @list; 
     169    while (my $res = $sth->fetchrow_hashref) { 
     170       push(@list, $_->{k}); 
     171   } 
     172   return(@list); 
     173} 
     174 
     175=head2 GetRawObject($otype, $id) 
     176 
     177Return an object even it is internal, alias are not follow and even 
     178unexported object are returned 
     179 
     180This function must be used only for maintenance operation. 
     181 
     182=cut 
     183 
     184sub GetRawObject { 
     185    my ($self, $otype, $id) = @_; 
     186 
     187    my $pclass = $self->_load_obj_class($otype) or return; 
     188 
     189    return $self->SUPER::get_object($otype, $id); 
     190} 
     191 
     192sub _derefObject { 
     193    my ($self, $otype, $oalias) = @_; 
     194    if (my ($aliasotype, $aliasoname, $aliasattr) = $oalias =~ m/^([^\/]+)\.([^\.]+)\.(.*)$/) { 
     195        my $attribute = $self->attribute($aliasotype, $aliasattr) or do { 
     196            $self->log(LA_DEBUG, "Oalias %s (%s): can fetch attibute %s/%s", 
     197                $otype, $oalias, $aliasotype, $aliasattr); 
     198            return; 
     199        }; 
     200        my $refotype = $attribute->reference or do { 
     201            $self->log(LA_DEBUG, "Oalias %s (%s): Attribute does not reference an object", 
     202                $otype, $oalias); 
     203            return; 
     204        }; 
     205        my $robj = $self->get_object($aliasotype, $aliasoname) or do { 
     206            $self->log(LA_DEBUG, "Oalias %s (%s): can fetch object %s/%s", 
     207                $otype, $oalias, $aliasotype, $aliasoname); 
     208            return; 
     209        }; 
     210        my $rvalue = $robj->get_attributes($aliasattr) or do { 
     211            $self->log(LA_DEBUG, "Oalias %s (%s): attribute value is empty", 
     212                $otype, $oalias); 
     213            return; 
     214        }; 
     215        return $self->get_object($refotype, $rvalue); 
     216    } else { 
     217        return $self->get_object($otype, $oalias); 
     218    } 
     219} 
     220 
     221sub get_object { 
     222    my ($self, $otype, $id) = @_; 
     223 
     224    my $pclass = $self->_load_obj_class($otype) or return; 
     225 
     226    # Object Alias: checking if object is alias, then returning it: 
     227    my $sth = $self->db->prepare_cached( 
     228        sprintf(q{select oalias from %s where %s = ? and internobject = false %s}, 
     229            $self->db->quote_identifier($pclass->_object_table), 
     230            $self->db->quote_identifier($pclass->_key_field), 
     231            ($self->{wexported} ? '' : 'and exported = true'), 
     232        ), 
     233    ); 
     234    $sth->execute($id); 
     235    my $res = $sth->fetchrow_hashref; 
     236    $sth->finish; 
     237    if (my $oalias = $res->{oalias}) { 
     238        # Cross reference over object/attribute 
     239        $self->_derefObject($otype, $oalias); 
     240    } else { 
     241        return $self->SUPER::get_object($otype, $id); 
     242    } 
     243} 
     244 
    149245=head2 getObjectFromOKey ($okey) 
    150246 
    … …  
    255351    my ($self, @otype) = @_; 
    256352    $self->SUPER::list_supported_objects(qw(site), @otype); 
     353} 
     354 
     355# For SQL listRealObjects != list_objects 
     356sub listRealObjects { 
     357    my ($self, $otype) = @_; 
     358    my $pclass = $self->_load_obj_class($otype) or return; 
     359    $pclass->listReal($self); 
    257360} 
    258361 
    … …  
    287390 
    288391=head1 SPECIFICS FUNCTIONS 
     392 
     393=head2 GetAlias($base, $id) 
     394 
     395Return object having id C<$id> only if it is an object alias 
     396 
     397=cut 
     398 
     399sub GetAlias { 
     400    my ($self, $otype, $id) = @_; 
     401 
     402    my $pclass = $self->_load_obj_class($otype) or return; 
     403 
     404    # Object Alias: checking if object is alias, then returning it: 
     405    my $sth = $self->db->prepare_cached( 
     406        sprintf(q{select oalias from %s where %s = ? and oalias IS NOT NULL and internobject = false %s}, 
     407            $self->db->quote_identifier($pclass->_object_table), 
     408            $self->db->quote_identifier($pclass->_key_field), 
     409            ($self->{wexported} ? '' : 'and exported = true'), 
     410        ), 
     411    ); 
     412    $sth->execute($id); 
     413    my $res = $sth->fetchrow_hashref; 
     414    $sth->finish; 
     415    if ($res) { 
     416        return $self->SUPER::get_object($otype, $id); 
     417    } else { 
     418        return; 
     419    } 
     420} 
     421 
     422=head2 CreateAlias($otype, $name, $for) 
     423 
     424Create an object alias named C<$name> for ovbject C<$for> 
     425 
     426=cut 
     427 
     428sub CreateAlias { 
     429    my ($self, $otype, $name, $for) = @_; 
     430 
     431    my $pclass = $self->_load_obj_class($otype) or return; 
     432 
     433    $for or die "Cannot create alias without giving object to point"; 
     434 
     435    my $res = $pclass->CreateAlias($self, $name, $for); 
     436 
     437    if ($res) { 
     438        $self->ReportChange( 
     439            $otype, 
     440            $name, 
     441            $pclass->_get_ikey($self, $name), 
     442            'Create', "Alias %s %s => %s", $otype, $name, $for 
     443        ); 
     444        $self->log(LA_DEBUG, "Alias $otype $name => $for created"); 
     445        return 1; 
     446    } else { 
     447        $self->log(LA_ERR, "Error when creating alias $otype $name"); 
     448        return; 
     449    } 
     450} 
     451 
     452=head2 RemoveAlias($otype, $name, $for) 
     453 
     454Create an object alias named C<$name> for ovbject C<$for> 
     455 
     456=cut 
     457 
     458sub RemoveAlias { 
     459    my ($self, $otype, $name) = @_; 
     460 
     461    my $pclass = $self->_load_obj_class($otype) or return; 
     462 
     463    my $obj = $self->GetAlias($otype, $name) or do { 
     464        $self->log('Cannot get alias %s/%s for removal', $otype, $name); 
     465        return; 
     466    }; 
     467 
     468    if ($obj->_get_attributes('internobject')) { 
     469        # Cannot happend: internal are not fetchable 
     470        $self->log(LA_ERR,'Cannot delete %s/%s: is an internal object', $pclass->type, $name); 
     471        return; 
     472    } 
     473    if ($obj->_get_attributes('nodelete')) { 
     474        $self->log(LA_ERR,'Cannot delete %s/%s: is write protected', $pclass->type, $name); 
     475        return; 
     476    } 
     477 
     478    my $id = $obj->Iid; 
     479 
     480    my $sth = $self->db->prepare_cached(sprintf( 
     481        'DELETE FROM %s WHERE %s = ?', 
     482        $self->db->quote_identifier($pclass->_object_table), 
     483        $self->db->quote_identifier($pclass->_key_field), 
     484    )); 
     485 
     486    my $res = $sth->execute($name); 
     487 
     488    if ($res) { 
     489        $self->ReportChange( 
     490            $otype, 
     491            $name, 
     492            $id, 
     493            'Delete', "Alias %s %s deleted", $otype, $name 
     494        ); 
     495        $self->log(LA_DEBUG, "Alias $otype $name removed"); 
     496        return 1; 
     497    } else { 
     498        $self->log(LA_ERR, "Error when removing alias $otype $name"); 
     499        return; 
     500    } 
     501} 
    289502 
    290503=head2 get_global_value ($varname) 
    … …  
    419632            and expire > now() 
    420633            and expire is not null 
     634            and internobject = false 
    421635            } . ($self->{wexported} ? '' : 'and exported = true') . q{ 
    422636            order by expire 
    … …  
    444658            expire < now() - ?::interval 
    445659            and expire is not null 
     660            and internobject = false 
    446661        } . ($self->{wexported} ? '' : 'and exported = true') . q{ 
    447662            order by expire 

  • trunk/LATMOS-Accounts/lib/LATMOS/Accounts/Bases/Sql/Address.pm

    r1613 r1865  
    324324                label => l('Description'), 
    325325            }, 
     326            expire    => { 
     327                inline => 1, 
     328                formtype => 'DATE', 
     329                label => l('Expire'), 
     330            }, 
    326331        } 
    327332    ); 

  • trunk/LATMOS-Accounts/lib/LATMOS/Accounts/Bases/Sql/User.pm

    r1863 r1865  
    508508                        select name from "group" join 
    509509                        group_attributes on group_attributes.okey = "group".ikey 
    510                         where value = ? and attr = ? 
     510                        where value = ? and attr = ? and internobject = false 
    511511                        } . ($self->base->{wexported} ? '' : ' and "group".exported = true') 
    512512                    ); 
    … …  
    558558                    my ($self) = @_; 
    559559                    my $sth = $self->base->db->prepare(q{ 
    560                         select forward from aliases where name = ? 
     560                        select forward from aliases where name = ? and internobject = false 
    561561                        } . ($self->base->{wexported} ? '' : ' and exported = true')); 
    562562                    $sth->execute($self->object->id); 
    … …  
    609609                    my ($self) = @_; 
    610610                    my $sth = $self->base->db->prepare(q{ 
    611                         select name from aliases where lower($1) = 
     611                        select name from aliases where internobject = false and lower($1) = 
    612612                        lower(array_to_string("forward", ',')) 
    613613                        } . ($self->base->{wexported} ? '' : 'and exported = true')); 
    … …  
    13481348            /^never$/ and return 0; 
    13491349 
    1350             !$_[0] and return 0; 
     1350            $_[0] or return 0; 
    13511351 
    13521352            /^any$/i and return $_[0]->listEmployment ? 1 : 0; 
    … …  
    13891389 
    13901390    $class->SUPER::_get_attr_schema($base, $attrs) 
     1391} 
     1392 
     1393sub CreateAlias { 
     1394    my ($class, $base, $name, $for) = @_; 
     1395 
     1396    my $stAddAlias = $base->db->prepare_cached( 
     1397        q{INSERT INTO "user" (name, uidnumber,            gidnumber, oalias) values 
     1398                             (?,    -nextval('ikey_seq'), ?,         ?)} 
     1399    ); 
     1400 
     1401    my $res = $stAddAlias->execute($name, -1, $for); 
     1402    return $res ? 1 : 0; 
    13911403} 
    13921404 

  • trunk/LATMOS-Accounts/lib/LATMOS/Accounts/Bases/Sql/objects.pm

    r1823 r1865  
    2222sub _attributes_table { $_[0]->_object_table . '_attributes_list' } 
    2323 
    24 sub list { 
     24sub listReal { 
    2525    my ($class, $base) = @_; 
    2626 
    2727    my $sth = $base->db->prepare_cached( 
    2828        sprintf( 
    29             q{select %s as k from %s %s order by %s}, 
     29            q{select %s as k from %s where internobject = false 
     30                and oalias IS NULL %s order by %s}, 
    3031            $base->db->quote_identifier($class->_key_field), 
    3132            $base->db->quote_identifier($class->_object_table), 
    32             ($base->{wexported} ? '' : 'where exported = true'), 
     33            ($base->{wexported} ? '' : 'and exported = true'), 
    3334            $base->db->quote_identifier($class->_key_field), 
    3435        ) 
    … …  
    4243} 
    4344 
     45sub list { 
     46    my ($class, $base) = @_; 
     47 
     48    my $sth = $base->db->prepare_cached( 
     49        sprintf( 
     50            q{select %s as k from %s where internobject = false %s order by %s}, 
     51            $base->db->quote_identifier($class->_key_field), 
     52            $base->db->quote_identifier($class->_object_table), 
     53            ($base->{wexported} ? '' : 'and exported = true'), 
     54            $base->db->quote_identifier($class->_key_field), 
     55        ) 
     56    ); 
     57    $sth->execute; 
     58    my @keys; 
     59    while(my $res = $sth->fetchrow_hashref) { 
     60        push(@keys, $res->{k}); 
     61    } 
     62    @keys 
     63} 
     64 
    4465sub list_from_rev { 
    4566    my ($class, $base, $rev) = @_; 
    4667    my $sth = $base->db->prepare_cached( 
    4768        sprintf( 
    48             q{select %s as k from %s where rev > ? %s order by %s}, 
     69            q{select %s as k from %s where rev > ? and internobject = false 
     70                and oalias IS NULL  %s order by %s}, 
    4971            $base->db->quote_identifier($class->_key_field), 
    5072            $base->db->quote_identifier($class->_object_table), 
    … …  
    135157            label => l('Created by'), 
    136158        }, 
     159        oalias => { 
     160            inline  => 1, 
     161            reference => $class->type, 
     162            label => 'Alias for', 
     163            post => sub { 
     164                my ($self, $value) = @_; 
     165                $self->object->_update_aliases_ptr(); 
     166            }, 
     167            checkinput => sub { 
     168                my ($oalias) = @_; 
     169                my $otype = $class->type; 
     170 
     171                if (my ($aliasotype, $aliasoname, $aliasattr) = $oalias =~ m/^([^\/]+)\.([^\.]+)\.(.*)$/) { 
     172                    my $attribute = $base->attribute($aliasotype, $aliasattr) or do { 
     173                        $base->log(LA_DEBUG, "Oalias %s (%s): can fetch attibute %s/%s", 
     174                            $otype, $oalias, $aliasotype, $aliasattr); 
     175                        return; 
     176                    }; 
     177                    my $refotype = $attribute->reference or do { 
     178                        $base->log(LA_DEBUG, "Oalias %s (%s): Attribute does not reference an object", 
     179                            $otype, $oalias); 
     180                        return; 
     181                    }; 
     182 
     183                    if ($attribute->multiple) { 
     184                        $base->log(LA_DEBUG, "Oalias %s (%s): Attribute must not be multiple", 
     185                            $otype, $oalias); 
     186                        return; 
     187                    }; 
     188                } elsif(!$base->get_object($otype, $oalias)) { 
     189                    $base->log(LA_DEBUG, "Cannot get object $otype/$oalias"); 
     190                    return; 
     191                } 
     192                return 1; 
     193            }, 
     194        }, 
     195        internobject => { 
     196            inline  => 1, 
     197            label => 'True if object is for internal use', 
     198            hide => 1, 
     199        }, 
     200        nodelete => { 
     201            inline => 1, 
     202            label => 'True if the object is protected against deletion', 
     203            hide => 1, 
     204        }, 
    137205    ); 
    138206 
    … …  
    161229        } 
    162230        foreach (@{$base->{__cache}{$class->_object_table}{extend}}) { 
    163             $base->log(LA_DEBUG, 'Attribute %s for %s not declared in code', $_, $class->type) if(!exists($info->{$_})); 
     231            #$base->log(LA_DEBUG, 'Attribute %s for %s not declared in code', $_, $class->type) if(!exists($info->{$_})); 
    164232            $info->{$_} ||= {}; 
    165233        } 
    … …  
    185253 
    186254        my $sth = $base->db->prepare_cached( 
    187             sprintf(q{select 1 from %s where %s = ? %s}, 
     255            sprintf(q{ select 1 from %s where %s = ?}, 
    188256                $base->db->quote_identifier($class->_object_table), 
    189257                $base->db->quote_identifier($class->_key_field), 
    190                 ($base->{wexported} ? '' : 'and exported = true'), 
    191258            ), 
    192259        ); 
    … …  
    288355} 
    289356 
     357=head2 refreshRev 
     358 
     359Increase revision of the object to force synchronisation 
     360 
     361=cut 
     362 
     363sub refreshRev { 
     364    my ($self) = @_; 
     365 
     366    my $sth = $self->db->prepare_cached( 
     367        sprintf(q{ 
     368                UPDATE %s SET rev = nextval('revisions_rev_seq'::regclass)  WHERE %s = ? 
     369            }, 
     370            $self->db->quote_identifier($self->_object_table), 
     371            $self->db->quote_identifier($self->_key_field), 
     372        ) 
     373    ); 
     374    $sth->execute($self->id); 
     375} 
     376 
     377=head2 CreateAlias($base, $name, $for) 
     378 
     379Create an alias named C<$name> with pointing to C<$for> 
     380 
     381=cut 
     382 
     383sub CreateAlias { 
     384    my ($class, $base, $name, $for) = @_; 
     385 
     386    $base->log(LA_ERR, '%s does not support alias object, alias %s not created', $class->type, $name); 
     387} 
     388 
    290389sub _delete { 
    291390    my ($class, $base, $id) = @_; 
    … …  
    295394    my $obj = $base->get_object($class->type, $id) 
    296395        or return; 
     396 
     397    if ($obj->_get_attributes('internobject')) { 
     398        # Cannot happend: internal are not fetchable 
     399        $base->log(LA_ERR,'Cannot delete %s/%s: is an internal object', $class->type, $id); 
     400        return; 
     401    } 
     402    if ($obj->_get_attributes('nodelete')) { 
     403        $base->log(LA_ERR,'Cannot delete %s/%s: is write protected', $class->type, $id); 
     404        return; 
     405    } 
    297406 
    298407    my $sthd = $base->db->prepare_cached( 
    … …  
    411520        my $val = $__cache->{$self->id}{$field}; 
    412521        return @{$val || []} > 1 ? $val : $val->[0]; 
     522    } 
     523} 
     524 
     525sub GetAttributeValue { 
     526    my ($self, $cfield) = @_; 
     527 
     528    my $res = $self->SUPER::GetAttributeValue($cfield) or return; 
     529 
     530    my $attribute = $self->attribute($cfield) or do { 
     531        $self->base->log(LA_WARN, "Unknow attribute $cfield"); 
     532        return; 
     533    }; 
     534 
     535    if (my $ref = $attribute->reference) { 
     536        my @deref; 
     537        foreach my $v (ref $res ? @{ $res } : $res) { 
     538            my $derefobj = $self->base->_derefObject($ref, $v); 
     539            push(@deref, $derefobj ? $derefobj->id : $v); 
     540        } 
     541        return scalar(@deref) > 1 ? \@deref : $deref[0]; 
     542    } else { 
     543        return $res; 
    413544    } 
    414545} 
    … …  
    588719} 
    589720 
     721=head2 SetNoDelete($value) 
     722 
     723Set nodelete attribute to true or false 
     724 
     725=cut 
     726 
     727sub SetNoDelete { 
     728    my ($self, $value) = @_; 
     729 
     730    my $sthr = $self->db->prepare_cached( 
     731        sprintf( 
     732            q{update %s set nodelete = ? where %s = ?}, 
     733            $self->db->quote_identifier($self->_object_table), 
     734            $self->db->quote_identifier($self->_key_field), 
     735        ) 
     736    ); 
     737 
     738    if (($sthr->execute($value ? 'true' : 'false', $self->id) || 0) != 1) { 
     739        $self->log(LA_ERR, "Erreur seting nodelete for %s/%s to %s", 
     740            $self->type, 
     741            $self->id, 
     742            $value, 
     743        ); 
     744        return; 
     745    } 
     746 
     747    1; 
     748} 
     749 
    590750=head2 find_next_numeric_id($class, $base, $field, $min, $max) 
    591751 
    … …  
    644804        $attr->{inline} 
    645805            ? sprintf( 
    646                 q{select %s as value from %s} . ($base->{wexported} ? '' : ' and "exported" = true'), 
     806                q{select %s as value from %s where internobject = false} . ($base->{wexported} ? '' : ' and "exported" = true'), 
    647807                $base->db->quote_identifier($attr->iname), 
    648808                $base->db->quote_identifier($class->_object_table), 
    … …  
    650810            : sprintf( 
    651811                q{select value from %s join 
    652                 %s on %s.ikey = %s.okey where attr = ? group by value} . ($base->{wexported} ? '' : ' and "exported" = true'), 
     812                %s on %s.ikey = %s.okey where attr = ? and internobject = false group by value} .  
     813                    ($base->{wexported} ? '' : ' and "exported" = true'), 
    653814                $base->db->quote_identifier($class->_object_table), 
    654815                $base->db->quote_identifier($class->_object_table . 
    … …  
    756917    # foo=1 bar=1 => foo =1 and bar = 2 
    757918    my $results = {}; 
     919    my $noalias = 0; 
    758920 
    759921    @filter = grep { defined($_) && $_ ne '' } @filter; 
    … …  
    776938            return; 
    777939        }; 
     940        $attribute->name eq 'oalias' and $noalias = 1; 
    778941        defined($val) or $val =  ''; 
    779942 
    … …  
    822985    } 
    823986 
     987    # We add to result aliases: 
     988    if(keys %mresults && !$noalias) { 
     989        my @alias = $class->_search_uniq_filter($base, 'oalias', '=', join('||', keys %mresults)); 
     990        foreach(@alias) { 
     991            $mresults{$_} = 1; 
     992        } 
     993    } 
     994 
    824995    return(sort keys %mresults); 
    825996} 
    826  
    827997 
    828998sub _search_uniq_filter { 
    … …  
    8381008 
    8391009    my @values = split(/([\|\&]+)/, $value); 
     1010    return unless(@values); 
     1011 
     1012    $base->log(LA_DEBUG, "Uniq search for $attr $operator (%s)", join(' ', @values)); 
    8401013     
    8411014    # We detect if we can do a very quick search: 
    … …  
    9401113    # building the query 
    9411114    if (!$base->{wexported}) { 
    942         push(@attrsql, 'intersect', sprintf( 
    943                 q{select ikey from %s where exported = true}, 
     1115        push(@attrsql, 'intersect') if (@attrsql); 
     1116        push(@attrsql, sprintf( 
     1117                q{select ikey from %s where exported = true and internobject = false}, 
    9441118                $base->db->quote_identifier($class->_object_table) 
    9451119            ) 
    … …  
    9491123        sprintf(q{ 
    9501124            select name from %s 
     1125            where internobject = false 
    9511126            %s 
    9521127            order by name 
    … …  
    9541129            $base->db->quote_identifier($class->_object_table), 
    9551130            @attrsql 
    956             ? "where ikey in (\n" . join(" ", @attrsql) . ")\n" 
     1131            ? "and ikey in (\n" . join(" ", @attrsql) . ")\n" 
    9571132            : '', 
    9581133        ) 
    … …  
    10651240} 
    10661241 
     1242sub _update_aliases_ptr { 
     1243    my ($self) = @_; 
     1244 
     1245    my $atype = $self->type; 
     1246    my $name  = $self->id; 
     1247    my $base  = $self->base; 
     1248 
     1249    foreach my $otype ($base->list_supported_objects) { 
     1250        foreach my $attr ($base->list_canonical_fields($otype, 'r')) { 
     1251            $attr =~ /^(oalias|modifiedby|createdby)$/ and next; 
     1252            my $attribute = $base->attribute($otype, $attr); 
     1253            my $ref = $attribute->reference or next; 
     1254 
     1255            if ($ref eq $atype) { 
     1256                $base->log(LA_DEBUG, "Searching object referencing alias %s/%s in %s->%s", 
     1257                    $atype, $name, $otype, $attr); 
     1258                foreach my $target ($base->search_objects($otype, "$attr\=$name", 'oalias=NULL')) { 
     1259                    $base->log(LA_DEBUG, "Update ref for object %s/%s", $otype, $target); 
     1260                    my $otarget = $base->get_object($otype, $target) or next; 
     1261                    $otarget->refreshRev; 
     1262                } 
     1263            } 
     1264        } 
     1265    } 
     1266} 
     1267 
    106712681; 
    10681269 

  • trunk/LATMOS-Accounts/lib/LATMOS/Accounts/Cli.pm

    r1313 r1865  
    731731        ); 
    732732    } 
     733    if ($labase->can('CreateAlias')) { 
     734        $env->add_func( 
     735            'newalias', { 
     736                help => 'Create an alias object', 
     737                code => sub { 
     738                    my ($self, $otype, $name, $for) = @_; 
     739                    if ($self->base->CreateAlias($otype, $name, $for)) { 
     740                        print $OUT "Alias $otype/$name Created\n"; 
     741                        $self->commit; 
     742                    } 
     743                }, 
     744                completion => sub { 
     745                    if ($_[3]) { 
     746                        return $_[0]->base->list_objects($_[2]); 
     747                    } elsif (!$_[2]) { 
     748                        return $_[0]->base->list_supported_objects; 
     749                    } else { 
     750                        return; 
     751                    } 
     752                } 
     753            }, 
     754        ); 
     755        $env->add_func( 
     756            'rmalias', { 
     757                help => 'Remove an alias object', 
     758                code => sub { 
     759                    my ($self, $otype, $name) = @_; 
     760                    if ($self->base->RemoveAlias($otype, $name)) { 
     761                        print $OUT "Alias $otype/$name Removed\n"; 
     762                        $self->commit; 
     763                    } 
     764                }, 
     765                completion => sub { 
     766                    if (!$_[2]) { 
     767                        return $_[0]->base->list_supported_objects; 
     768                    } else { 
     769                        return $_[0]->base->search_objects($_[2], 'oalias=*'); 
     770                    } 
     771                } 
     772            }, 
     773        ); 
     774        $env->add_func( 
     775            'updalias', { 
     776                help => 'Update an alias object', 
     777                code => sub { 
     778                    my ($self, $otype, $name, $for) = @_; 
     779                    my $obj = $self->base->GetAlias($otype, $name) or do { 
     780                        print $OUT "No alias $otype/$name found"; 
     781                        return; 
     782                    }; 
     783                    if ($obj->set_c_fields(oalias => $for)) { 
     784                        print $OUT "Alias $otype/$name Updated\n"; 
     785                        $self->commit; 
     786                    } 
     787                }, 
     788                completion => sub { 
     789                    if ($_[3]) { 
     790                        return $_[0]->base->list_objects($_[2]); 
     791                    } elsif($_[2]) { 
     792                        return $_[0]->base->search_objects($_[2], 'oalias=*'); 
     793                    } else { 
     794                        return $_[0]->base->list_supported_objects; 
     795                    } 
     796                } 
     797            }, 
     798        ); 
     799    } 
    733800    $env->add_func('quit', { help => 'quit - exit the tool', 
    734801            code => sub { print "\n"; exit(0) }, }); 

  • trunk/LATMOS-Accounts/lib/LATMOS/Accounts/Log.pm

    r1698 r1865  
    173173    my ($level, $msg, @args) = @_; 
    174174    no warnings 'printf'; 
     175 
    175176    if (!$msg) { 
     177        # Wrong la_log usage 
    176178        my @call = caller(); 
    177179        la_log(LA_WARN, 'empty message at %s:%s', $call[1], $call[2]); 
    178180        return; 
    179181    } 
     182    if ($level =~ /\D/) { 
     183        # Wrong la_log usage 
     184        my @call = caller(); 
     185        la_log(LA_WARN, 'unrecognize message level %s at %s:%s', $level, $call[1], $call[2]); 
     186        return; 
     187    } 
     188 
    180189    $lastmessages{$level} = sprintf($msg, map { defined($_) ? $_ : '' } @args); 
    181190    if ($log_method{syslog}) { 

  • trunk/LATMOS-Accounts/lib/LATMOS/Accounts/Synchro.pm

    r1805 r1865  
    286286 
    287287            $existings{$otype} = { map { $_ => 1 } 
    288                 $self->from->list_objects($otype) }; 
     288                $self->from->listRealObjects($otype) }; 
    289289 
    290290            # Is there a filter to apply: 
    … …  
    293293                la_log(LA_DEBUG, "Found %s param, using it: %s", $filtername, $filter); 
    294294                $filtering{$otype} = { map { $_ => 1 } 
    295                     $self->from->search_objects($otype, $filter) }; 
     295                    $self->from->search_objects($otype, $filter, 'oalias=NULL') }; 
    296296            } else { 
    297297                $filtering{$otype} = $existings{$otype}; 
    … …  
    319319            my $deletefiltered = 'deletefiltered.' . $destbase->label . '.' . $otype; 
    320320 
    321             foreach ($destbase->list_objects($otype)) { 
     321            foreach ($destbase->listRealObjects($otype)) { 
    322322 
    323323                if ($filtering{$otype}{$_}) { 

  • trunk/LATMOS-Accounts/lib/LATMOS/Accounts/Task/Unexportexpired.pm

    r1801 r1865  
    4848    my $nowtext = $now->iso8601(); 
    4949 
    50     foreach my $otype (qw(Aliases Nethost)) { 
     50    foreach my $otype (qw(Aliases Nethost Address)) { 
    5151 
    5252        foreach my $name ( 
Note: See TracChangeset for help on using the changeset viewer.