Commit 97dadc11 authored by Erick's avatar Erick

Deleting the extensions directory. Use ScmPkg for that now

parent 4a34573d
This diff is collapsed.
;;;;
;;;; secho.stk -- a simple /bin/echo in Scheme
;;;;
;;;; Copyright © 2009 Erick Gallesio - Polytech'Nice-Sophia <eg@unice.fr>
;;;;
;;;;
;;;; This program 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 of the License, or
;;;; (at your option) any later version.
;;;;
;;;; This program 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 this program; if not, write to the Free Software
;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
;;;; USA.
;;;;
;;;; Author: Erick Gallesio [eg@unice.fr]
;;;; Creation date: 4-May-2009 10:56 (eg)
;;;; Last file update: 9-May-2009 00:41 (eg)
;;;;
(define *version* "1.0")
(define (main argv)
(let ((output-nl #t)
(out (current-output-port)))
(parse-arguments argv
"Usage: secho [options] [parameter ...]"
"Available options"
(("no-newline" :alternate "n" :help "do not output the trailing newline")
(set! output-nl #f))
(("error-port" :alternate "2" :help "Use the error port for the outputs")
(set! out (current-error-port)))
"Other options"
(("help" :alternate "h" :help "display this help and exit")
(arg-usage (current-error-port))
(exit 1))
(("version" :alternate "V" :help "output version information and exit")
(printf "~a version ~a\n" (program-name) *version*)
(exit 0))
(else
(for-each (lambda (x)
(display x out)
(display #\space out))
other-arguments)
(when output-nl
(newline out))))))
# Makefile.am for STklos extension directory
#
# Author: Erick Gallesio [eg@unice.fr]
# Creation date: 4-Jul-2001 11:36 (eg)
# Last file update: 29-Nov-2007 22:30 (eg)
STKCONF = ../utils/stklos-config
INCLUDES = -I../src $(COMPFLAGS)
CC = @CC@
CFLAGS = @CFLAGS@ @SH_COMP_FLAGS@ @GTK_CONFIG_CFLAGS@ @GCINC@ $(INCLUDES)
shobjectdir = $(libdir)/@PACKAGE@/@VERSION@
shobject_SCRIPTS = ldap.@SH_SUFFIX@
#======================================================================
# Scheme code
#
scheme_SRCS = ldap.stk
scheme_OBJS = ldap.ostk
schemedir = $(datadir)/@PACKAGE@/@VERSION@
scheme_DATA = $(scheme_SRCS) $(scheme_OBJS)
##############################################################################
SUFFIXES = .@SH_SUFFIX@ .o .c .stk .ostk .scm
.o.@SH_SUFFIX@:
@SH_LOADER@ @SH_LOAD_FLAGS@ $*.@SH_SUFFIX@ $<
if test -f a.out ;then mv a.out $*.@SH_SUFFIX@; fi
.stk.ostk:
../utils/tmpcomp $*.stk $*.ostk
.scm.ostk:
../utils/tmpcomp $*.scm $*.ostk
##############################################################################
clean:
/bin/rm -f *.o *.ostk *.@SH_SUFFIX@ *.a *~
##############################################################################
# Specific rules for ldap.so
ldap.@SH_SUFFIX@: ldap.o
@SH_LOADER@ @SH_LOAD_FLAGS@ $*.@SH_SUFFIX@ $< @LDAP_LIB@
if test -f a.out ;then mv a.out $*.@SH_SUFFIX@; fi
This diff is collapsed.
-*- outline -*-
* STklos Extensions
You can find the following extensions modules in this directory
** ldap
This is a proof of concept module. Don't take it as a finished
extension. This is a module that I have written because I need to
hack a rather large LDAP base in our school. It does what I need and
very little more. If you want to improve it to make something more
useful, I would be glad to add your contribution.
LocalWords: ldap
/* -*- C -*-
* extconfig.h -- Extensions configuration
*
* Copyright © 2002 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
*
*
* This program 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 of the License, or
* (at your option) any later version.
*
* This program 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 this program; if not, write to the Free Software
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
* USA.
*
* Author: Erick Gallesio [eg@unice.fr]
* Creation date: 28-Feb-2002 18:11 (eg)
* Last file update: 28-Feb-2002 18:19 (eg)
*/
#@HAVE_LDAP@ HAVE_LDAP
This diff is collapsed.
;;;;
;;;; ldap.stk -- A small extension to access LDAP in STklos
;;;;
;;;; Copyright 2002 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
;;;;
;;;;
;;;; This program 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 of the License, or
;;;; (at your option) any later version.
;;;;
;;;; This program 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 this program; if not, write to the Free Software
;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
;;;; USA.
;;;;
;;;; Author: Erick Gallesio [eg@unice.fr]
;;;; Creation date: 23-Feb-2002 22:39 (eg)
;;;; Last file update: 29-Mar-2002 16:51 (eg)
;;;;
(load "ldap.so")
(define *ldap-verbose* #f)
;;; ======================================================================
;;;
;;; ldap-connect
;;;
;;; ======================================================================
(define (ldap-connect :key (server "localhost") (port 389) (dn #f) (password #f))
(%ldap-connect server port dn password))
;;; ======================================================================
;;;
;;; ldap-search
;;;
;;; ======================================================================
(define (ldap-search ld base :key (filter "(objectClass=*)") (scope 'subtree))
(let ((sco (case scope
((base) 0)
((onelevel) 1)
((subtree) 2)
(else (error 'ldap-search
"scope must base, onelevel or subtree (was ~S)"
scope)))))
(%ldap-search ld base sco filter)))
;;; ======================================================================
;;;
;;; ldap-read-ldif
;;;
;;; ======================================================================
(define (ldap-read-ldif :optional (in (current-input-port)))
(define split-entry-line (string->regexp "^([^:]+): (.*$)"))
(define bad-keys (map make-keyword '("creatorsName" "createTimestamp"
"modifiersName" "modifyTimestamp")))
(define (build-key-value key value)
(if (= (length value) 1)
(list (car value) key)
(list (reverse! value) key)))
(define (read-block line res)
;; When we arrive we have a non empty line
(when *ldap-verbose*
(display line (current-error-port))
(newline (current-error-port))
(flush (current-error-port)))
(let ((split (regexp-match split-entry-line line)))
(let Loop ((line (read-line in))
(res res)
(prev-key (make-keyword (cadr split)))
(prev-value (cddr split)))
(cond
((or (eof-object? line) (equal? line ""))
(reverse! (append! (build-key-value prev-key prev-value) res)))
(else
(let* ((split (regexp-match split-entry-line line))
(key (make-keyword (cadr split)))
(val (caddr split)))
(cond
((memq key bad-keys)
(Loop (read-line in)
res
prev-key
prev-value))
((eq? key prev-key)
(Loop (read-line in)
res
prev-key
(cons val prev-value)))
(else
(Loop (read-line in)
(append! (build-key-value prev-key prev-value) res)
key
(list val))))))))))
(let ((res '()))
(do ((l (read-line in) (read-line in)))
((eof-object? l) res)
(if (not (string=? l ""))
(set! res (cons (read-block l '()) res))))
(reverse! res)))
;;; ======================================================================
;;;
;;; ldap-add
;;;
;;; ======================================================================
(define (ldap-add ld entry)
(%ldap-add ld (key-get entry :dn) (key-delete entry :dn)))
;;;
;;; ======================================================================
;;;
;;; ldap-write-entry
;;;
;;; ======================================================================
(define (%ldap-write-entry block out)
(let Loop ((l block))
(unless (null? l)
(let ((key (car l))
(val (cadr l)))
(if (pair? val)
(for-each (lambda(x) (format out "~A: ~A\n" (keyword->string key) x))
val)
(format out "~A: ~A\n" (keyword->string key) val))
(Loop (cddr l)))))
(format out "\n"))
(define (ldap-write-entry entry :optional (out (current-output-port)))
(%ldap-write-entry entry out)
(flush out))
;;; ======================================================================
;;;
;;; ldap-write-ldif
;;;
;;; ======================================================================
(define (ldap-write-ldif base :optional (out (current-output-port)))
(for-each (lambda (x) (%ldap-write-entry x out)) base)
(flush out))
;;; ======================================================================
;;;
;;; ldap-is-a?
;;;
;;; ======================================================================
(define (ldap-is-a? who what)
(let ((dn (key-get who :dn #f)))
(and dn (regexp-match (format #f ",ou=~A," what) dn) #t)))
;;; ======================================================================
;;;
;;; ldap-modify
;;;
;;; ======================================================================
(define (ldap-modify ld old new)
(define (compare-entries dn old new)
(let Loop ((modified '())
(deleted '())
(old old)
(new new))
(cond
((null? old)
(%ldap-modify ld dn new deleted modified))
((equal? (key-get new (car old) #f) (cadr old))
;; item found identical in both lists
(Loop modified
deleted
(cddr old)
(key-delete! new (car old))))
((key-get new (car old) #f)
;; item found in both list but different
(Loop (list* (car old) (key-get new (car old)) modified)
deleted
(cddr old)
(key-delete! new (car old))))
(else ;; item is not in new
(Loop modified
(cons (car old) deleted)
(cddr old)
new)))))
;;
;; start of ldap-modify
;;
(compare-entries (key-get old :dn) old new))
#|
Examples:
- Dump a base in LDIF format (i.e. slapcat, but without stopping the ldap process)
(let ((ld (ldap-connect)))
(ldap-write-ldif (ldap-search ld "dc=essi,dc=fr")))
- Search all the people whose cn contains "eric"
(let ((ld (ldap-connect)))
(ldap-search ld "dc=essi,dc=fr" :filter "(cn=*eric*)"))
- Make an LDIF file where all the gecos field have been deleted
(let ((ld (ldap-connect))
(base (ldap-search ld "dc=essi,dc=fr")))
;; Suppress the gecos field if the organizational unit is "People"
(for-each (lambda (x)
(if (ldap-is-a? x "People")
(key-delete! x :gecos)))
base)
;; Make an LDIF file of the result
(ldap-write-ldif base))
|#
(provide "ldap")
This diff is collapsed.
This diff is collapsed.
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment