[Bioperl-guts-l] [16892] bioperl-live/trunk: [bug 3012] add a clearer to guarantee clearing the proxy, regardless how the method is called (a bit of code smell there, probably should be refactored to just be used as an instance instead of ambiguously using either class or instance calls )

Christopher John Fields cjfields at dev.open-bio.org
Thu Mar 4 00:23:17 EST 2010


Revision: 16892
Author:   cjfields
Date:     2010-03-04 00:23:17 -0500 (Thu, 04 Mar 2010)
Log Message:
-----------
[bug 3012] add a clearer to guarantee clearing the proxy, regardless how the method is called (a bit of code smell there, probably should be refactored to just be used as an instance instead of ambiguously using either class or instance calls)

Modified Paths:
--------------
    bioperl-live/trunk/Bio/Root/Build.pm
    bioperl-live/trunk/Bio/Root/HTTPget.pm
    bioperl-live/trunk/Bio/Root/Test.pm
    bioperl-live/trunk/Bio/SeqFeature/Generic.pm
    bioperl-live/trunk/t/Root/HTTPget.t

Modified: bioperl-live/trunk/Bio/Root/Build.pm
===================================================================
--- bioperl-live/trunk/Bio/Root/Build.pm	2010-03-04 04:50:49 UTC (rev 16891)
+++ bioperl-live/trunk/Bio/Root/Build.pm	2010-03-04 05:23:17 UTC (rev 16892)
@@ -1217,7 +1217,7 @@
         my $use_email = $self->y_n("Do you want to run tests requiring a valid email address? y/n",'n');
         if ($use_email) {
             my $address = $self->prompt("Enter email address:");
-            $self->notes(email => $address || undef);
+            $self->notes(email => $address);
         }
     }
     else {

Modified: bioperl-live/trunk/Bio/Root/HTTPget.pm
===================================================================
--- bioperl-live/trunk/Bio/Root/HTTPget.pm	2010-03-04 04:50:49 UTC (rev 16891)
+++ bioperl-live/trunk/Bio/Root/HTTPget.pm	2010-03-04 05:23:17 UTC (rev 16892)
@@ -90,6 +90,7 @@
 package Bio::Root::HTTPget;
 
 use strict;
+use warnings;
 use IO::Socket qw(:DEFAULT :crlf);
 
 use base qw(Bio::Root::Root);
@@ -360,7 +361,7 @@
  Function: Get/Set a proxy for use of proxy. Defaults to environment variable
            http_proxy if present.
  Returns : a string indicating the proxy
- Args    : $protocol : an array ref of the protocol(s) to set/get
+ Args    : $protocol : string for the protocol to set/get
            $proxyurl : url of the proxy to use for the specified protocol
            $username : username (if proxy requires authentication)
            $password : password (if proxy requires authentication)
@@ -375,7 +376,7 @@
     my ($protocol,$proxy,$username,$password) = @_;
     my $atts = ref($self) ? $self : \%attributes;
     $protocol ||= 'http';
-    unless ($proxy) {
+    if (!$proxy) {
         if (defined $ENV{http_proxy}) {
             $proxy = $ENV{http_proxy};
             if ($proxy =~ /\@/) {
@@ -384,13 +385,36 @@
             }
         }
     }
-    return unless (defined $proxy);
-    # default to class method call
-    __PACKAGE__->authentication($username, $password) 
-	if ($username && $password);
-    return $atts->{'_proxy'}->{$protocol} = $proxy;
+    if (defined $proxy) {
+        # default to class method call
+        __PACKAGE__->authentication($username, $password) 
+        if ($username && $password);
+        $atts->{'_proxy'}->{$protocol} = $proxy;
+    }
+    return $atts->{'_proxy'}->{$protocol};
 }
 
+=head2 clear_proxy
+
+ Title   : clear_proxy
+ Usage   : my $old_prozy = $db->clear_proxy('http')
+ Function: Unsets (clears) the proxy for the protocol indicated 
+ Returns : a string indicating the old proxy value
+ Args    : $protocol : string for the protocol to clear
+
+=cut
+
+sub clear_proxy {
+    my $self;
+    if($_[0] && (ref($_[0]) or $_[0] =~ /^Bio::/)) {
+        $self = shift;
+    }
+    my ($protocol) = @_;
+    my $atts = ref($self) ? $self : \%attributes;
+    $protocol ||= 'http';
+    delete $atts->{'_proxy'}->{$protocol};
+}
+
 =head2 authentication
 
  Title   : authentication

Modified: bioperl-live/trunk/Bio/Root/Test.pm
===================================================================
--- bioperl-live/trunk/Bio/Root/Test.pm	2010-03-04 04:50:49 UTC (rev 16891)
+++ bioperl-live/trunk/Bio/Root/Test.pm	2010-03-04 05:23:17 UTC (rev 16892)
@@ -211,6 +211,10 @@
            -requires_networking => 1|0 (default 0, if true all tests will be
                                         skipped if network tests haven't been
                                         enabled in Build.PL)
+           -requires_email      => 1   (if true the desired number of tests will
+                                        be skipped if either network tests
+                                        haven't been enabled in Build.PL or an
+                                        email hasn't been entered)
            -excludes_os         => str (default none, if OS suppied, all tests
                                         will skip if running on that OS (eg.
                                         'mswin'))

Modified: bioperl-live/trunk/Bio/SeqFeature/Generic.pm
===================================================================
--- bioperl-live/trunk/Bio/SeqFeature/Generic.pm	2010-03-04 04:50:49 UTC (rev 16891)
+++ bioperl-live/trunk/Bio/SeqFeature/Generic.pm	2010-03-04 05:23:17 UTC (rev 16892)
@@ -381,7 +381,9 @@
 
     if (@_) {
         my $value = shift;
-
+        if ($value && $value eq '.') {
+            undef $value;
+        }
         if ( defined $value && $value && $value !~ /^[A-Za-z]+$/ &&
             $value !~ /^[+-]?\d+\.?\d*(e-\d+)?/ and $value != 0) {
             $self->throw(-class=>'Bio::Root::BadParameter',

Modified: bioperl-live/trunk/t/Root/HTTPget.t
===================================================================
--- bioperl-live/trunk/t/Root/HTTPget.t	2010-03-04 04:50:49 UTC (rev 16891)
+++ bioperl-live/trunk/t/Root/HTTPget.t	2010-03-04 05:23:17 UTC (rev 16892)
@@ -8,7 +8,7 @@
     use lib '.';
     use Bio::Root::Test;
     
-    test_begin(-tests => 28,
+    test_begin(-tests => 29,
 	       -requires_networking => 1);
 	
     use_ok('Bio::Root::HTTPget');
@@ -48,10 +48,7 @@
 is_deeply([$obj->authentication], []);
 $obj->proxy('http', $TEST_PROXY);
 $obj->authentication(@TEST_AUTHENTICATION);
-TODO: {
-    local $TODO = 'proxy not working';
-    is ($obj->proxy(), $TEST_PROXY);
-}
+is ($obj->proxy(), $TEST_PROXY);
 is_deeply([$obj->authentication], \@TEST_AUTHENTICATION);
 
 # test class method calls; note that mixing class and sub calls pollutes the
@@ -67,10 +64,7 @@
 is_deeply([Bio::Root::HTTPget->authentication], []);
 Bio::Root::HTTPget->proxy('http', $TEST_PROXY);
 Bio::Root::HTTPget->authentication(@TEST_AUTHENTICATION);
-TODO: {
-    local $TODO = 'proxy not working';
-    is (Bio::Root::HTTPget->proxy('http'), $TEST_PROXY);
-}
+is (Bio::Root::HTTPget->proxy('http'), $TEST_PROXY);
 is_deeply([Bio::Root::HTTPget->authentication], \@TEST_AUTHENTICATION);
 
 # test sub calls (not called as method)
@@ -84,16 +78,15 @@
 # note that mixing class and sub calls pollutes the class attributes, have to
 # manually reset
 Bio::Root::HTTPget->authentication(undef, undef);
-Bio::Root::HTTPget->proxy('http', undef);
 
+my $old = Bio::Root::HTTPget->clear_proxy('http');
 is (Bio::Root::HTTPget::proxy(), undef);
+is ($old, $TEST_PROXY);
+
 is_deeply([Bio::Root::HTTPget->authentication], [undef, undef]);
 Bio::Root::HTTPget::proxy('http', $TEST_PROXY);
 Bio::Root::HTTPget::authentication(@TEST_AUTHENTICATION);
-TODO: {
-    local $TODO = 'proxy not working';
-    is (Bio::Root::HTTPget::proxy('http'), $TEST_PROXY);
-}
+is (Bio::Root::HTTPget::proxy('http'), $TEST_PROXY);
 is_deeply([Bio::Root::HTTPget::authentication], \@TEST_AUTHENTICATION);
 
 # check to make sure new instance attributes are not polluted by class attrbutes
@@ -107,9 +100,6 @@
 is_deeply([$newobj->authentication], []);
 $newobj->proxy('http', $TEST_PROXY);
 $newobj->authentication(@TEST_AUTHENTICATION);
-TODO: {
-    local $TODO = 'proxy not working';
-    is ($newobj->proxy(), $TEST_PROXY);
-}
+is ($newobj->proxy(), $TEST_PROXY);
 is_deeply([$newobj->authentication], \@TEST_AUTHENTICATION);
 



More information about the Bioperl-guts-l mailing list