package provide xotcl::comm::ldap 0.9
 
requireModules { ldapOpen ldaplibGen.so }

Class Ldap -superclass NetAccess -parameter {host port dn attributes scope filter}
Ldap instproc initialize args {
  [self] instvar port mapToC useCache
  [self] set port 389
  [self] set useCache 0
  set mapToC(one) onelevel
  set mapToC(sub) subtree
  set mapToC(base) base
  [self] next
}
Ldap proc urlDecode string {
  set toParse $string
  set parsed ""
  while {1} {
    if {[regexp {^([^%]*)%(..)(.*)$} $toParse _ front hex toParse]} {
      append parsed $front [binary format c 0x$hex]
    } else {
      append parsed $toParse
      break
    }
  }
  return $parsed
}
Ldap instproc getUrlcomponents {} { 
  showCall
  [self] instvar path dn attributes scope filter url
  set path [Ldap urlDecode $path]
  puts stderr "___ path=<$path>"
  if {[regexp -nocase {^/([^?]*)(\?([^?]*)(\?([^?]*)(\?([^?]*))?)?)?$} \
	   $path _ dn a attributes s scope f filter]} {
    if {![string compare "" $scope]} { set scope "base" }
    if {![string compare "" $filter]} { set filter "(objectClass=*)" }
  } else {
    set errmsg    "*** Ldap Url trail=<$path> does not  match!\n"      
    append errmsg "___ RFC 1959 says:\n"
    append errmsg "    ldap://<host>:<port>/<dn>\[?<attributes>\[?<scope>?<filter>\]\]\n"    
    append errmsg "___ Cineast and Netscape uses:\n"
    append errmsg "    ldap://<host>:<port>/<dn>\[?<attributes>\[?<scope>\[?<filter>\]\]\]"
    [self] abort "Unsupported URL: '$url' \n $errmsg"
  }    
}
Ldap instproc GET {} {
  [self] instvar  contentType totalsize state currentsize informObjects block
  showCall
  set contentType text/html
  [self] getUrlcomponents
  if {[string compare start $state]} {
    puts stderr "... [self]:$proc ignoring request in state $state"
    return
  }
  [self] open
  [self] search
  [self] body-state
  set totalsize [string length $block]
  set currentsize $totalsize
  foreach obj $informObjects {
    $obj incCb [self] $totalsize $currentsize
  }
  [self] eof
}
Ldap instproc open {} {
  showCall
  [self] instvar port host  ldapHandle
  set ldapHandle [ldapOpen $host $port]
}
Ldap instproc bind {} {
  [self] instvar ldapHandle
  showCall
}
Ldap instproc search {} {
  showVars
  [self] instvar url ldapHandle searchHandle dn attributes scope filter results mapToC path
  set searchHandle [ldapSearch $ldapHandle $dn \
			$mapToC($scope) $filter [split $attributes ,] false results]
  set nentries [ldapCountEntries $ldapHandle $searchHandle]
  puts stderr "*** nentries = $nentries"
  if {!$nentries} {set results ""}
  [self] response 
}
Ldap instproc getAttrs {dn} {
}
Ldap instproc makeUrl {dn} {
  showCall
  [self] instvar port host scope filter attributes
  set tmpUrl ldap://$host:$port/$dn?$attributes?$scope?$filter
  return "<a href=\"$tmpUrl\">$dn</a>"  
}
Ldap instproc  response {} { 
  showCall
  [self]  instvar block results attrsVals ldapHandle searchHandle
  set block "
<HTML>
 <HEAD><TITLE>LDAP searching result!!</TITLE></HEAD>
 <BODY bgcolor=FFFFFF>
   <H1>Result</H1>\n  <ul>\n"
  foreach {resDN}  $results {
    append block "   <li>  [[self] makeUrl $resDN] <p>\n    <ul>\n"   
    ldapAttributes $ldapHandle $searchHandle $resDN attrsVals
    foreach {a v} [array get attrsVals] {      
      append block "     <li> <FONT COLOR=\"\#cc0000\" face=\"Arial,Helvetica\" size=4><b> $a </b></FONT> = $v <p>\n"    
    }
    append block "    </ul>\n" 
  }
  append block "  </ul>\n </BODY>\n</HTML>"
}

# destructor: Close Connection to LDAP-Server and unbind 
Ldap instproc destroy {} {
  showCall
  [self]  instvar ldapHandle
  if {[catch {ldapUnbind $ldapHandle} error]} {
    return $error
  }
  [self] freeSearchHandle
}
Ldap instproc close {} {
  showCall
  [self] destroy
  [self] next
}
Ldap instproc freeSearchHandle {} { 
  showCall
  [self] instvar searchHandle 
  if {[info exists searchHandle]} {
    ldapFreeSearch $searchHandle  
  }
}
