File Coverage

blib/lib/Devel/Cycle.pm

Criterion	Covered	Total	%
statement	95	142	66.9
branch	33	82	40.2
condition	9	21	42.8
subroutine	16	22	72.7
pod	2	2	100.0
total	155	269	57.6

package Devel::Cycle;
# $Id: Cycle.pm,v 1.15 2009/08/24 12:51:02 lstein Exp $

use 5.006001;
use strict;
use Carp 'croak','carp';
use warnings;

use Scalar::Util qw(isweak blessed refaddr reftype);

my $SHORT_NAME = 'A';
my %SHORT_NAMES;


require Exporter;

our @ISA = qw(Exporter);
our @EXPORT = qw(find_cycle find_weakened_cycle);
our @EXPORT_OK = qw($FORMATTING);
our $VERSION = '1.12';
our $FORMATTING = 'roasted';
our $QUIET   = 0;

my %import_args = (-quiet =>1,
		   -raw   =>1,
		   -cooked =>1,
		   -roasted=>1);

BEGIN {
  require constant;
  constant->import( HAVE_PADWALKER =>
		    eval {
		      require PadWalker;
		      $PadWalker::VERSION >= 1.0;
		    });
}

sub import {
  my $self = shift;
  my @args = @_;
  my %args = map {$_=>1} @args;
  $QUIET++    if exists $args{-quiet};
  $FORMATTING = 'roasted' if exists $args{-roasted};
  $FORMATTING = 'raw'     if exists $args{-raw};
  $FORMATTING = 'cooked'  if exists $args{-cooked};
  $self->export_to_level(1,$self,grep {!exists $import_args{$_}} @_);
}

sub find_weakened_cycle {
  my $ref      = shift;
  my $callback = shift;
  unless ($callback) {
    my $counter = 0;
    $callback = sub {
      _do_report(++$counter,shift)
    }
  }
  _find_cycle($ref,{},$callback,1,{},());
}

sub find_cycle {
  my $ref      = shift;
  my $callback = shift;
  unless ($callback) {
    my $counter = 0;
    $callback = sub {
      _do_report(++$counter,shift)
    }
  }
  _find_cycle($ref,{},$callback,0,{},());
}

sub _find_cycle {
  my $current   = shift;
  my $seenit    = shift;
  my $callback  = shift;
  my $inc_weak_refs = shift;
  my $complain = shift;
  my @report  = @_;

  return unless ref $current;

  # note: it seems like you could just do:
  #
  #    return if isweak($current);
  #
  # but strangely the weak flag doesn't seem to survive the copying,
  # so the test has to happen directly on the reference in the data
  # structure being scanned.

  if ($seenit->{refaddr $current}) {
    $callback->(\@report);
    return;
  }
  $seenit->{refaddr $current}++;

  _find_cycle_dispatch($current,{%$seenit},$callback,$inc_weak_refs,$complain,@report);
}

sub _find_cycle_dispatch {
  my $type = _get_type($_[0]);

  if (!defined $type) {
    my $ref = reftype $_[0];
    our %already_warned;
    if (!$already_warned{$ref}++) {
	warn "Unhandled type: $ref";
    }
    return;
  }
  my $sub = do { no strict 'refs'; \&{"_find_cycle_$type"} };
  $sub->(@_);
}

sub _find_cycle_SCALAR {
  my $current   = shift;
  my $seenit    = shift;
  my $callback  = shift;
  my $inc_weak_refs = shift;
  my $complain  = shift;
  my @report  = @_;

  return if !$inc_weak_refs && isweak($$current);
  _find_cycle($$current,{%$seenit},$callback,$inc_weak_refs,$complain,
              (@report,['SCALAR',undef,$current => $$current,$inc_weak_refs?isweak($$current):()]));
}

