Changeset 1865 for trunk/LATMOS-Accounts/lib/LATMOS/Accounts/Bases/Sql.pm

Timestamp:

12/21/16 15:07:28 (8 years ago)

Author:

nanardon

Message:

Merge branch

File:

• trunk/LATMOS-Accounts/lib/LATMOS/Accounts/Bases/Sql.pm (modified) (5 diffs)

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

@@ -147 +147 @@
 }
 
+=head2 ListInternalObjects($otype)
+
+List objects flags as internal for type C<$otype>
+
+=cut
+
+sub ListInternalObjects {
+    my ($self, $otype) = @_;
+
+    my $pclass = $self->_load_obj_class($otype) or return;
+
+    # Object Alias: checking if object is alias, then returning it:
+    my $sth = $self->db->prepare_cached(
+        sprintf(q{select %s as k from %s where and internobject = true},
+            $self->db->quote_identifier($pclass->_key_field),
+            $self->db->quote_identifier($pclass->_object_table),
+        ),
+    );
+    $sth->execute();
+    my @list;
+    while (my $res = $sth->fetchrow_hashref) {
+       push(@list, $_->{k});
+   }
+   return(@list);
+}
+
+=head2 GetRawObject($otype, $id)
+
+Return an object even it is internal, alias are not follow and even
+unexported object are returned
+
+This function must be used only for maintenance operation.
+
+=cut
+
+sub GetRawObject {
+    my ($self, $otype, $id) = @_;
+
+    my $pclass = $self->_load_obj_class($otype) or return;
+
+    return $self->SUPER::get_object($otype, $id);
+}
+
+sub _derefObject {
+    my ($self, $otype, $oalias) = @_;
+    if (my ($aliasotype, $aliasoname, $aliasattr) = $oalias =~ m/^([^\/]+)\.([^\.]+)\.(.*)$/) {
+        my $attribute = $self->attribute($aliasotype, $aliasattr) or do {
+            $self->log(LA_DEBUG, "Oalias %s (%s): can fetch attibute %s/%s",
+                $otype, $oalias, $aliasotype, $aliasattr);
+            return;
+        };
+        my $refotype = $attribute->reference or do {
+            $self->log(LA_DEBUG, "Oalias %s (%s): Attribute does not reference an object",
+                $otype, $oalias);
+            return;
+        };
+        my $robj = $self->get_object($aliasotype, $aliasoname) or do {
+            $self->log(LA_DEBUG, "Oalias %s (%s): can fetch object %s/%s",
+                $otype, $oalias, $aliasotype, $aliasoname);
+            return;
+        };
+        my $rvalue = $robj->get_attributes($aliasattr) or do {
+            $self->log(LA_DEBUG, "Oalias %s (%s): attribute value is empty",
+                $otype, $oalias);
+            return;
+        };
+        return $self->get_object($refotype, $rvalue);
+    } else {
+        return $self->get_object($otype, $oalias);
+    }
+}
+
+sub get_object {
+    my ($self, $otype, $id) = @_;
+
+    my $pclass = $self->_load_obj_class($otype) or return;
+
+    # Object Alias: checking if object is alias, then returning it:
+    my $sth = $self->db->prepare_cached(
+        sprintf(q{select oalias from %s where %s = ? and internobject = false %s},
+            $self->db->quote_identifier($pclass->_object_table),
+            $self->db->quote_identifier($pclass->_key_field),
+            ($self->{wexported} ? '' : 'and exported = true'),
+        ),
+    );
+    $sth->execute($id);
+    my $res = $sth->fetchrow_hashref;
+    $sth->finish;
+    if (my $oalias = $res->{oalias}) {
+        # Cross reference over object/attribute
+        $self->_derefObject($otype, $oalias);
+    } else {
+        return $self->SUPER::get_object($otype, $id);
+    }
+}
+
 =head2 getObjectFromOKey ($okey)
 
@@ -255 +351 @@
     my ($self, @otype) = @_;
     $self->SUPER::list_supported_objects(qw(site), @otype);
