X-Git-Url: http://dxcluster.net/gitweb/gitweb.cgi?a=blobdiff_plain;f=perl%2FDXCommandmode.pm;h=d0af6bbb228b0d4954b1c1fa0e0ddcc7fbaed4f9;hb=6951e5c6623c813b5f3da77796aa22c7e0848e44;hp=798351773c998c62f603facd84c093c782873d34;hpb=c02dc2d8b544b9d682c9a068ba13bdedf40ed3bf;p=spider.git

diff --git a/perl/DXCommandmode.pm b/perl/DXCommandmode.pm
index 79835177..d0af6bbb 100644
--- a/perl/DXCommandmode.pm
+++ b/perl/DXCommandmode.pm
@@ -13,6 +13,10 @@ package DXCommandmode;
 
 @ISA = qw(DXChannel);
 
+use AnyEvent;
+use AnyEvent::Handle;
+use AnyEvent::Socket;
+
 use POSIX qw(:math_h);
 use DXUtil;
 use DXChannel;
@@ -32,7 +36,6 @@ use WCY;
 use Sun;
 use Internet;
 use Script;
-use Net::Telnet;
 use QSL;
 use DB_File;
 use VE7CC;
@@ -51,7 +54,7 @@ $maxbadcount = 3;				# no of bad words allowed before disconnection
 $msgpolltime = 3600;			# the time between polls for new messages 
 $cmdimportdir = "$main::root/cmd_import"; # the base directory for importing command scripts 
                                           # this does not exist as default, you need to create it manually
-					  #
+#
 
 #
 # obtain a new connection this is derived from dxchannel
@@ -521,10 +524,10 @@ sub run_cmd
 			my $package = find_cmd_name($path, $fcmd);
 			return ($@) if $@;
 				
-			if ($package && DXCommandmode->can($package)) {
+			if ($package && $self->can("${package}::handle")) {
 				no strict 'refs';
 				dbg("cmd: package $package") if isdbg('command');
-				eval { @ans = &$package($self, $args) };
+				eval { @ans = &{"${package}::handle"}($self, $args) };
 				return (DXDebug::shortmess($@)) if $@;
 			} else {
 				dbg("cmd: $package not present") if isdbg('command');
@@ -745,12 +748,14 @@ sub clear_cmd_cache
 {
 	no strict 'refs';
 	
-	for (keys %Cache) {
-		undef *{$_} unless /cmd_cache/;
-		dbg("Undefining cmd $_") if isdbg('command');
+	for my $k (keys %Cache) {
+		unless ($k =~ /cmd_cache/) {
+			dbg("Undefining cmd $k") if isdbg('command');
+			undef $DXCommandmode::{"${k}::"};
+		}
 	}
 	%cmd_cache = ();
-	%Cache = ();
+	%Cache = ( cmd_clear_cmd_cache  => $Cache{cmd_clear_cmd_cache} );
 }
 
 #
@@ -761,11 +766,10 @@ sub clear_cmd_cache
 # 
 # This has been nicked directly from the perlembed pages
 #
-
 #require Devel::Symdump;  
 
 sub valid_package_name {
-	my($string) = @_;
+	my $string = shift;
 	$string =~ s|([^A-Za-z0-9_/])|sprintf("_%2x",unpack("C",$1))|eg;
 	
 	$string =~ s|/|_|g;
@@ -788,11 +792,11 @@ sub find_cmd_name {
 		return undef;
 	}
 	
-	if(defined $Cache{$package}->{mtime} &&$Cache{$package}->{mtime} <= $mtime) {
+	if(exists $Cache{$package} && exists $Cache{$package}->{mtime} && $Cache{$package}->{mtime} <= $mtime) {
 		#we have compiled this subroutine already,
 		#it has not been updated on disk, nothing left to do
 		#print STDERR "already compiled $package->handler\n";
-		;
+		dbg("find_cmd_name: $package cached") if isdbg('command');
 	} else {
 
 		my $sub = readfilestr($filename);
@@ -802,7 +806,14 @@ sub find_cmd_name {
 		};
 		
 		#wrap the code into a subroutine inside our unique package
-		my $eval = qq( sub $package { $sub } );
+		my $eval = qq(package DXCommandmode::$package; use POSIX qw{:math_h}; use DXLog; use DXDebug; use DXUser; use DXUtil; use Minimuf; use Sun; our \@ISA = qw{DXCommandmode}; );
+
+
+		if ($sub =~ m|\s*sub\s+handle\n|) {
+			$eval .= $sub;
+		} else {
+			$eval .= qq(sub handle { $sub });
+		}
 		
 		if (isdbg('eval')) {
 			my @list = split /\n/, $eval;
@@ -817,7 +828,8 @@ sub find_cmd_name {
 
 		if (exists $Cache{$package}) {
 			dbg("find_cmd_name: Redefining $package") if isdbg('command');
-			undef *$package;
+			undef $DXCommandmode::{"${package}::"};
+			delete $Cache{$package};
 		} else {
 			dbg("find_cmd_name: Defining $package") if isdbg('command');
 		}
@@ -825,10 +837,9 @@ sub find_cmd_name {
 		eval $eval;
 
 		$Cache{$package} = {mtime => $mtime } unless $@;
-	    
 	}
 
-	return $package;
+	return "DXCommandmode::$package";
 }
 
 sub send
@@ -1233,5 +1244,50 @@ sub send_motd
 	}
 	$self->send_file($motd) if -e $motd;
 }
+
+sub http_get
+{
+	my $self = shift;
+	my ($host, $uri, $cb) = @_;
+
+	# store results here
+	my ($response, $header, $body);
+
+	my $handle;
+	$handle = AnyEvent::Handle->new(
+									connect  => [$host => 'http'],
+									on_error => sub {
+										$cb->("HTTP/1.0 500 $!");
+										$self->anyevent_del($handle);
+										$handle->destroy; # explicitly destroy handle
+									},
+									on_eof   => sub {
+										$cb->($response, $header, $body);
+										$self->anyevent_del($handle);
+										$handle->destroy; # explicitly destroy handle
+									}
+								   );
+	$self->anyevent_add($handle);
+	$handle->push_write ("GET $uri HTTP/1.0\015\012\015\012");
+
+	# now fetch response status line
+	$handle->push_read (line => sub {
+							my ($handle, $line) = @_;
+							$response = $line;
+						});
+
+	# then the headers
+	$handle->push_read (line => "\015\012\015\012", sub {
+							my ($handle, $line) = @_;
+							$header = $line;
+						});
+
+	# and finally handle any remaining data as body
+	$handle->on_read (sub {
+						  $body .= $_[0]->rbuf;
+						  $_[0]->rbuf = "";
+					  });
+}
+
 1;
 __END__