File Coverage

blib/lib/SPOPS/Secure/Hierarchy.pm

Criterion	Covered	Total	%
statement	16	18	88.8
branch			n/a
condition			n/a
subroutine	6	6	100.0
pod			n/a
total	22	24	91.6

package SPOPS::Secure::Hierarchy;

# $Id: Hierarchy.pm,v 3.6 2004/06/02 00:48:24 lachoy Exp $

use strict;
use base  qw( Exporter SPOPS::Secure );
use Log::Log4perl qw( get_logger );
use vars  qw( $ROOT_OBJECT_NAME );

use Data::Dumper  qw( Dumper );
use SPOPS;
use SPOPS::Exception::Security;
use SPOPS::Secure qw( :scope :level $EMPTY );
use SPOPS::Secure::Util;

my $log = get_logger();

@SPOPS::Secure::Hierarchy::EXPORT_OK = qw( $ROOT_OBJECT_NAME );
$SPOPS::Secure::Hierarchy::VERSION   = sprintf("%d.%02d", q$Revision: 3.6 $ =~ /(\d+)\.(\d+)/);

$ROOT_OBJECT_NAME = 'ROOT_OBJECT';


# Override this method from SPOPS::Secure -- return a hashref with the
# scopes as keys and the values as security information (level or
# hashref of scope_id => level)

sub get_security {
    my ( $item, $p ) = @_;

    # Find object info for debugging and for passing to the
    # fetch_by_object method later

    my ( $class, $oid ) = SPOPS::Secure::Util->find_class_and_oid( $item, $p );
    $log->is_info &&
        $log->info( "Checking security for [$class: $oid]" );

    # Punt the request back to our parent if we're getting security
    # explicitly for the ROOT_OBJECT, which generally only happens when
    # we're editing its security

    if ( $oid eq $ROOT_OBJECT_NAME ) {
        $log->is_info &&
            $log->info( "Object ID == ROOT_OBJECT_NAME: punting to parent" );
        return SUPER->get_security({ %{ $p },
                                     class     => $class,
                                     object_id => $oid });
    }

    unless ( exists $p->{user} and exists $p->{group} ) {
        ( $p->{user}, $p->{group} ) = $item->get_security_scopes( $p );
    }

    # superuser (record with user_id 1) can do anything

    if ( my $security_info = $item->_check_superuser( $p->{user}, $p->{group} ) ) {
        $log->is_info &&
            $log->info( "Superuser is logged in" );
        return $security_info;
    }

    my ( $all_levels, $first_level ) = $item->get_hierarchy_levels( $p );
    $log->is_info &&
        $log->info( "First level with security ($first_level)" );

    # Dereference $EMPTY so there's no chance of anyone putting
    # information into the ref and screwing up the package variable...

    return $all_levels->{ $first_level } || \%{ $EMPTY };
}


sub get_hierarchy_levels {
    my ( $item, $p ) = @_;

    # Grab hierarchy config info from the params or from the object

    my $object_id = $p->{oid} || $p->{object_id};
    my $h_info = $item->_get_hierarchy_parameters({ %{ $p },
                                                    hierarchy_value => $object_id });

    # Ensure we have necessary info

    unless ( $h_info->{hierarchy_value} ) {
        $log->warn( "No value available to split into hierarchy! Returning ",
                    "empty security." );
        return ();
    }
    unless ( ref $h_info->{hierarchy_manip} eq 'CODE' ) {
        $log->warn( "Cannot split hierarchy into pieces without either a ",
                    "separator or processing code. Returning empty security." );
        return ();
    }

    # Now comes the interesting part. Setup a list of the object value
    # followed by all the parents. Note that we can either use the
    # default generated list (splitting the value by the separator) or
    # create a subroutine to do it for us, passing it in via
    # 'hierarchy_manip' in the routine parameters or in our object
    # config.

    my $check_list = $h_info->{hierarchy_manip}->( $h_info->{hierarchy_sep},
                                                   $h_info->{hierarchy_value} );

    return $item->_fetch_hierarchy_levels({ %{ $p },
                                            check_list => $check_list,
                                            ordered    => 1  });
}


sub create_root_object_security {
    my ( $item, $p ) = @_;
    my ( $class, $oid ) = SPOPS::Secure::Util->find_class_and_oid( $item, $p );
    return $class->set_security({ object_id      => $ROOT_OBJECT_NAME,
                                  scope          => $p->{scope},
                                  security_level => $p->{level} });
}


# Override so that the WORLD scope doesn't get any default setting

sub create_initial_security { return 1 }


# Retrieve and store a security level for each item in the hierarchy
# check_list, returning these security levels plus a marker denoting
# the first one found. This is used not only in get_security but can
# also be useful when displaying all the parents of a particular
# object and how security is inherited.

