view release on metacpan or  search on metacpan

Catalog.pm  view on Meta::CPAN

		$self->{catalog_list}{$catalog_name} = [] ;
		$self->{class_catalog}->add_catalog($catalog_name) ;
		Class::IntrospectionMethods::Catalog::warn_obsolete
		    ("Warning: undeclared catalog $catalog_name, Created ...");
	      }
	    else
	      {
		croak "slot: unknown catalog $catalog_name, expected",
		  join(',',keys %$clist) ;
	      }
	  }
      }

    # add inherited catalogs
    push @all_cats,
      map {$self->catalog_isa($_)} @all_cats ;

    #print "slot: @_ is @all_cats\n";
    my @result ;
    foreach my $slot (@{$self->ordered_slot_list()})
      {
        my @c = @{$self->{slot_list}{$slot}} ;
        my %c ;
        foreach my $c (@c) {$c{$c} = 1}
        my %isect ;
        foreach my $c (@all_cats) { $isect{$c} = 1 if $c{$c} }

        push @result, $slot if scalar keys %isect ; 
      }  ;

    #print "result is @result\n";
    return wantarray ? @result : \@result ;
  }

=head2 all_slot()

Return a list of all slots (respecting the order defined in
global_catalog).

=cut

sub all_slot
  {
    my $self = shift;
    return @{$self->ordered_slot_list} ;
  }

=head2 all_catalog()

Returns a sorted list of all defined catalogs.

=cut

sub all_catalog
  {
    my ($self) = @_ ;
    return sort keys %{$self->{catalog_list}} ;
  }

#internal
sub update_catalog_list
  {
    my $self = shift ;

    # reset and update catalog lists (which is somewhat different from rebuild)
    delete $self->{catalog} ;
    foreach my $slot (sort keys %{$self->{slot_list}} ) 
      {
        map{ push @{$self->{catalog_list}{$_}}, $slot ;} 
          @{$self->{slot_list}{$slot}} ;
      }
 }

package Class::IntrospectionMethods::ObjectCatalog ;

use Carp;
use Storable qw(dclone) ;
use vars qw($AUTOLOAD @ISA);

@ISA = qw/Class::IntrospectionMethods::AnyCatalog/ ;

sub new
  {
    my $type =shift ;
    my $self = { @_ } ;

    croak __PACKAGE__,"->new: no class_catalog given" unless defined
      $self->{class_catalog} ;

    $self->{slot_list} = 
      dclone($self->{class_catalog}->slot_list() ) ;

    bless $self, $type ;
    $self->update_catalog_list ;

    return $self ;
  }

=head1 ObjectClass methods

Unknown methods will be forwarded to associated ClassCatalog object.

=head2 change( slot_name, catalog_name )

Move the slot into catalog C<catalog_name>.

=cut

sub change
  {
    my ($self, $slot_name, $catalog_name) = @_ ;

    croak "set_catalog, change command: Missing slot name"
      unless defined $slot_name;
    croak "set_catalog, change command: Missing catalog name"
      unless defined $catalog_name;

    # check new catalog
   my @cat = ref $catalog_name ? sort @$catalog_name : ($catalog_name) ;
    map 
      {