#!/usr/bin/perl #---------------------------------------------------------------------- # navega v: 20050601-01 - RedIRIS # # script de navegacion por un directorio basado en LDAP # ldap navigation program used in directory services # # Param: # # h= host:puerto del servidor LDAP / host:port # b= DN base de la busqueda # search= cadena / string # filtro= filtro LDAP de busqueda / ldap filter # scope= one | base | subtree # test= cualquier valor (para ver si funciona el LDAP) / test # # Ver fichero todo.txt para ver lo que queda por hacer #---------------------------------------------------------------------- # 20050601 javi - Modify call to certificate print program # &h=$wServer&p=$wPort instead of &b=userCertificate # - Use printLdapCert.pl instead of pinta_de_LDAP.pl # No webber needed # 20050531 javi - English/Spanish version # - Reorganization of a group of vars # 20050113 javi - Añadimos atributos a visualizar como: displayName # 20040928 javi - Quitamos "??base", "??sub", del final de un URL ldap # 20030516 javi - Adición de soporte para sn1 y sn2 # 20021203 javi - Cambio de arr.gif de /ldap/iconos a /iconos/template # También se ha hecho transparente # Creación de variables para todos los iconos # 20021112 Nacho Diaz Asenjo - Correcta visualización # de Multiples direcciones postales en una entrada # 20021030 javi - Control de servidores que dan error cuando les # preguntas por un objectclass (redirisViewControl) que # no tienen # 20020618 javi - 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; %webData = &readParse; #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - # Ini: Configuracion / Config #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - #-- 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 # %attrStrings = ( "cn" => "Name", "sn" => "Surname", "sn1" => "Surname 1", "sn2" => "Surname 2", "description" => "Description", "postaladdress" => "Postal Address", "telephonenumber" => "Telephone", "facsimiletelephonenumber" => "Fax", "mail" => "Mail", "photo" => "Photo (g3fax)", "jpegphoto" => "Photo", "labeleduri" => "URL", "userpassword" => "Password", "aliasedobjectname" => "Alias", "o" => "Organization", "ou" => "Organization", "dc" => "Organization", "usercertificate;binary" => "Certificate", "displayname" => "Displayed Name", "title" => "Title", ); @attrPrint = [ 'cn','sn','sn1','sn2','o','ou','description', 'mail','labeleduri','postaladdress', 'telephonenumber','facsimiletelephonenumber', 'jpegphoto', 'usercertificate;binary', 'idnc', 'displayName', ]; $navegaVersion = "20050601-01"; #-- Scripts used by navega $script{'navega'} = "/ldap/ldap-es/navega"; $script{'showPhoto'} = "/ldap/ldap-es/foto"; $script{'showCert'} = "http://www.rediris.es/cgi-bin/printLdapCert.pl"; #-- Some URLs $urls{'navega'} = "http://www.rediris.es/ldap/software/navega/"; $urls{'world'} = "http://archive.dante.net/nameflow/national.html"; #-- Web server used to load images $webServer = "http://www.rediris.es"; #-- Graphics icons $v = "$webServer/v.gif"; # 1x1 pixel blank image $fleft = "$webServer/iconos/template/fleft.gif"; # left arrow $arr = "$webServer/iconos/template/arr.gif"; # arroba $icLDAP = "$webServer/ldap/iconos/iris-ldap.gif"; # iris-ldap icon #-- LDAP data for Top level dc=es (below world) $ldapDef{'server'} = "ldap.rediris.es"; $ldapDef{'port'} = "389"; $ldapDef{'base'} = "dc=es"; #$ldapDef{'server'} = "alpha.surfnet.nl"; #$ldapDef{'port'} = "389"; #$ldapDef{'base'} = "dc=surfnet,dc=nl"; #-- Servers with redirisViewControl objectclass # These data are obsolete and will be replaced using irisUserPrivateAttribute %serversViewControl = ( "ldap.rediris.es" => "1389", "gummo.rediris.es" => "1389" ); #-- Some strings used in web output $webStrings{'rediris'} = "Red Académica - España"; $webStrings{'navBoxWorld'} = "World / Mundo"; $webStrings{'navBoxTitle'} = "Navigation / Navegación"; $webStrings{'searchBoxTitle'} = "Search / Buscar"; $webStrings{'searchBoxOneLevel'} = "1 level / nivel"; $webStrings{'searchBoxSubtree'} = "subtree / recursivo"; $webStrings{'searchBoxButton'} = " Search / Buscar "; $webStrings{'limitSearch'} = '"El servidor $wServer tiene un límite en el núero de entradas que puede devolver.
Se ha superado dicho límite.
Server $wServer has a limit in the number of entries displayed."'; $webStrings{'serverNameReview'} = '"La entrada:

