#!/usr/bin/perl #---------------------------------------------------------------------- # navega v: 20021112-01 - RedIRIS # # script de navegacion por un directorio basado en LDAP # # Parametros: # # h= host:puerto del servidor LDAP # b= DN base de la busqueda # search= cadena # filtro= filtro LDAP de busqueda # scope= one | base | subtree # test= cualquier valor (para ver si funciona el LDAP) # # Ver fichero todo.txt para ver lo que queda por hacer #---------------------------------------------------------------------- # 20021112 Nacho Diaz Asenjo - Correcta visualización # de Multiples direcciones postales en una entrada # 20021030 _avi - Control de servidores que dan error cuando les # preguntas por un objectclass (redirisViewControl) que # no tienen # 20020618 _avi - Control de visibilidad de entradas mediante la clase # redirisViewControl #---------------------------------------------------------------------- use Net::LDAP; use Net::LDAP::Control; use Net::LDAP::Search; #use XTM::XML::UTF; use URI::Escape; #%datos = &obtenDatos; %datos = &ReadParse; #-- Hay que poner los nombres de campos en minúsculas porque algunos # servidores devuelven los nombres así. Luego pasaremos los nombres # de atributos a minúsculas para que no haya problemas %campos_es = ( "cn" => "Nombre", "sn" => "Apellidos", "description" => "Descripción", "postaladdress" => "Dir. Postal", "telephonenumber" => "Teléfono", "facsimiletelephonenumber" => "Fax", "mail" => "correo", "photo" => "Fotografía (g3fax)", "jpegphoto" => "Fotografía", "labeleduri" => "URL", "userpassword" => "Clave", "aliasedobjectname" => "Alias", "o" => "Organización", "ou" => "Organización", "dc" => "Organización", "usercertificate;binary" => "Certificado" ); @camposPintar = [ 'cn','sn','o','ou','description', 'mail','labeleduri','postaladdress', 'telephonenumber','facsimiletelephonenumber', 'jpegphoto', 'usercertificate;binary' ]; #-- Servidores que tienen definido redirisViewControl en sus clases %serversViewControl = ( "ldap.rediris.es" => "1389" ); #-- Base para las imágenes del web $webServer = "http://www.rediris.es"; #-- Scripts navega y foto $navega = "/cgi/ldap/ldap-es/navega"; $foto = "/cgi/ldap/ldap-es/foto"; #-- servidor LDAP y puerto de dc=es $ldapEsServer = "ldap.rediris.es"; $ldapEsPort = "389"; $search = $datos{'search'}; $test = $datos{'test'}; $filtro = ($datos{'filtro'} ne "") ? "(&".$datos{'filtro'}.")" : "" ; #-- Ini - scope $scope = ($datos{'scope'} ne "") ? $datos{'scope'} : "one"; #if ($scope =~ ('base', 'one', 'subtree')) if (($scope ne "base") && ($scope ne "one") && ($scope ne "subtree")) { $scope = "one"; } #-- Fin - scope if (!defined $datos{'h'}) { $wServer = $ldapEsServer; $wPort = $ldapEsPort; } else { ($wServer,$wPort) = split(/:/,$datos{'h'}); $cPort = "389"; $cPort = $wPort if ($wPort ne ""); $wPort = $cPort; } $wBase = (!defined $datos{'b'}) ? "dc=es" : $datos{'b'}; #-- Tenemos que quitar la porqueria como en: # o=Aegean,c=GR??base ($wBase,$kk) = split (/\?/,$wBase); &Cabecera; $pLDAP = Net::LDAP->new ( $wServer, port => $wPort, timeout => 10, async => 1, );# or print "$@"; if (defined $pLDAP) { $pLDAP->bind ( anonymous => 1, version => 3 ); $rdo = $pLDAP->search ( base => $wBase, scope => "base", filter => "(c=tv)", ); if (!defined $test) { pintaPadres($wBase); } else { print "OK - LDAP Server $wServer:$wPort/$wBase\n"; $pLDAP->unbind; exit(1); } #-- Comprobamos si hay algun error como: que el servidor tengaversion 2 my $err = $rdo->error; if ($err ne "Success") { if ($err eq "Protocol Error") { $pLDAP->bind ( anonymous => 1, version => 2 ); } elsif ($err eq "No such object") { &mensaje ("La entrada:

$wBase

no puede ser encontrada en el servidor $wServer. Por favor revise que el nombre es correcto.

$err"); &pie; exit; } else { &mensaje ("Existe un problema para encontrar la entrada

$wBase

