FreewarWiki:Bot/Skripts/npclist.pl

Dieses Script ist hier lediglich archiviert und nicht direkt lauffähig. Wenn Du es benutzen möchtest, musst Du es lokal abspeichern und mit einem geeigneten Interpreter ausführen lassen. Zum Übernehmen solltest Du nicht den unten angezeigten Text verwenden, sondern den Quelltext des Wiki-Artikels: Dazu wählst Du Bearbeiten und kopierst den (meist zwischen PRE-Tags eingefassten) Scripttext.

Sofern Du die Scripte dauerhaft lokal abgespeichert hältst, solltest Du sie vor der nächsten Ausführung darauf prüfen, ob sie noch aktuell sind.

Letzter Bearbeiter: Zabuza — Zuletzt bearbeitet: 20.03.2012

#!/usr/bin/perl

use strict;
use LWP::UserAgent;
use URI::Escape;
use HTTP::Request;
use constant CUnknown => "?";

my $ua = LWP::UserAgent->new();
my $host = "http://www.fwwiki.de";
my $url = $host . "/index.php/Kategorie:NPCs";
my @urllist;




push(@urllist, $url);


# als erstes die URLs aufsammeln, die auf die aufeinanderfolgenden Kategorieseiten verweisen:
while($url ne "")  {
    my $request = HTTP::Request->new("GET", $url);
    my $response = $ua->simple_request($request);
    my $c = $response->content();


    $url = "";
    if ($c =~ /(<a [^>]*Kategorie:NPCs[^<]*)(n[^<]*chste \d+)/im) { # Zeichenkette mit der Angabe "nächste n" ermitteln
        # $1 enthält jetzt die URL im Format <a ... href="..." ... >
        $c = $1;
        # print "HTML-URL: " . $c . "\n";
        if ($c =~ /href=\"([^\"]*)/im) { # ... aus href="..." rausfummeln
             $url = $host . $1;
             $url =~ s/\N{U+0026}amp;/&/g;
             push(@urllist, $url);
        }
    }
}

# Nun die Kategorieseiten abarbeiten:

foreach (@urllist) {
    my $request = HTTP::Request->new("GET", $_);
    my $response = $ua->simple_request($request);
    my $c = $response->content();

    while($c =~ /<a([^>]*)>([^<]*)<\/a>/gm) {
        my ($anchor, $text) = ($1, $2);
        my $href;
        $href = $1 if ($anchor =~ /href\s*=\s*"([^"]*)"/);
        $href =~ s/\N{U+0026}amp;/&/g;
        my $title;
        $title = $1 if ($anchor =~ /title\s*=\s*"([^"]*)"/);
        next if ($href eq "");
        registerNpc($text, $host.$href) if ($title eq $text);
    }
}

sub trim($) {
    my $string = shift;
    $string =~ s/^\s+//;
    $string =~ s/\s+$//;
    return $string;
}


sub registerNpc {
  my ($text, $href) = @_;
  my $request = HTTP::Request->new("GET", $href."?action=edit");
  my $response = $ua->simple_request($request);
  my $c = $response->content();
  $c =~ tr/\n/ /;

  my $atk = CUnknown;
  my $xp = CUnknown;
  my $lp = CUnknown;
  my $gm = CUnknown;
  my $drops;
  my @vklist;
  my @itemlist;
  my $bild;
  my $bildautor;
  my $baindex;


  if ($c =~ /\|\s*St..?rke\s*=\s*([0-9.]+)/i) {
    $atk = $1;
    $atk =~ s/\.//g;
  }
  
  if ($c =~ /\|\s*Lebenspunkte\s*=\s*([0-9.]+)/i) {
    $lp = $1;
    $lp =~ s/\.//g;
  }

  $xp = $1 if ($c =~ /\|\s*XP\s*=\s*(\d+)/i);
  $gm = $1 if ($c =~ /\|\s*Gold\s*=\s*(\d+)/i);
  $bild = trim($1) if ($c =~ /\|\s*Bild\s*=\s*([^|}]*)/i);
  
  
  $bildautor = trim($1) if ($c =~ /\|\s*Bildautor\s*=\s*([^|}]*)/i);

  # Falls der BildAutor durch Verlinkungen | enthält überspringe dieses |
  if (($bildautor =~ m/\[\[Benutzer:/i) or ($bildautor =~ m/\[\[User:/i)) {
	$baindex = length($bildautor) +1;
	$bildautor = trim($1) if ($c =~ /\|\s*Bildautor\s*=\s*(.{$baindex}[^|}]*)/i);
  }

  if ($c=~ /\|Vorkommen\s*=\s([^=]*)/) {
      my $vk=$1;
      while ($vk =~ /\*\s*\[\[([^\]]+)\]\]/ogm)
      {
          my $area = $1;
          $area = $1 if ($area =~ /(.*)\|/);
          push(@vklist, $area);
      }
  }
  if ($c=~ /\|Items\s*=\s([^=]*)/) {
      my $it=$1;
      while ($it =~ /\*\s*\[\[([^\]]+)\]\]/og) 
      {
          push(@itemlist, $1);
      }
  }
  while ($c=~/\{\{Feld\|[^|]+\|[^|]+\|(\d+)\|(\d+)\}\}/ogm) {
      push(@vklist, "$1,$2");
  }
  # nur ausgeben, wenn mindestens eine Eigenschaft erkannt wurde:
  if (($atk ne CUnknown) || $xp ne CUnknown || $lp ne CUnknown || $gm ne CUnknown) {
    print "$text;$atk;$lp;$xp;$gm;";
    print join("/", @vklist);
    print ";";
    print join("/", @itemlist);
    print ";$bild;$bildautor";
    print "\n";
  }

}