File Coverage

blib/lib/DDC/Any.pm

Criterion	Covered	Total	%
statement	83	93	89.2
branch	34	54	62.9
condition	11	26	42.3
subroutine	12	12	100.0
pod	0	4	0.0
total	140	189	74.0

#-*- Mode: CPerl -*-

## File: DDC::Any.pm
## Author: Bryan Jurish
## Description:
##  + DDC Query utilities: wrap DDC::XS or DDC::PP
##======================================================================

package DDC::Any;
use DDC::Concordance;
use Carp qw(carp confess);
use strict;

our @ISA = qw();
our $VERSION = $DDC::Concordance::VERSION;

##======================================================================
## Globals

our $WHICH = undef;
our ($COMPILER);

##======================================================================
## Overrides

## $CQuery = DDC::Any->parse($qstr)
##  + convenience wrapper, re-implemented here b/c it uses the __PACKAGE__ keyword
sub parse {
  shift if (UNIVERSAL::isa($_[0],__PACKAGE__));
  $COMPILER = DDC::Any::CQueryCompiler->new() if (!$COMPILER);
  return $COMPILER->ParseQuery(@_);
}

## $version = DDC::Any->library_version()
##  + returns extended version string
sub library_version {
  return undef if (!defined($WHICH));
  return "$WHICH / " . $WHICH->can('library_version')->();
}


## $obj = DDC::Any::Object->new(@args)
##  + override calls "real" subclass new() method
package DDC::Any::Object;
sub new {
  my $that  = shift;
  my $class = ref($that)||$that;
  $class   =~ s/^DDC::Any::/${DDC::Any::WHICH}::/;
  return $class->new(@_);
};

##======================================================================
## Import
package DDC::Any;

##--------------------------------------------------------------
## $bool = PACKAGE->have_xs()
##  + attempts to load DDC::XS, and returns true if it is available in a suitable version
our $MIN_XS_VERSION = 0.21;
sub have_xs {
  shift if (UNIVERSAL::isa($_[0],__PACKAGE__));
  eval "use DDC::XS;" if (!$INC{'DDC/XS.pm'});
  return 0 if (!$INC{'DDC/XS.pm'});
  (my $xs_version = ($DDC::XS::VERSION||0)) =~ s/[^0-9\.]//g;
  return ($xs_version && $xs_version >= $MIN_XS_VERSION);
}

##--------------------------------------------------------------
## \%dst_stash = mapstash($src,$dst,%opts)
##  + %opts:
##     inherit => $which ##-- tweak inheritance; (0:don't, >0:$dst ISA $src, <0:$src ISA $dst)
##     deep    => $bool, ##-- walk package tree? (default: true)
##     ignore  => $re,   ##-- ignore fully qualified source-symbols matching $re (default:none)
sub mapstash {
  my ($src0,$dst0,%opts) = @_;
  my $inherit = $opts{inherit} || 0;
  my $deep    = exists($opts{deep}) ? $opts{deep} : 1;
  my $ignore  = $opts{ignore};
  $ignore     = qr{$ignore} if (!ref($ignore));
  my @queue = ([$src0,$dst0]);
  no strict 'refs';
  while (@queue) {
    my ($src,$dst) = @{shift @queue};
    #print STDERR "mapping $src -> $dst\n";
    my $src_stash = \%{"${src}::"};
    my $dst_stash = \%{"${dst}::"};
    while (my ($src_sym,$src_glob)=each %$src_stash) {
      if ($ignore && "${src}::${src_sym}" =~ $ignore) {
	##-- ignored
	next;
      }
      if ($deep && $src_sym =~ /::$/) {
	##-- sub-package
	$src_sym =~ s/::$//;
	$dst_stash->{"${src_sym}::"} = *{"${dst}::${src_sym}::"};
	push(@queue, ["${src}::${src_sym}","${dst}::${src_sym}"]);
      }
      elsif ($src_sym eq 'ISA') {
	##-- copy inheritance
	@{"${dst}::ISA"} = map {(my $isa=$_)=~s/^\Q${src0}\E\b/${dst0}/; $isa} @{"${src}::ISA"};
      }
      else {
	##-- anything else: copy
	$dst_stash->{$src_sym} = $src_glob;
      }
    }

    if ($inherit > 0) {
      push(@{"${dst}::ISA"}, $src);	##-- tweak inheritance: $dst ISA $src
    } elsif ($inherit < 0) {
      push(@{"${src}::ISA"}, $dst);	##-- tweak inheritance: $src ISA $dst
    }
  }

  return \%{"${dst0}::"};
}


##--------------------------------------------------------------
## import guts

## $WHICH = PACKAGE->import(@requests)
sub import {
  my $that = shift;

  ##-- parse user request
  my $which = $WHICH;
  my %alias = ('xs'=>'DDC::XS', pp=>'DDC::PP', any=>'', default=>'');
  foreach (@_) {
    if (/^:(\S+)$/i) {
      $which = lc($1);
      $which = $alias{$which} if (exists($alias{$which}));
    }
  }

  ##-- sanity check(s)
  if ($which) {
    return $WHICH if ($which eq 'none'); ##-- don't map back-end (yet)
    if ($WHICH) {
      carp(__PACKAGE__ . "::import() cannot override current back-end '$WHICH' -- ignoring user request '$which'")
	if ($WHICH ne $which);
      return $WHICH;
    }
  }

  ##-- be safe anyways
  undef $WHICH;
  undef $COMPILER;

  ##-- load back-end
  if (!$which || $which eq 'DDC::XS') {
    if (!$that->have_xs()) {
      die("DDC::Any::import(): failed to load DDC::XS back-end: $@") if (($which||'') eq 'DDC::XS');
    } else {
      $which = 'DDC::XS';
    }
  }
  if (!$which || $which eq 'DDC::PP') {
    eval "use DDC::PP;" if (!$INC{'DDC/PP.pm'});
    if (!$INC{'DDC/PP.pm'}) {
      die("DDC::Any::import(): failed to load DDC::PP back-end: $@") if (($which||'') eq 'DDC::PP');
    } else {
      $which = 'DDC::PP';
    }
  }
  die("DDC::Any::import(): failed to load any back-end") if (!$which);

  ##-- map back-end
  $WHICH = $which;
  mapstash($WHICH=>'DDC::Any', deep=>1, inherit=>-1, ignore=>qr{${WHICH}::(?:VERSION|COMPILER|parse|import|library_version|.*::new)$});
  return $WHICH;
}


1; ##-- be happy

__END__