13308-1-Lingüística de corpus

# cercaCorde.pl
use strict;
use integer;
use Net::HTTP;
use URI::Escape;


#-----------------------------------------------------------------------------------------
my ($name,@linies,$k,$nomFitxer,$servidor,$nomPag);
my ($partFixa,@text,$x,$nombreOcurr,$nombreDocs);

#-----------------------------------------------------------------------------------------
my $path = '/Users/Shared/perl/corde/';
$path = 'd:/LdYM/perl/corde/';

#-----------------------------------------------------------------------------------------

sub zeroXifra {
my $text=$_[0];
while (length($text)<$_[1]) {$text = '0'.$text}
return $text;
}

sub salvaText {
@linies=();
push(@linies,''."\n");
push(@linies,@text);
$nomFitxer = 'corde'.$name.'.html';
if (-e "$path"."$nomFitxer") {
	print STDERR "Ja existia: $path"."$nomFitxer\n";
	return 0;
	}
$x = join(' ',@text);
#No existen casos para esta consulta.
if ($x =~ /No existen casos para esta consulta\./) {
	print "0\t0";
	return 0;
	}
if ($x =~ / ([\d]+) casos? en ([\d]+) documentos?\./) {
	($nombreOcurr,$nombreDocs)= ($1,$2);
	print "$nombreOcurr\t$nombreDocs";
	return 0;
	}
open (SORTIDA,">"."$path".$nomFitxer);
print SORTIDA "@linies\n";
close(SORTIDA);
print STDERR "Situacio no prevista al fitxer $name.\n";
}

sub demanda {
@text=();
#print STDERR "Aprofundim amb $name ($servidor)\n$nomPag",'-' x 20,"\n";
my $s = Net::HTTP->new(Host => "$servidor") || die $@;
$s->write_request(GET => "$nomPag", 'User-Agent' => "Mozilla/5.0");
my($code, $mess, %h) = $s->read_response_headers;
@text = ();
while (1) {
	my $buf;
	my $n = $s->read_entity_body($buf, 1024);
	die "read failed: $!" unless defined $n;
	last unless $n;
	push (@text,$buf);
	}
salvaText if $text[0];
}

sub generaUrl  {
$nomPag = $partFixa;
$nomPag =~ s/texto=xxxxx/texto=$_[1]/;
$nomPag =~ s/autor=xxxxx/autor=$_[2]/;
$name=zeroXifra($_[0],5);
demanda;
}

sub recorreLLista {
print STDERR "$_[1]\t$_[2]\t",'-' x 20,"\n";
my  $m1 = uri_escape($_[1]);
my  $m2 = uri_escape($_[2]);
print "$m1\t$m2\t";
generaUrl($_[0],$m1,'Col%F3n');
print "\t";
generaUrl($_[0]+20000,$m2,'Col%F3n');
print "\t";
generaUrl($_[0]+40000,$m1,'');
print "\t";
generaUrl($_[0]+60000,$m2,'');
print "\n";
}

#-----------------------------------------------------------------------------------------

$servidor = 'corpus.rae.es';
$partFixa = "/cgi-bin/crpsrvEx.dll?MfcISAPICommand=buscar&tradQuery=1&destino=1&texto=xxxxx";
$partFixa .= "&autor=xxxxx&titulo=&ano1=1406&ano2=1506&medio=1000&pais=1000&tema=1000";


#my @cercats = ('sebilla','sevilla','nuebo','nuevo','enbiar','enviar','embiar','emviar');
my @cercats = ('correu','correo','custa','cuesta','custas','cuestas','deseu','deseo',
'dispusiçión','disposiçión','dispusiçión','disposición','indispusiçión','indisposiçión',
'indispusiçión','indisposición','duzientas','dozientas','duzientos','dozientos',
'pudía','podía','pudido','podido','punga','ponga','sudueste','sudoeste','unze','onze',
'unze','once');
@cercats = ('dispusiçión','disposición');
@cercats = ('sudueste','sudoeste');
$k=0;

print STDERR " \t \tNoc1a1\tNdo1a1\tNoc2a1\tNdo2a1\tNoc1a2\tNdo1a2\tNoc2a2\tNdo2a2\n",'-' x 50,"\n";
while (scalar @cercats) {
	recorreLLista(++$k,shift(@cercats),shift(@cercats));
	}

#################


Nota bene

  1. Per tal que funcioni, cal instal·lar Net::HTTP. La manera senzilla és descomprimir el fitxer NetHTTP.zip (suposant que ja hem fet una instal·lació estàndard amb ActivePerl) a la carpeta c:\aplic\ActivePerl\site\lib\Net.
  2. Mentre el Perl no estigui al PATH, podeu executar l'ordre set path=c:\aplic\activePerl\bin;%PATH%, copiant-la d'ací a la finestra de comandes (Sant Botó Dret)
  3. Si voleu facilitar-ho, podeu crear-vos a la t: un BAT (v.g. prepara.bat) que contingui la línia precedent i que vosaltres executareu abans de cada sessió amb perl des de la línia de comandes.