No podemos contactar con el servidor $wServer.

$err"); &pie; exit; } } #-- Ini - Pintamos los datos de la entrada $rdo = $pLDAP->search ( base => $wBase, scope => "base", filter => "(objectclass=*)", attrs => @camposPintar, ); pintaEntrada ($rdo->entry(0)); #-- Fin - Pintamos los datos de la entrada print "

    "; #--- Por si nos mandan un filtro LDAP desde el LIMS if ($filtro ne "") { $rdo = $pLDAP->search ( base => $wBase, #scope => 'subtree', scope => $scope, #-- Recordar que en el LIMS debe mandarse con subtree filter => $filtro, attrs => ['cn','description'], callback => \&ppal ); } elsif ($search ne "") { #my $filtrito = "(|(uid=*$search*)(cn=*$search*)(sn=*$search*)(o=*$search*)(ou=*$search*)(dc=*$search*)(mail=*$search*)(objectClass=$search))"; my $filtrito = "(|(uid=*$search*)(cn=*$search*)(sn=*$search*)(o=*$search*)(ou=*$search*)(dc=*$search*)(mail=*$search*))"; #print "Filtro: $filtrito"; $rdo = $pLDAP->search ( base => $wBase, scope => $scope, filter => $filtrito, attrs => ['cn','description'], callback => \&ppal ); } else { #-- Mostramos todo lo que no tenga un objectclass del tipo "redirisViewControl" # Ya veremos en un futuro si añadimos control de atributos # # 20021030 Hay que tener cuidado con algunos servidores que al no # tener ese objeto en sus esquemas dan error cuando se les # pasa un filtro que contiene (!(objectclass=redirisViewControl)) # $filtroControl = "(objectclass=*)"; if ($serversViewControl{$wServer} eq $wPort) { $filtroControl = '(!(objectclass=redirisViewControl))'; } $rdo = $pLDAP->search ( base => $wBase, scope => $scope, filter => $filtroControl, attrs => ['cn','description','dc','ou'], callback => \&ppal, ); } #$rdo->code && die $rdo->error; if ($rdo->error ne "Success") { if ($rdo->error eq "Sizelimit exceeded") { print "
"; &mensaje ("El servidor $wServer tiene un límite en el número de entradas que puede devolver.
Se ha superado dicho límite."); } else { print ("

