Difference between revisions of "User:Seph Swain/perl"
Jump to navigation
Jump to search
Seph Swain (talk | contribs) |
Seph Swain (talk | contribs) |
||
Line 1: | Line 1: | ||
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§Hdr=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 /<td/i, $_; | |||
my $cell_count = int(@cells); | |||
#print STDERR "entry: " . int(@cells) ."\n"; | |||
@cells = map { | |||
s/^[^>]*>//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"; |
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§Hdr=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";