lib/CXGN/Class/Exporter.pm

   1 package CXGN::Class::Exporter;
   2 use strict;
   3 no strict 'refs';
   4
   5 # VERBOSE: Developer Variable, default quiet
   6 # 0: non-verbose, no developer messages
   7 # 1: print messages on DBH exchange
   8 # 2: print messages on any import() call
   9 # Usage:
  10 # BEGIN {
  11 #       require CXGN::Class::Exporter;
  12 #       $CXGN::Class::Exporter::VERBOSE = 2;
  13 # }
  14 our $VERBOSE = 1;
  15
  16 BEGIN {
  17         #Uses the default exporter, want to allow subclasses to use
  18         #our importer for DBH-exchange capability
  19         our @EXPORT_OK = qw/
  20                 import
  21                 looks_like_DBH
  22                 looks_like_dbh
  23         /;
  24 }
  25 our @EXPORT_OK;
  26
  27 sub dprint {
  28         #We can have this do nothing to kill the dprint messages
  29         #Need to make sure DBH exchanging actually works
  30         return unless $VERBOSE;
  31         my $msg = shift;
  32         chomp $msg;
  33         print STDERR "# " . $msg . "\n";
  34 }
  35
  36 =head1 NAME
  37
  38  CXGN::Class::Exporter
  39
  40 =head1 DESCRIPTION
  41
  42  Use this as a base class to get a standard CXGN import() function on your class,
  43  which does a few cool things:
  44  1) Implements its own light-weight EXPORT/EXPORT_OK routine
  45  2) Can take one hash ref as a set of class routines to execute, with scalar/ref argument.
  46         If sub doesn't exist, will just set package scalar in the importing module
  47  3) Handles exchange of global database handles between modules
  48
  49  Example:
  50  use CXGN::DB::Connection qw/export this and that/ { verbose => 0 }
  51  #equivalent to CXGN::DB::Connection->verbose(0);
  52
  53 =head1 USAGE
  54
  55  package Foo;
  56  use base qw/CXGN::Class::Exporter/;
  57
  58  BEGIN {
  59         our @EXPORT_OK = qw/works like Exporter/;
  60         our @EXPORT = qw/ditto/;
  61  }
  62  our @EXPORT_OK;
  63  our @EXPORT;
  64
  65  our $EXCHANGE_DBH = 1; #pushes or pulls global $DBH to anything that uses this module
  66  #our $IMPORT_DBH = 1; would only pull a $DBH from the using script/module
  67  #our $EXPORT_DBH = 1; would only push a $DBH to the using script/module
  68
  69  sub baz {
  70     my $arg = shift;
  71         $Foo::Bar = $arg;
  72  }
  73  sub works { }
  74  sub ditto { }
  75  sub like { }
  76  sub Exporter { }
  77
  78  1;
  79
  80  package main;
  81
  82  use Foo qw/works/, { baz => 1 };
  83
  84  print "YaHoo!" if defined(&works) && defined(&ditto);
  85
  86
  87 =head1 IMPORT_DBH
  88
  89  Setting the package variable IMPORT_DBH to 'true' within a class will
  90  attempt DBH-importing.  This means that if $DBH is defined within the
  91  calling script/class, then it will be grabbed and set as a the DBH
  92  package variable within the importer.
  93
  94  This is part of an effort to minimize connections to the database.
  95  The idea is that all classes that need database access should use
  96  global database handles, which can be grabbed from other classes.
  97
  98  If fresh handles are needed, they could always be created at-will.
  99
 100
 101 =head1 AUTHOR
 102
 103  C. Carpita
 104
 105 =cut
 106
 107 sub import {
 108         my $class = shift;
 109         my @args = @_;
 110         my $pkg = caller(0);
 111         dprint "$class importer called by $pkg with args: " . join(", ", @args) . "\n" if $VERBOSE > 1;
 112         my @expok = grep { !ref && /^[\$\@\%\*&]?\w+$/ } @args;
 113         CXGN::Class::Exporter->export($class, $pkg, @expok);
 114
 115         my @refs = grep { ref eq "HASH" } @args;
 116         if (@refs > 1) {
 117                 die "Error: $pkg sent multiple hash ref import-arguments to $class\n";
 118         }
 119         if(@refs){
 120                 my $args = $refs[0];
 121                 while(my($k,$v) = each %$args){
 122                         if(defined(&{$class."::".$k})){
 123                                 $class->$k($v);
 124                         }
 125                         else {
 126                                 ${$class."::$k"} = $v;
 127                         }
 128                 }
 129         }
 130         CXGN::Class::Exporter->resolve_DBH_exchange($class, $pkg);
 131 }
 132
 133 sub export {
 134         my $this = shift;
 135         my ($source, $target, @ok) = @_;
 136         foreach my $export (@{$source.'::EXPORT'}){
 137                 $this->export_variable($source, $target, $export);
 138         }
 139         my %export_ok = ();
 140         $export_ok{$_} = 1 foreach(@{$source.'::EXPORT_OK'});
 141         foreach my $ok (@ok){
 142                 die "Package $source does not list '$ok' within EXPORT_OK\n" unless $export_ok{$ok};
 143                 $this->export_variable($source, $target, $ok);
 144         }
 145 }
 146
 147 sub export_variable {
 148         my $this = shift;
 149         my ($source, $target, $var) = @_;
 150         my ($type) = $var =~ /^([\$\@\%&\*])/;
 151         if(defined($type)){
 152                 $var =~ s/\Q$type\E//;
 153                 ${$target.'::'.$var} = ${$source.'::'.$var} if $type eq '$';
 154                 @{$target.'::'.$var} = @{$source.'::'.$var} if $type eq '@';
 155                 %{$target.'::'.$var} = %{$source.'::'.$var} if $type eq '%';
 156                 *{$target.'::'.$var} = *{$source.'::'.$var} if $type eq '*';
 157                 *{$target.'::'.$var} = \&{$source.'::'.$var} if $type eq '&';
 158         }
 159         else {
 160                 warn "Method \&${source}::$var() does not exist\n" unless defined(&{"${source}::$var"});
 161                 *{$target.'::'.$var} = \&{$source.'::'.$var};
 162         }
 163 }
 164
 165 sub resolve_DBH_exchange {
 166         my $this = shift;
 167         my $class = shift;
 168         my $pkg = shift;
 169
 170         my $lldbh = sub { $this->looks_like_DBH(@_) };
 171         no warnings 'once';
 172         if( ${$class."::IMPORT_DBH"}  && $lldbh->(${$pkg."::DBH"}) && !$lldbh->(${$class."::DBH"}) ){
 173                 dprint "$class is pulling its DBH from $pkg\n";
 174                 $this->send_DBH($pkg, $class);  #Pull the DBH from $pkg
 175         }
 176
 177         elsif ( ${$class."::EXPORT_DBH"}
 178                 && $lldbh->(${$class."::DBH"})
 179                 && !$lldbh->(${$pkg."::DBH"})
 180         ) {
 181                 dprint "$class is pushing its DBH to $pkg\n";
 182                 $this->send_DBH($class, $pkg); #push DBH to $pkg
 183         }
 184         elsif (${$class."::EXCHANGE_DBH"} && ${$pkg."::EXCHANGE_DBH"}){
 185                 if(
 186                         $lldbh->(${$class."::DBH"})
 187                         && !$lldbh->(${$pkg."::DBH"})
 188                 ){
 189                         dprint "$class exchanging (push) its DBH with $pkg\n";
 190                         $this->send_DBH($class, $pkg);
 191                 }
 192                 elsif(
 193                         $lldbh->(${$pkg."::DBH"})
 194                         && !$lldbh->(${$class."::DBH"})
 195                 ){
 196                         dprint "$class exchanging (pull) its DBH with $pkg\n";
 197                         $this->send_DBH($pkg, $class);
 198                 }
 199         }
 200 }
 201
 202 sub send_DBH {
 203         my $this = shift;
 204         my $source = shift;
 205         my $dest = shift;
 206         my $DBH = ${$source."::DBH"};
 207         return unless defined $DBH;
 208         return unless $this->looks_like_DBH($DBH);
 209         if(defined(&{$dest."::DBH"})){
 210                 DBH $dest $DBH;
 211         }
 212         else {
 213                 ${$dest."::DBH"} = $DBH;
 214         }
 215 }
 216
 217 sub looks_like_DBH {
 218         my $this = shift;
 219         my ($DBH) = @_;
 220         $DBH = $this if (ref($this) && !$DBH); #used :: (or exported) form of sub
 221         return 0 unless defined($DBH);
 222         return 0 unless ref($DBH);
 223         my $debug = '';
 224         eval {
 225                 $DBH->can("anything");
 226         };
 227         return 0 if $@;
 228         foreach(qw/disconnect prepare commit quote do selectall_hashref ping tables/){
 229                 return 0 unless defined &{ref($DBH).'::'.$_};
 230         }
 231         return 1;
 232 }
 233
 234 *looks_like_dbh = \&looks_like_DBH;
 235
 236 1;