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
#!/usr/bin/perl
#
#
# multi purpose WWW->SL Gateway
# multi purpose WWW->SL Gateway


require 5;
require 5;
use LWP::Simple;
use LWP::Simple;
use CGI;
use CGI;
use POSIX('strftime');
use POSIX('strftime');


# Config Section
# Config Section
  my %VERSION = (
  my %VERSION = (
    'MyControl HUD Translator' => 0.02,
    'MyControl HUD Translator' => 0.02,
    'LineGraph' => 0.9,
    'LineGraph' => 0.9,
  );
  );
# EOC
# EOC


# global variables
# global variables
my $out = "ERROR";
my $out = "ERROR";


# collect input data
# collect input data
my $query = new CGI;
my $query = new CGI;
my $action = $query->param("action");
my $action = $query->param("action");
my $client_version = $query->param("version");
my $client_version = $query->param("version");
my $client_object_name = $ENV{"HTTP_X_SECONDLIFE_OBJECT_NAME"};
my $client_object_name = $ENV{"HTTP_X_SECONDLIFE_OBJECT_NAME"};
  $client_object_name =~ s/ v[\d\.]*$//o;
  $client_object_name =~ s/ v[\d\.]*$//o;
my $client_owner_name = $ENV{"HTTP_X_SECONDLIFE_OWNER_NAME"};
my $client_owner_name = $ENV{"HTTP_X_SECONDLIFE_OWNER_NAME"};
#foreach (sort keys %ENV) { print STDERR "$_ = $ENV{$_}\n"; }
#foreach (sort keys %ENV) { print STDERR "$_ = $ENV{$_}\n"; }


# some logging:
# some logging:
print STDERR (strftime "%F %T", localtime) .  
print STDERR (strftime "%F %T", localtime) .  
            " $client_object_name [v${client_version}]" .
    " $client_object_name [v${client_version}]" .
    " (owner: $client_owner_name)\n";
    " (owner: $client_owner_name)\n";


# version checking:
# version checking:
if ($client_version < $VERSION{$client_object_name}) {
if ($client_version < $VERSION{$client_object_name}) {
  $out = "Version expired. New Version $VERSION{$client_object_name} " .
  $out = "Version expired. New Version $VERSION{$client_object_name} " .
"available from MyControl";
"available from MyControl";
  $action = "error";
  $action = "error";
}
}


if ($action eq 'SL-online-now') {
if ($action eq 'SL-online-now') {
  my $html = get("http://www.secondlife.com/");
  my $html = get("http://www.secondlife.com/");
  my $total = $1 if $html =~ /.*Total Residents:.*\n.*>([\d,]{1,})</;
  my $total = $1 if $html =~ /.*Total Residents:.*\n.*>([\d,]{1,})</;
    $total =~ s/,//go;
    $total =~ s/,//go;
  my $online = $1 if $html =~ /.*Online Now:.*\n.*>([\d,]{1,})</;
  my $online = $1 if $html =~ /.*Online Now:.*\n.*>([\d,]{1,})</;
    $online =~ s/,//go;
    $online =~ s/,//go;
  $out = join(';', $online, $total);
  $out = join(';', $online, $total);
} elsif ($action eq 'dict.leo.org') {
} elsif ($action eq 'dict.leo.org') {
  # version checking:
  # version checking:
  my $word = $query->param("word");
  my $word = $query->param("word");
  my $language = $query->param("language");
  my $language = $query->param("language");
  my $language_str = "ende";
  my $language_str = "ende";
  # 0-englisch(default), 1-franzoesisch, 2-spanisch
  # 0-englisch(default), 1-franzoesisch, 2-spanisch
    if ($language == 1) { $language_str = "frde" }
    if ($language == 1) { $language_str = "frde" }
  elsif ($language == 2) { $language_str = "esde" }
  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");
  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";
  #print STDERR "HTML:\n$html\n";
  my $content;
  my $content;
  $content = $1
  $content = $1
    if $html =~ /<table[^>]*id="results"[^>]*>(.*?)<\/table>/s; # no i!
    if $html =~ /<table[^>]*id="results"[^>]*>(.*?)<\/table>/s; # no i!
  #print STDERR "content:\n$content\n";
  #print STDERR "content:\n$content\n";
  #print STDERR "splut:\n";
  #print STDERR "splut:\n";
  my @entries = split /\<tr/i, $content;
  my @entries = split /\<tr/i, $content;
  # remove leading and trailing 2 entries:
  # remove leading and trailing 2 entries:
  #@entries = splice(@entries, 2, -2);
  #@entries = splice(@entries, 2, -2);
  my @out;
  my @out;
  foreach (@entries) {
  foreach (@entries) {
    my @cells = split /<td/i, $_;
    my @cells = split /<td/i, $_;
    my $cell_count = int(@cells);
    my $cell_count = int(@cells);
    #print STDERR "entry: " . int(@cells) ."\n";
    #print STDERR "entry: " . int(@cells) ."\n";
    @cells = map {
    @cells = map {
      s/^[^>]*>//o;
      s/^[^>]*>//o;
      s/<[^>]*>//go;  
      s/<[^>]*>//go;  
      $_; } @cells;
      $_; } @cells;
    if ($cell_count == 6) {
    if ($cell_count == 6) {
      push @out, $cells[2] . " - " . $cells[4];
      push @out, $cells[2] . " - " . $cells[4];
    }
    }
  }
  }
  if (@out) {
  if (@out) {
    $out = join("\n", @out);
    $out = join("\n", @out);
  } else {
  } else {
    $out = "no results";
    $out = "no results";
  }
  }


}
}


# cut to size
# cut to size
$out = substr($out, 0, 2048);
$out = substr($out, 0, 2048);
print "Content-type: text/html\n\n$out\n";
print "Content-type: text/html\n\n$out\n";

Revision as of 01:53, 27 April 2007

#!/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! #print STDERR "content:\n$content\n"; #print STDERR "splut:\n"; 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";

Retrieved from "https://wiki.secondlife.com/w/index.php?title=User:Seph_Swain/perl&oldid=18867"