$wBase

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

$err

Entry:

$wBase

can not be found in the server $wServer. Please review the server name.

$err"'; $webStrings{'problemFindingEntry'} = '"Existe un problema para encontrar la entrada

$wBase

No podemos contactar con el servidor $wServer.

$err

We have a problem finding entry:

$wBase

We can not contact with the server $wServer.

$err"'; $webStrings{'serverProblem'} = '"El servidor $wServer tiene un problema. No podemos contactar con él.

Server $wServer has a problem. We can contact it"'; #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - # End: Configuracion / Config #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - $search = $webData{'search'}; $test = $webData{'test'}; $ldapFilter = ($webData{'filtro'} ne "") ? "(&".$webData{'filtro'}.")" : "" ; #-- Ini - scope $scope = ($webData{'scope'} ne "") ? $webData{'scope'} : "one"; #if ($scope =~ ('base', 'one', 'subtree')) if (($scope ne "base") && ($scope ne "one") && ($scope ne "subtree")) { $scope = "one"; } #-- End - scope if (!defined $webData{'h'}) { $wServer = $ldapDef{'server'}; $wPort = $ldapDef{'port'}; } else { ($wServer,$wPort) = split(/:/,$webData{'h'}); $cPort = "389"; $cPort = $wPort if ($wPort ne ""); $wPort = $cPort; } $wBase = (!defined $webData{'b'}) ? $ldapDef{'base'} : $webData{'b'}; #-- Tenemos que quitar la porqueria como en: # o=Aegean,c=GR??base ($wBase,$kk) = split (/\?/,$wBase); &printHeader; #print "
Base:>$wBase<"; $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) { navParents($wBase); } else { print "OK - LDAP Server $wServer:$wPort/$wBase\n"; $pLDAP->unbind; exit(1); } #-- Comprobamos si hay algun error como: que el servidor tenga version 2 #-- Error management: example, if ldap server version is 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") { &message ( $webStrings{'serverNameReview'} ); &pie; exit; } else { &message ( $webStrings{'problemFindingEntry'} ); &pie; exit; } } #-- Ini - Pintamos los datos de la entrada - We write entry data $rdo = $pLDAP->search ( base => $wBase, scope => "base", filter => "(objectclass=*)", attrs => @attrPrint, ); printEntry ($rdo->entry(0)); #-- End - Pintamos los datos de la entrada - We write entry data print "

    "; #--- Por si nos mandan un filtro LDAP desde el LIMS # We coul receive an LDAP filter from LIMS (Roland) if ($ldapFilter ne "") { $rdo = $pLDAP->search ( base => $wBase, #scope => 'subtree', scope => $scope, #-- Recordar que en el LIMS debe mandarse con subtree - Lims send it with subtree filter => $ldapFilter, 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 { # These data are obsolete and will be replaced using irisUserPrivateAttribute #-- 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)) # $ldapFilterControl = "(objectclass=*)"; # These data are obsolete and will be replaced using irisUserPrivateAttribute if ($serversViewControl{$wServer} eq $wPort) { $ldapFilterControl = '(!(objectclass=redirisViewControl))'; } $rdo = $pLDAP->search ( base => $wBase, scope => $scope, filter => $ldapFilterControl, attrs => ['cn','description','dc','ou','idnc'], callback => \&ppal, ); } #$rdo->code && die $rdo->error; if ($rdo->error ne "Success") { if ($rdo->error eq "Sizelimit exceeded") { print "
"; &message ( $webStrings{'limitSearch'} ); } else { print ("

