;;; eudcb-ph.el --- Emacs Unified Directory Client - CCSO PH/QI Backend;; Copyright (C) 1998 Free Software Foundation, Inc.;; Author: Oscar Figueiredo <oscar@xemacs.org>;; Maintainer: Oscar Figueiredo <oscar@xemacs.org>;; Created: Feb 1998;; Version: $Revision$;; Keywords: help;; This file is part of XEmacs;; XEmacs is free software; you can redistribute it and/or modify it;; under the terms of the GNU General Public License as published by;; the Free Software Foundation; either version 2, or (at your option);; any later version.;; XEmacs is distributed in the hope that it will be useful, but;; WITHOUT ANY WARRANTY; without even the implied warranty of;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU;; General Public License for more details.;; You should have received a copy of the GNU General Public License;; along with XEmacs; see the file COPYING. If not, write to ;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,;; Boston, MA 02111-1307, USA.;;; Commentary:;; This library provides specific CCSO PH/QI protocol support for the ;; Emacs Unified Directory Client package;;; Code:(require'eudc);;{{{ Internal cooking(eudc-protocol-set'eudc-bbdb-conversion-alist'eudc-ph-bbdb-conversion-alist'ph)(eudc-protocol-set'eudc-query-function'eudc-ph-query-internal'ph)(eudc-protocol-set'eudc-list-attributes-function'eudc-ph-get-field-list'ph)(eudc-protocol-set'eudc-protocol-has-default-query-attributest'ph)(defvareudc-ph-process-buffernil)(defvareudc-ph-read-point)(defconsteudc-ph-default-server-port105"Default TCP port for CCSO PH/QI directory services.")(defuneudc-ph-query-internal(query&optionalreturn-fields)"Query the PH/QI server with QUERY.QUERY can be a string NAME or a list made of strings NAME and/or cons cells (KEY . VALUE) where KEYs should be valid CCSO database keys. NAME is equivalent to (DEFAULT . NAME),where DEFAULT is the default key of the database.RETURN-FIELDS is a list of database fields to return,defaulting to `eudc-default-return-attributes'."(let(request)(if(nullreturn-fields)(setqreturn-fieldseudc-default-return-attributes))(if(eq'allreturn-fields)(setqreturn-fields'(all)))(setqrequest(concat"query "(if(stringpquery)query(mapconcat(function(lambda(elt)(if(stringpelt)elt)(format"%s=%s"(carelt)(cdrelt))))query" "))(ifreturn-fields(concat" return "(mapconcat'symbol-namereturn-fields" ")))))(and(>(lengthrequest)6)(eudc-ph-do-requestrequest)(eudc-ph-parse-query-resultreturn-fields))))(defuneudc-ph-get-field-list(full-records)"Return a list of valid field names for the current server.If FULL-RECORDS is non-nil, full records including field descriptionare returned"(interactive)(eudc-ph-do-request"fields")(iffull-records(eudc-ph-parse-query-result)(mapcar'eudc-caar(eudc-ph-parse-query-result))))(defuneudc-ph-parse-query-result(&optionalfields)"Return a list of alists of key/values from in `eudc-ph-process-buffer'. Fields not in FIELDS are discarded."(let(recordrecordsline-regexpcurrent-keykeyvalueignore)(save-excursion(message"Parsing results...")(set-buffereudc-ph-process-buffer)(goto-char(point-min))(while(re-search-forward"^\\(-[0-9]+\\):\\([0-9]+\\):"nilt)(catch'ignore(setqline-regexp(concat"^\\(-[0-9]+\\):"(match-string2)":[ \t]*\\([-a-zA-Z_]*\\)?:[ \t]*\\(.*\\)$"))(beginning-of-line)(setqrecordnilignorenilcurrent-keynil)(while(re-search-forwardline-regexpnilt)(catch'skip-line(if(string="-508"(match-string1));; A field is missing in this entry. Skip it or skip the;; whole record (see `eudc-strict-return-matches')(if(noteudc-strict-return-matches)(throw'skip-linet)(while(re-search-forwardline-regexpnilt))(setqignoret)(throw'ignoret)))(setqkey(and(not(string=(match-string2)""))(intern(match-string2)))value(match-string3))(if(andcurrent-key(eqkeycurrent-key))(setqkeynil)(setqcurrent-keykey))(if(or(nullfields)(eq'allfields)(memqcurrent-keyfields))(ifkey(setqrecord(cons(conskeyvalue)record)); New key(setcdr(carrecord)(if(listp(eudc-cdarrecord))(append(eudc-cdarrecord)(listvalue))(list(eudc-cdarrecord)value))))))))(and(notignore)(or(nullfields)(eq'allfields)(setqrecord(nreverserecord)))(setqrecord(if(not(eq'listeudc-duplicate-attribute-handling-method))(eudc-filter-duplicate-attributesrecord)(listrecord)))(setqrecords(appendrecordrecords)))))(message"Done")records))(defuneudc-ph-do-request(request)"Send REQUEST to the server.Wait for response and return the buffer containing it."(let(processbuffer)(unwind-protect(progn(message"Contacting server...")(setqprocess(eudc-ph-open-session))(ifprocess(save-excursion(set-buffer(setqbuffer(process-bufferprocess)))(eudc-ph-send-commandprocessrequest)(message"Request sent, waiting for reply...")(eudc-ph-read-responseprocess))))(ifprocess(eudc-ph-close-sessionprocess)))buffer))(defuneudc-ph-open-session(&optionalserver)"Open a connection to the given CCSO/QI SERVER.SERVER is either a string naming the server or a list (NAME PORT)."(let(processhostport)(catch'done(if(nullserver)(setqserver(oreudc-server(call-interactively'eudc-ph-set-server))))(string-match"\\(.*\\)\\(:\\(.*\\)\\)?"server)(setqhost(match-string1server))(setqport(or(match-string3server)eudc-ph-default-server-port))(setqeudc-ph-process-buffer(get-buffer-create(format" *PH-%s*"host)))(save-excursion(set-buffereudc-ph-process-buffer)(erase-buffer)(setqeudc-ph-read-point(point))(andeudc-xemacs-mule-p(set-buffer-file-coding-system'binaryt)))(setqprocess(open-network-stream"ph"eudc-ph-process-bufferhostport))(if(nullprocess)(throw'donenil))(process-kill-without-queryprocess)process)))(defuneudc-ph-close-session(process)(save-excursion(set-buffer(process-bufferprocess))(eudc-ph-send-commandprocess"quit")(eudc-ph-read-responseprocess)(if(fboundp'add-async-timeout)(add-async-timeout10'delete-processprocess)(run-at-time2nil'delete-processprocess))))(defuneudc-ph-send-command(processcommand)(goto-char(point-max))(process-send-stringprocesscommand)(process-send-stringprocess"\r\n"))(defuneudc-ph-read-response(process&optionalreturn-response)"Read a response from the PH/QI query process PROCESS.Returns nil if response starts with an error code. If theresponse is successful the return code or the response itself is returneddepending on RETURN-RESPONSE."(let((case-fold-searchnil)return-codematch-end)(goto-chareudc-ph-read-point);; CCSO protocol : response complete if status >= 200(while(not(re-search-forward"^\\(^[2-5].*\\):.*\n"nilt))(accept-process-outputprocess)(goto-chareudc-ph-read-point))(setqmatch-end(point))(goto-chareudc-ph-read-point)(if(and(setqreturn-code(match-string1))(setqreturn-code(string-to-numberreturn-code))(>=(absreturn-code)300))(progn(setqeudc-ph-read-pointmatch-end)nil)(setqeudc-ph-read-pointmatch-end)(ifreturn-response(buffer-substring(point)match-end)return-code))));;}}} ;;{{{ High-level interfaces (interactive functions)(defuneudc-ph-customize()"Customize the EUDC PH support."(interactive)(customize-group'eudc-ph))(defuneudc-ph-set-server(server)"Set the PH server to SERVER."(interactive"sNew PH/QI Server: ")(message"Selected PH/QI server is now %s"server)(eudc-set-serverserver'ph));;}}}(eudc-register-protocol'ph)(provide'eudcb-ph);;; eudcb-ph.el ends here