sub _fetch_hierarchy_levels {
    my ( $item, $p ) = @_;
    my $class = $p->{class} || ref $item || $item;
    my $so_class = $p->{security_object_class} ||
                   $class->global_security_object_class;

    my $first_found = undef;
    my $level_track = {};
    my @ordered     = ();

    unless ( $p->{class} ) {
        my $object_id = $p->{oid} || $p->{object_id};
        ( $p->{class}, $p->{oid} ) = SPOPS::Secure::Util->find_class_and_oid(
                                                                      $item, $p );
        $log->is_info &&
            $log->info( "Checking security for [$p->{class}] [$p->{oid}]" );
    }

    # Yes, I know, grep in a void context...

    unless ( grep /^$ROOT_OBJECT_NAME$/, @{ $p->{check_list} } ) {
        push @{ $p->{check_list} }, $ROOT_OBJECT_NAME;
        $log->is_info &&
            $log->info( "$ROOT_OBJECT_NAME not found in checklist; added manually" );
    }

SECVALUE:
    foreach my $security_check ( @{ $p->{check_list} } ) {
        $log->is_info &&
            $log->info( "Find value for $p->{class} ($security_check)" );
        push @ordered, $security_check  if ( $p->{ordered} );
        my $sec_listing = $so_class->fetch_by_object( $p->{class},
                                                      { object_id => $security_check,
                                                        user      => $p->{user},
                                                        group     => $p->{group} });
        $log->is_info &&
            $log->info( "Security found for ($security_check):\n",
                          Dumper( $sec_listing ) );

        $first_found ||= $security_check if ( $sec_listing );
        $level_track->{ $security_check } = $sec_listing;
    }

    # If we don't find a single item that has security, we need to
    # create security for this class's root object.

    unless ( $first_found ) {
        $log->is_info &&
            $log->info( "Cannot find ANY security for [$p->{class}] [$p->{oid}] -- ",
                          "creating extremely stringent root object security" );
        $item->create_root_object_security({ class  => $p->{class},
                                             scope  => SEC_SCOPE_WORLD,
                                             level  => SEC_LEVEL_NONE });
    }
    return ( $level_track, $first_found ) unless ( $p->{ordered} );
    return ( $level_track, $first_found, \@ordered );
}


# Set the parameters for hierarchy information whether it came in
# through a parameter list or from an object and its configuration.

sub _get_hierarchy_parameters {
    my ( $item, $p ) = @_;

    # Find the hierarchy information -- info passed into the routine via
    # parameters takes precedence, and we only query the object config if
    # we actually have an object.

    my $h_info = {};
    $h_info->{hierarchy_field} = $p->{hierarchy_field};
    $h_info->{hierarchy_sep}   = $p->{hierarchy_separator};
    $h_info->{hierarchy_manip} = $p->{hierarchy_manip};

    my $class = $p->{class} || ref $item || $item;
    my $CONF = eval { $class->CONFIG };
    if ( ref $CONF ) {
        $h_info->{hierarchy_field} ||= $CONF->{hierarchy_field};
        $h_info->{hierarchy_sep}   ||= $CONF->{hierarchy_separator};
        $h_info->{hierarchy_manip} ||= $CONF->{hierarchy_manip};
    }

    # Only use the default check_list maker if there is a hierarchy
    # separator

    if ( $h_info->{hierarchy_sep} ) {
        $h_info->{hierarchy_manip} ||= \&_make_check_list;
    }

    # If this is an object, find the hierarchy value from the object

    $h_info->{hierarchy_value} = $p->{hierarchy_value};
    my $object = ( ref $item ) ? $item : $p->{object}; # this is a nasty hack
    if ( $object ) {
        $log->is_info &&
            $log->info( "Getting value from object, overriding previously ",
                        "set value of '$h_info->{hierarchy_value}'" );
        $h_info->{hierarchy_value} = $object->{ $h_info->{hierarchy_field} };
    }

    $log->is_info &&
        $log->info( "Found parameters:\n", Dumper( $h_info ) );
    return $h_info;
}


# Note: don't push the root object reference onto the stack in this
# procedure -- we handle it automatically in ->get_hierarchy_levels()

sub _make_check_list {
    my ( $hierarchy_sep, $hierarchy_value ) = @_;
    my @check_list = ( $hierarchy_value );

    # don't get into an infinite loop!
    unless ( $hierarchy_value =~ m!$hierarchy_sep! ) {
        return \@check_list;
    }

    while ( $hierarchy_value ) {
        $hierarchy_value =~ s|^(.*)$hierarchy_sep.*$|$1|;
        push @check_list, $hierarchy_value    if ( $hierarchy_value );
    }
    return \@check_list;
}

1;


__END__