Difference between revisions of "User:Seph Swain/perl"

From Second Life Wiki
Jump to navigation Jump to search
Line 1: Line 1:
#!/usr/bin/perl
Here's a frist example of how to make server side CGI scripts to interact with SL objects.
#
# multi purpose WWW->SL Gateway


require 5;
(Unfortunatly the Wiki-Formating doesn't really work for this, if you know how to fix it, please tell me)
use LWP::Simple;
use CGI;
use POSIX('strftime');


# Config Section
  #!/usr/bin/perl
  my %VERSION = (
  #
    'MyControl HUD Translator' => 0.02,
  # multi purpose WWW->SL Gateway
    'LineGraph' => 0.9,
 
  );
  require 5;
# EOC
  use LWP::Simple;
 
  use CGI;
# global variables
  use POSIX('strftime');
my $out = "ERROR";
 
 
  # Config Section
# collect input data
    my %VERSION = (
my $query = new CGI;
      'MyControl HUD Translator' => 0.02,
my $action = $query->param("action");
      'LineGraph' => 0.9,
my $client_version = $query->param("version");
    );
my $client_object_name = $ENV{"HTTP_X_SECONDLIFE_OBJECT_NAME"};
  # EOC
  $client_object_name =~ s/ v[\d\.]*$//o;
 
my $client_owner_name = $ENV{"HTTP_X_SECONDLIFE_OWNER_NAME"};
  # global variables
#foreach (sort keys %ENV) { print STDERR "$_ = $ENV{$_}\n"; }
  my $out = "ERROR";
 
 
# some logging:
  # collect input data
print STDERR (strftime "%F %T", localtime) .  
  my $query = new CGI;
    " $client_object_name [v${client_version}]" .
  my $action = $query->param("action");
    " (owner: $client_owner_name)\n";
  my $client_version = $query->param("version");
 
  my $client_object_name = $ENV{"HTTP_X_SECONDLIFE_OBJECT_NAME"};
# version checking:
    $client_object_name =~ s/ v[\d\.]*$//o;
if ($client_version < $VERSION{$client_object_name}) {
  my $client_owner_name = $ENV{"HTTP_X_SECONDLIFE_OWNER_NAME"};
  $out = "Version expired. New Version $VERSION{$client_object_name} " .
  #foreach (sort keys %ENV) { print STDERR "$_ = $ENV{$_}\n"; }
"available from MyControl";
 
  $action = "error";
  # some logging:
}
  print STDERR (strftime "%F %T", localtime) .  
 
        " $client_object_name [v${client_version}]" .
if ($action eq 'SL-online-now') {
        " (owner: $client_owner_name)\n";
  my $html = get("http://www.secondlife.com/");
 
  my $total = $1 if $html =~ /.*Total Residents:.*\n.*>([\d,]{1,})</;
  # version checking:
    $total =~ s/,//go;
  if ($client_version < $VERSION{$client_object_name}) {
  my $online = $1 if $html =~ /.*Online Now:.*\n.*>([\d,]{1,})</;
    $out = "Version expired. New Version $VERSION{$client_object_name} " .
    $online =~ s/,//go;
    "available from MyControl";
  $out = join(';', $online, $total);
    $action = "error";
} elsif ($action eq 'dict.leo.org') {
  }
  # version checking:
 
  my $word = $query->param("word");
  if ($action eq 'SL-online-now') {
  my $language = $query->param("language");
    my $html = get("http://www.secondlife.com/");
  my $language_str = "ende";
    my $total = $1 if $html =~ /.*Total Residents:.*\n.*>([\d,]{1,})</;
  # 0-englisch(default), 1-franzoesisch, 2-spanisch
      $total =~ s/,//go;
    if ($language == 1) { $language_str = "frde" }
    my $online = $1 if $html =~ /.*Online Now:.*\n.*>([\d,]{1,})</;
  elsif ($language == 2) { $language_str = "esde" }
      $online =~ s/,//go;
 
    $out = join(';', $online, $total);
  my $html = get("http://dict.leo.org/${language_str}?lp=${language_string}&lang=de&searchLoc=0&cmpType=relaxed&sectHdr=on&spellToler=on&relink=on&search=$word");
  } elsif ($action eq 'dict.leo.org') {
  #print STDERR "HTML:\n$html\n";
    # version checking:
  my $content;
    my $word = $query->param("word");
  $content = $1
    my $language = $query->param("language");
    if $html =~ /<table[^>]*id="results"[^>]*>(.*?)<\/table>/s; # no i!
    my $language_str = "ende";
  #print STDERR "content:\n$content\n";
    # 0-englisch(default), 1-franzoesisch, 2-spanisch
  #print STDERR "splut:\n";
      if ($language == 1) { $language_str = "frde" }
  my @entries = split /\<tr/i, $content;
    elsif ($language == 2) { $language_str = "esde" }
  # remove leading and trailing 2 entries:
 
  #@entries = splice(@entries, 2, -2);
    my $html = get("http://dict.leo.org/${language_str}?lp=${language_string}&lang=de&searchLoc=0&cmpType=relaxed&sectHdr=on&spellToler=on&relink=on&search=$word");
  my @out;
    #print STDERR "HTML:\n$html\n";
  foreach (@entries) {
    my $content;
    my @cells = split /<td/i, $_;
    $content = $1
    my $cell_count = int(@cells);
      if $html =~ /<table[^>]*id="results"[^>]*>(.*?)<\/table>/s; # no i!
    #print STDERR "entry: " . int(@cells) ."\n";
 
    @cells = map {
    my @entries = split /\<tr/i, $content;
      s/^[^>]*>//o;
    # remove leading and trailing 2 entries:
      s/<[^>]*>//go;  
    #@entries = splice(@entries, 2, -2);
      $_; } @cells;
    my @out;
    if ($cell_count == 6) {
    foreach (@entries) {
      push @out, $cells[2] . " - " . $cells[4];
      my @cells = split /<td/i, $_;
    }
      my $cell_count = int(@cells);
  }
      #print STDERR "entry: " . int(@cells) ."\n";
  if (@out) {
      @cells = map {
    $out = join("\n", @out);
s/^[^>]*>//o;
  } else {
s/<[^>]*>//go;  
    $out = "no results";
$_; } @cells;
  }
      if ($cell_count == 6) {
 
  push @out, $cells[2] . " - " . $cells[4];
}
      }
 
    }
# cut to size
    if (@out) {
$out = substr($out, 0, 2048);
      $out = join("\n", @out);
print "Content-type: text/html\n\n$out\n";
    } else {
      $out = "no results";
    }
 
  }
 
  # cut to size
  $out = substr($out, 0, 2048);
  print "Content-type: text/html\n\n$out\n";

Revision as of 02:02, 27 April 2007

Here's a frist example of how to make server side CGI scripts to interact with SL objects.

(Unfortunatly the Wiki-Formating doesn't really work for this, if you know how to fix it, please tell me)

 #!/usr/bin/perl
 #
 # multi purpose WWW->SL Gateway
 
 require 5;
 use LWP::Simple;
 use CGI;
 use POSIX('strftime');
 
 # Config Section
   my %VERSION = (
     'MyControl HUD Translator'	=> 0.02,
     'LineGraph'			=> 0.9,
   );
 # EOC
 
 # global variables
 my $out = "ERROR";
 
 # collect input data
 my $query = new CGI;
 my $action = $query->param("action");
 my $client_version = $query->param("version");
 my $client_object_name = $ENV{"HTTP_X_SECONDLIFE_OBJECT_NAME"};
    $client_object_name =~ s/ v[\d\.]*$//o;
 my $client_owner_name = $ENV{"HTTP_X_SECONDLIFE_OWNER_NAME"};
 #foreach (sort keys %ENV) { print STDERR "$_ = $ENV{$_}\n"; }
 
 # some logging:
 print STDERR (strftime "%F %T", localtime) . 
 	       " $client_object_name [v${client_version}]" .
 	       " (owner: $client_owner_name)\n";
 
 # version checking:
 if ($client_version < $VERSION{$client_object_name}) {
   $out = "Version expired. New Version $VERSION{$client_object_name} " .
 	   "available from MyControl";
   $action = "error";
 }
 
 if ($action eq 'SL-online-now') {
   my $html = get("http://www.secondlife.com/");
   my $total = $1 if $html =~ /.*Total Residents:.*\n.*>([\d,]{1,})</;
      $total =~ s/,//go;
   my $online = $1 if $html =~ /.*Online Now:.*\n.*>([\d,]{1,})</;
      $online =~ s/,//go;
   $out = join(';', $online, $total);
 } elsif ($action eq 'dict.leo.org') {
   # version checking:
   my $word = $query->param("word");
   my $language = $query->param("language");
   my $language_str = "ende";
   # 0-englisch(default), 1-franzoesisch, 2-spanisch
      if ($language == 1) { $language_str = "frde" }
   elsif ($language == 2) { $language_str = "esde" }
 
   my $html = get("http://dict.leo.org/${language_str}?lp=${language_string}&lang=de&searchLoc=0&cmpType=relaxed&sectHdr=on&spellToler=on&relink=on&search=$word");
   #print STDERR "HTML:\n$html\n";
   my $content;
   $content = $1
     if $html =~ /<table[^>]*id="results"[^>]*>(.*?)<\/table>/s; # no i!
 
   my @entries = split /\<tr/i, $content;
   # remove leading and trailing 2 entries:
   #@entries = splice(@entries, 2, -2);
   my @out;
   foreach (@entries) {

my @cells = split /]*>//o;

s/<[^>]*>//go; $_; } @cells;

     if ($cell_count == 6) {
 	push @out, $cells[2] . " - " . $cells[4];
     }
   }
   if (@out) {
     $out = join("\n", @out);
   } else {
     $out = "no results";
   }
 
 }
 
 # cut to size
 $out = substr($out, 0, 2048);
 print "Content-type: text/html\n\n$out\n";