+}
+
+# For SQL listRealObjects != list_objects
+sub listRealObjects {
+    my ($self, $otype) = @_;
+    my $pclass = $self->_load_obj_class($otype) or return;
+    $pclass->listReal($self);
 }
 
@@ -287 +390 @@
 
 =head1 SPECIFICS FUNCTIONS
+
+=head2 GetAlias($base, $id)
+
+Return object having id C<$id> only if it is an object alias
+
+=cut
+
+sub GetAlias {
+    my ($self, $otype, $id) = @_;
+
+    my $pclass = $self->_load_obj_class($otype) or return;
+
+    # Object Alias: checking if object is alias, then returning it:
+    my $sth = $self->db->prepare_cached(
+        sprintf(q{select oalias from %s where %s = ? and oalias IS NOT NULL and internobject = false %s},
+            $self->db->quote_identifier($pclass->_object_table),
+            $self->db->quote_identifier($pclass->_key_field),
+            ($self->{wexported} ? '' : 'and exported = true'),
+        ),
+    );
+    $sth->execute($id);
+    my $res = $sth->fetchrow_hashref;
+    $sth->finish;
+    if ($res) {
+        return $self->SUPER::get_object($otype, $id);
+    } else {
+        return;
+    }
+}
+
+=head2 CreateAlias($otype, $name, $for)
+
+Create an object alias named C<$name> for ovbject C<$for>
+
+=cut
+
+sub CreateAlias {
+    my ($self, $otype, $name, $for) = @_;
+
+    my $pclass = $self->_load_obj_class($otype) or return;
+
+    $for or die "Cannot create alias without giving object to point";
+
+    my $res = $pclass->CreateAlias($self, $name, $for);
+
+    if ($res) {
+        $self->ReportChange(
+            $otype,
+            $name,
+            $pclass->_get_ikey($self, $name),
+            'Create', "Alias %s %s => %s", $otype, $name, $for
+        );
+        $self->log(LA_DEBUG, "Alias $otype $name => $for created");
+        return 1;
+    } else {
+        $self->log(LA_ERR, "Error when creating alias $otype $name");
+        return;
+    }
+}
+
+=head2 RemoveAlias($otype, $name, $for)
+
+Create an object alias named C<$name> for ovbject C<$for>
+
+=cut
+
+sub RemoveAlias {
+    my ($self, $otype, $name) = @_;
+
+    my $pclass = $self->_load_obj_class($otype) or return;
+
+    my $obj = $self->GetAlias($otype, $name) or do {
+        $self->log('Cannot get alias %s/%s for removal', $otype, $name);
+        return;
+    };
+
+    if ($obj->_get_attributes('internobject')) {
+        # Cannot happend: internal are not fetchable
+        $self->log(LA_ERR,'Cannot delete %s/%s: is an internal object', $pclass->type, $name);
+        return;
+    }
+    if ($obj->_get_attributes('nodelete')) {
+        $self->log(LA_ERR,'Cannot delete %s/%s: is write protected', $pclass->type, $name);
+        return;
+    }
+
+    my $id = $obj->Iid;
+
+    my $sth = $self->db->prepare_cached(sprintf(
+        'DELETE FROM %s WHERE %s = ?',
+        $self->db->quote_identifier($pclass->_object_table),
+        $self->db->quote_identifier($pclass->_key_field),
+    ));
+
+    my $res = $sth->execute($name);
+
+    if ($res) {
+        $self->ReportChange(
+            $otype,
+            $name,
+            $id,
+            'Delete', "Alias %s %s deleted", $otype, $name
+        );
+        $self->log(LA_DEBUG, "Alias $otype $name removed");
+        return 1;
+    } else {
+        $self->log(LA_ERR, "Error when removing alias $otype $name");
+        return;
+    }
+}
 
 =head2 get_global_value ($varname)
@@ -419 +632 @@
             and expire > now()
             and expire is not null
+            and internobject = false
             } . ($self->{wexported} ? '' : 'and exported = true') . q{
             order by expire
@@ -444 +658 @@
             expire < now() - ?::interval
             and expire is not null
+            and internobject = false
         } . ($self->{wexported} ? '' : 'and exported = true') . q{
             order by expire