ERROR:2: ".$rdo->error); } } print ""; $pLDAP->unbind; } else { if (!defined $test) { pintaPadres($wBase); &mensaje ("El servidor $wServer tiene un problema. No podemos contactar con él."); } else { print "ERROR - LDAP Server $wServer:$wPort/$wBase\n"; $pLDAP->unbind; } } &pie if (!defined $test); #---------------------------------------------------------------------- # Funcion: ppal #---------------------------------------------------------------------- sub ppal { my $mesg = shift; my $obj = shift; $urlWeb = "$navega?h="; if (!$obj) { #-- Se acabaron las entradas #print "
Fin"; } elsif ($obj->isa('Net::LDAP::Reference')) { #-- Procesado de referencias LDAPv3 my $ref; foreach $ref ($obj->references) { #-- Obtenemos servidor, puerto y base #print "

  • $ref"; #--- Quitamos el texto "# ldap://" ($kk,$refe) = split(/:\/\//,$ref); #--- Separamos el nombre del servidor del puerto ($rServer,$rBase) = split(/\//,$refe); ($rServer,$rPort) = split(/:/,$rServer); $rPort = ($rPort ne "") ? ":$rPort" : ":389"; #-- Convertimos los %xx a sus valores reales $wrBase = uri_unescape($rBase); $urlWeb .= "$rServer$rPort&b=$rBase"; print "
  • $wrBase"; print " - (referencia)"; } } else { #-- Procesado de entradas normales - Net::LDAP::Entry $urlWeb .= "$wServer:$wPort&b="; # $urlWeb .= uri_escape ($obj->dn, "[=:]"); $urlWeb .= uri_escape ($obj->dn); # $urlWeb =~ s/ /+/g; #--- Por el tema de los DNs en Netscape 4.79 (my $dnWeb, my $kk) = split /,/,$obj->dn; print "
  • "; #print "$dnWeb<\/a> - "; if ($obj->get_value('cn') ne "") { print "".utf8_lat1($obj->get_value('cn'))."<\/a>"; } elsif ($obj->get_value('ou') ne "") { print "ou: ".utf8_lat1($obj->get_value('ou'))."<\/a>"; } elsif ($obj->get_value('dc') ne "") { print "dc: ".utf8_lat1($obj->get_value('dc'))."<\/a>"; } else { print "$dnWeb<\/a>"; } print " - ".utf8_lat1($obj->get_value('description')) if ($obj->get_value('description') ne ""); print "\n"; } } #---------------------------------------------------------------------- # Funcion: mensaje #---------------------------------------------------------------------- sub mensaje { my $cadena = shift; print <

    $cadena
    FIN } #---------------------------------------------------------------------- # Funcion: ObtenDatos #---------------------------------------------------------------------- sub obtenDatos { if ($ENV{'REQUEST_METHOD'} eq "POST") { read(STDIN, $request, $ENV{'CONTENT_LENGTH'}); } elsif ($ENV{'REQUEST_METHOD'} eq "GET" ) { $request = $ENV{'QUERY_STRING'}; } $request =~ s/\+/ /g; @F = split(/[&=]/, $request); $i=0; while ($i <= $#F) { print "
    $i - $F[$i]"; $F[$i] =~ s/%(..)/pack("c",hex($1))/ge; $i++; } if (scalar @F % 2 == 1) { print "
    entro $F[$i]"; push @F, ""; } return @F; } #---------------------------------------------------------------------- # Funcion: ReadParse #---------------------------------------------------------------------- sub ReadParse { if ($ENV{'REQUEST_METHOD'} eq "GET") { $in = $ENV{'QUERY_STRING'}; } elsif ($ENV{'REQUEST_METHOD'} eq "POST") { for ($i = 0; $i < $ENV{'CONTENT_LENGTH'}; $i++) { $in .= getc; } } @in = split (/&/, $in); foreach $i (0 .. $#in) { $in[$i] =~ s/\+/ /g; $in[$i] =~ s/%(..)/pack("c", hex ($1))/ge; $loc = index ($in[$i], "="); $key = substr ($in[$i], 0, $loc); $val = substr ($in[$i], $loc + 1); $in{$key} .= '\0' if (defined ($in{$key})); $in{$key} .= $val; } return %in; } #----------------------------------------------------------------------- # Funcion: Cabecera # Descrip: #----------------------------------------------------------------------- sub Cabecera { if (!defined ($test)) { print <
    Servicios LDAP Consultas en España

    Consultas al Servicio de Directorio LDAP

    Consulta LDAP a: $wServer:$wPort     		SDir
    FIN } else { print"Content-type: text/plain\n\n"; } } #----------------------------------------------------------------------- # Funcion: pie # Descrip: #----------------------------------------------------------------------- sub pie { print <

    Por favor envíe las peticiones de modificación de datos a la organización bajo la que se encuentra la entrada que desea modificar. No lo haga al administrador de esta pasarela.
    		     
    Please send modification requests to the organisation the data item belongs to and not to the webmaster or administrator of this gateway.
    FIN } #----------------------------------------------------------------------- # Funcion: utf8_lat1 # Descrip: #----------------------------------------------------------------------- sub utf8_lat1 { my $cad = shift; $cad =~ s/\xC2\xAA/ª/g; $cad =~ s/\xC2\xBA/º/g; $cad =~ s/\xC3\x91/Ñ/g; $cad =~ s/\xC3\xB1/ñ/g; $cad =~ s/\xC3\x81/Á/g; $cad =~ s/\xC3\x89/É/g; $cad =~ s/\xC3\x8D/Í/g; $cad =~ s/\xC3\x93/Ó/g; $cad =~ s/\xC3\x9A/Ú/g; $cad =~ s/\xC3\xA1/á/g; $cad =~ s/\xC3\xA9/é/g; $cad =~ s/\xC3\xAD/í/g; $cad =~ s/\xC3\xB3/ó/g; $cad =~ s/\xC3\xBA/ú/g; $cad =~ s/\xC3\x80/À/g; $cad =~ s/\xC3\x88/È/g; $cad =~ s/\xC3\x8C/Ì/g; $cad =~ s/\xC3\x92/Ò/g; $cad =~ s/\xC3\x99/Ù/g; $cad =~ s/\xC3\xA0/à/g; $cad =~ s/\xC3\xA8/è/g; $cad =~ s/\xC3\xAC/ì/g; $cad =~ s/\xC3\xB2/ò/g; $cad =~ s/\xC3\xB9/ù/g; $cad =~ s/\xC3\x84/Ä/g; $cad =~ s/\xC3\x8B/Ë/g; $cad =~ s/\xC3\x8F/Ï/g; $cad =~ s/\xC3\x96/Ö/g; $cad =~ s/\xC3\xA4/ä/g; $cad =~ s/\xC3\xAB/ë/g; $cad =~ s/\xC3\xAF/ï/g; $cad =~ s/\xC3\xB6/ö/g; $cad =~ s/\xC3\xBC/ü/g; $cad =~ s/\xC3\x9C/Ü/g; $cad =~ s/\xC3\xA5/å/g; return $cad; } #----------------------------------------------------------------------- # Funcion: pintaPadres # Descrip: #----------------------------------------------------------------------- sub pintaPadres { my $entry = shift; #-- Ini - Navegacion hacia arriba en el arbol $cad1 = "$navega?h=$wServer:$wPort&b="; #-- Hay que tener mucho cuidado con entradas del tipo: # cn="lopez gomez, alfonso", ou=depto. aa, dc=uu, dc=es # ¿Como partimos? $entry =~ s/[, ]+(\w+)=/#caca#$1=/g; #print "

    $entry
    "; @rdns = split /#caca#/,$entry; # http://ldap.rediris.es/ldap-es/navega?h=ldap.uji.es:389&b=cn=%22GOMEZ%20SALES,%20JOSE%20ANTONIO%22,%20ou=%22Enginyeria%20Industrial%22,%20ou=%22Estudiantat%20de%20primer%20i%20segon%20cicle%22,%20ou=%22Estudiantat%22,%20o=Universitat%20Jaume%20I,%20c=ES #$rdnBase = "$rdns[$#rdns-1],$rdns[$#rdns]"; $rdnBase = "$rdns[$#rdns]"; print <

    FIN } print <
    Navegación
    \n"; if ($#rdns > 0) { print <
  • Mundo FIN if ( ($rdns[$#rdns] eq "dc=es") || ($rdns[$#rdns] eq "c=ES") || ($rdns[$#rdns] eq "c=es") ) { print "
  • Red Académica - España\n"; } else { #print "
  • $rdns[$#rdns]\n"; print "
  • $rdns[$#rdns]\n"; } for ($i=$#rdns-1; $i>=0 ; $i--) { $rdnBase = "$rdns[$i],$rdnBase"; # Escapamos el $rdnBase por si nos encontramos rdns del tipo # ou="Estudiantat" print "
  • $rdns[$i]\n"; } print "
    • Buscar:  1 nivel,  recursivo
     
    FIN #-- Fin - Navegacion hacia arriba en el arbol } #----------------------------------------------------------------------- # Funcion: pintaEntrada # Descrip: #----------------------------------------------------------------------- sub pintaEntrada { my $entry = shift; my @attrs = $entry->attributes; print '

    \n"; foreach my $attr (@attrs) { #-- Para evitar pintar las fotos #next if ( $attr =~ /;binary$/ ); my @aValue = $entry->get_value( $attr ); $attr =~ tr/A-Z/a-z/; print ' \n"; } print '
    '; print "$wBase 
    '; print " $campos_es{$attr} "; my $cuentaDir=1; foreach my $value (@aValue) { if ($attr eq "mail") { # Cambiamos kk@kk.kk por # kk@kk.kk #--- Ini: Para evitar un posible spam #print "
  • $value"; #print "
  • $value"; my ($a,$b) = split /\@/, $value; print "
  • $a$b"; #--- Fin: Para evitar un posible spam } elsif ($attr eq "labeleduri") { # Cambiamos http://kk.kk.kk Nombre del URL por # Nombre del URL (my $url, my $txt) = split / /, $value, 2; $txt = ($txt eq "") ? $url : $txt; $txt = utf8_lat1 ($txt); print "
  • $txt"; } elsif ($attr eq "postaladdress") { # Cambiamos los kk $ kk $ kk $ kk por # kk
    kk
    kk
    kk @direccion = split /\$/, $value; #foreach my $dir (@direccion) #{ # print "
    $dir"; #} print utf8_lat1($direccion[0]); for (my $idir = 1; $idir <= $#direccion; $idir++) { print "
    ".utf8_lat1($direccion[$idir]); #print "
    ".$direccion[$idir]; } #-- Gracias a Nacho Diaz Asenjo # if ($cuentaDir <= $#aValue) { print "
    "; } $cuentaDir++; } elsif ($attr eq "jpegphoto") { print " "; print ""; } elsif ($attr eq "usercertificate;binary") { print "Ver el certificado"; } else { print utf8_lat1($value)."
    "; } } print "
    • '; } #---------------------------------------------------------------------- # Fin de navega #----------------------------------------------------------------------