sub _find_cycle_ARRAY {
  my $current   = shift;
  my $seenit    = shift;
  my $callback  = shift;
  my $inc_weak_refs = shift;
  my $complain  = shift;
  my @report  = @_;

  for (my $i=0; $i<@$current; $i++) {
    next if !$inc_weak_refs && isweak($current->[$i]);
    _find_cycle($current->[$i],{%$seenit},$callback,$inc_weak_refs,$complain,
                (@report,['ARRAY',$i,$current => $current->[$i],$inc_weak_refs?isweak($current->[$i]):()]));
    }
}

sub _find_cycle_HASH {
  my $current   = shift;
  my $seenit    = shift;
  my $callback  = shift;
  my $inc_weak_refs = shift;
  my $complain  = shift;
  my @report  = @_;

  for my $key (sort keys %$current) {
    next if !$inc_weak_refs && isweak($current->{$key});
    _find_cycle($current->{$key},{%$seenit},$callback,$inc_weak_refs,$complain,
                (@report,['HASH',$key,$current => $current->{$key},$inc_weak_refs?isweak($current->{$key}):()]));
    }
}

sub _find_cycle_CODE {
  my $current   = shift;
  my $seenit    = shift;
  my $callback  = shift;
  my $inc_weak_refs = shift;
  my $complain  = shift;
  my @report  = @_;

  unless (HAVE_PADWALKER) {
    if (!$complain->{$current} && !$QUIET) {
      carp "A code closure was detected in but we cannot check it unless the PadWalker module is installed";
    }

    return;
  }

  my $closed_vars = PadWalker::closed_over( $current );
  foreach my $varname ( sort keys %$closed_vars ) {
    my $value = $closed_vars->{$varname};
    _find_cycle_dispatch($value,{%$seenit},$callback,$inc_weak_refs,$complain,
                         (@report,['CODE',$varname,$current => $value]));
  }
}

sub _do_report {
  my $counter = shift;
  my $path    = shift;
  print "Cycle ($counter):\n";
  foreach (@$path) {
    my ($type,$index,$ref,$value,$is_weak) = @$_;
    printf("\t%30s => %-30s\n",($is_weak ? 'w-> ' : '')._format_reference($type,$index,$ref,0),_format_reference(undef,undef,$value,1));
  }
  print "\n";
}

sub _format_reference {
  my ($type,$index,$ref,$deref) = @_;
  $type ||= _get_type($ref);
  return $ref unless $type;
  my $suffix  = defined $index ? _format_index($type,$index) : '';
  if ($FORMATTING eq 'raw') {
    return $ref.$suffix;
  }

  else {
    my $package  = blessed($ref);
    my $prefix   = $package ? ($FORMATTING eq 'roasted' ? "${package}::" : "${package}="  ) : '';
    my $sygil    = $deref ? '\\' : '';
    my $shortname = ($SHORT_NAMES{$ref} ||= $SHORT_NAME++);
    return $sygil . ($sygil ? '$' : '$$'). $prefix . $shortname . $suffix if $type eq 'SCALAR';
    return $sygil . ($sygil ? '@' : '$') . $prefix . $shortname . $suffix  if $type eq 'ARRAY';
    return $sygil . ($sygil ? '%' : '$') . $prefix . $shortname . $suffix  if $type eq 'HASH';
    return $sygil . ($sygil ? '&' : '$') . $prefix . $shortname . $suffix if $type eq 'CODE';
  }
}

# why not Scalar::Util::reftype?
sub _get_type {
  my $thingy = shift;
  return unless ref $thingy;
  return 'SCALAR' if UNIVERSAL::isa($thingy,'SCALAR') || UNIVERSAL::isa($thingy,'REF');
  return 'ARRAY'  if UNIVERSAL::isa($thingy,'ARRAY');
  return 'HASH'   if UNIVERSAL::isa($thingy,'HASH');
  return 'CODE'   if UNIVERSAL::isa($thingy,'CODE');
  undef;
}

sub _format_index {
  my ($type,$index) = @_;
  return "->[$index]" if $type eq 'ARRAY';
  return "->{'$index'}" if $type eq 'HASH';
  return " variable $index" if $type eq 'CODE';
  return;
}

1;
__END__