ERROR:2: ".$rdo->error); } } print ""; $pLDAP->unbind; } else { if (!defined $test) { navParents($wBase); &message ( $webStrings{'serverProblem'} ); } else { print "ERROR - LDAP Server $wServer:$wPort/$wBase\n"; $pLDAP->unbind; } } &pie if (!defined $test); #---------------------------------------------------------------------- # Function: ppal # Descript: Main function #---------------------------------------------------------------------- sub ppal { my $mesg = shift; my $obj = shift; $urlWeb = $script{'navega'}."?h="; if (!$obj) { #-- Se acabaron las entradas #print "
Fin"; } elsif ($obj->isa('Net::LDAP::Reference')) { #-- Procesado de referencias LDAPv3 # We process LDAPV3 referrals my $ref; foreach $ref ($obj->references) { #-- Obtenemos servidor, puerto y base # We obtain ldap server, port and base # print "

  • $ref"; #--- Quitamos el texto "ldap://" # We delete text "ldap://" ($kk,$refe) = split(/:\/\//,$ref); #-- Quitamos "??base", "??sub", del final # Se añade gracias al rfc3296 ($refe,$kk) = split(/\?\?/,$refe); #--- Separamos el nombre del servidor del puerto # Split server and port ($rServer,$rBase) = split(/\//,$refe); ($rServer,$rPort) = split(/:/,$rServer); $rPort = ($rPort ne "") ? ":$rPort" : ":389"; #print "
  • $rBase"; #-- 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 # Process normal entries - 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>"; } elsif ($obj->get_value('idnc') ne "") { print "idnc: ".utf8_lat1($obj->get_value('idnc'))."<\/a>"; } else { print "$dnWeb<\/a>"; } print " - ".utf8_lat1($obj->get_value('description')) if ($obj->get_value('description') ne ""); print "\n"; } } #---------------------------------------------------------------------- # Function: message # Descript: Print a text #---------------------------------------------------------------------- sub message { my $co = shift; my $cadena = eval $co; if (!defined $cadena) { $cadena = $co; } print <

    $cadena
    ENDSTRING } #---------------------------------------------------------------------- # Function: readParse # Descript: #---------------------------------------------------------------------- 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; } #----------------------------------------------------------------------- # Function: printHeader # Descript: #----------------------------------------------------------------------- sub printHeader { if (!defined ($test)) { print < RedIRIS - Navega por ldap-es
    Servicios LDAP Consultas en España

    LDAP Directory Servers Navigator

    LDAP server: $wServer:$wPort     		SDir
    ENDSTRING } else { print"Content-type: text/plain\n\n"; } } #----------------------------------------------------------------------- # Function: pie # Descript: Footpage #----------------------------------------------------------------------- sub pie { print <

    Please send modification requests to the organisation the data item belongs to and not to the webmaster or administrator of this gateway.
    		     
    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.

    This gateway was made with rediris navega software v: $navegaVersion ENDSTRING } #----------------------------------------------------------------------- # Function: utf8_lat1 # Descript: #----------------------------------------------------------------------- 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; } #----------------------------------------------------------------------- # Function: navParents # Descript: #----------------------------------------------------------------------- sub navParents { my $entry = shift; $str1 = $script{'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? # #-- Hay que tener en cuenta que el nombre del atributo # puede contener guiones (los de IRISGrid) # $entry =~ s/[, ]+(\w+)=/#caca#$1=/g; $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 <

    ENDSTRING } print <
    $webStrings{'navBoxTitle'}
    \n"; if ($#rdns > 0) { print <
  • $webStrings{'navBoxWorld'} ENDSTRING #-- If Spain we put string "Red Academica - España" if ( ($rdns[$#rdns] eq "dc=es") || ($rdns[$#rdns] eq "c=ES") || ($rdns[$#rdns] eq "c=es") ) { print "
  • ". $webStrings{'rediris'}."\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 "
    • $webStrings{'searchBoxTitle'}:  $webStrings{'searchBoxOneLevel'}  $webStrings{'searchBoxSubtree'}
     
    ENDSTRING } #----------------------------------------------------------------------- # Function: printEntry # Descript: #----------------------------------------------------------------------- sub printEntry { 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 " $attrStrings{$attr} "; my $cuentaDir=1; foreach my $value (@aValue) { if ($attr eq "mail") { # Cambiamos kk@kk.kk por # kk@kk.kk #--- Ini: To avoid spam / Para evitar un posible spam #print "
  • $value"; #print "
  • $value"; my ($a,$b) = split /\@/, $value; print "
  • $a$b"; #--- End: To avoid spam / Para evitar un posible spam } elsif ($attr eq "labeleduri") { # We change http://kk.kk.kk URL_name by # URL_name # # 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") { # We change kk $ kk $ kk $ kk by # kk
    kk
    kk
    kk # # 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]; } #-- Thanks to/Gracias a Nacho Diaz Asenjo # if ($cuentaDir <= $#aValue) { print "
    "; } $cuentaDir++; } elsif ($attr eq "jpegphoto") { print " "; print ""; } elsif ($attr eq "usercertificate;binary") { print "Show certificate / Ver el certificado"; } else { #-- Any other attribute print utf8_lat1($value)."
    "; } } print "
    • '; } #---------------------------------------------------------------------- # Fin de navega #----------------------------------------------------------------------