1#
2# Extended object interface to entries in LDAP directories or LDIF files.
3#
4# (c) 2006-2018 Pierre David (pdav@users.sourceforge.net)
5#
6# $Id: ldapx.tcl,v 1.12 2008/02/07 21:19:39 pdav Exp $
7#
8# History:
9#   2006/08/08 : pda : design
10#
11
12package require Tcl 8.4
13package require snit		;# tcllib
14package require uri 1.1.5	;# tcllib
15package require base64		;# tcllib
16package require ldap 1.6	;# tcllib, low level code for LDAP directories
17
18package provide ldapx 1.1
19
20##############################################################################
21# LDAPENTRY object type
22##############################################################################
23
24snit::type ::ldapx::entry {
25    #########################################################################
26    # Variables
27    #########################################################################
28
29    #
30    # Format of an individual entry
31    # May be "standard" (standard LDAP entry, read from an LDAP directory
32    # or from a LDIF channel) or "change" (LDIF change, or result of the
33    # comparison of two standard entries).
34    # Special : "uninitialized" means that this entry has not been used,
35    # and the first use will initialize it.
36    #
37
38    variable format "uninitialized"
39
40    #
41    # DN
42    #
43
44    variable dn ""
45
46    #
47    # Standard entry
48    #
49    # Syntax:
50    #   - array indexed by attribute names (lower case)
51    #   - each value is the list of attributes
52    #
53    # The current state may be backed up in an internal state.
54    # (see backup and restore methods)
55    #
56
57    variable attrvals -array {}
58
59    variable backup 0
60    variable bckav  -array {}
61    variable bckdn  ""
62
63    #
64    # Change entry
65    #
66    # Syntax:
67    #	{{<op> <parameters>} ... }
68    #	    if <op> = mod
69    #		{mod {{<modop> <attr> [ {<val1> ... <valn>} ]} ...} }
70    #		where <modop> = modrepl, modadd, moddel
71    #	    if <op> = add
72    #		{add {<attr> {<val1> ... <valn>} ...}}
73    #	    if <op> = del
74    #		{del}
75    #	    if <op> = modrdn
76    #		{modrdn <newrdn> <deleteoldrdn> [ <newsuperior> ]}
77    #
78
79    variable change ""
80
81    #########################################################################
82    # Generic methods (for both standard and change entries)
83    #########################################################################
84
85    # Resets the entry to an empty state
86
87    method reset {} {
88
89	set format "uninitialized"
90	set dn ""
91	array unset attrvals
92	set backup 0
93	array unset bckav
94	set bckdn  ""
95	set change ""
96    }
97
98    # Returns current format
99
100    method format {} {
101
102	return $format
103    }
104
105    # Checks if entry is compatible with a certain format
106    # errors out if not
107
108    method compatible {ref} {
109
110	if {$format eq "uninitialized"} then {
111	    set format $ref
112	} elseif {$format ne $ref} then {
113	    return -code error \
114		"Invalid operation on format $format (should be $ref)"
115	}
116    }
117
118    # Get or set the current dn
119
120    method dn {{newdn {-}}} {
121
122	if {$newdn ne "-"} then {
123	    set dn $newdn
124	}
125	return $dn
126    }
127
128    # Get the "superior" (LDAP slang word) part of current dn
129
130    method superior {} {
131
132	set pos [string first "," $dn]
133	if {$pos == -1} then {
134	    set r ""
135	} else {
136	    set r [string range $dn [expr {$pos+1}] end]
137	}
138	return $r
139    }
140
141    # Get the "rdn" part of current dn
142
143    method rdn {} {
144
145	set pos [string first "," $dn]
146	if {$pos == -1} then {
147	    set r ""
148	} else {
149	    set r [string range $dn 0 [expr {$pos-1}]]
150	}
151	return $r
152    }
153
154    # Get a printable form of the contents
155
156    method print {} {
157
158	set r "dn: $dn"
159	switch -- $format {
160	    uninitialized {
161		# nothing
162	    }
163	    standard {
164		foreach a [lsort [array names attrvals]] {
165		    append r "\n$a: $attrvals($a)"
166		}
167	    }
168	    change {
169		if {[llength $change]} then {
170		    append r "\n$change"
171		}
172	    }
173	    default {
174		append r " (inconsistent value)"
175	    }
176	}
177	return $r
178    }
179
180    # Prints the whole state of an entry
181
182    method debug {} {
183
184	set r "dn = <$dn>\nformat = $format"
185	switch -- $format {
186	    uninitialized {
187		# nothing
188	    }
189	    standard {
190		foreach a [lsort [array names attrvals]] {
191		    append r "\n\t$a: $attrvals($a)"
192		}
193		if {$backup} then {
194		    append r "\nbackup dn = $bckdn"
195		    foreach a [lsort [array names bckav]] {
196			append r "\n\t$a: $bckav($a)"
197		    }
198		} else {
199		    append r "\nno backup"
200		}
201	    }
202	    change {
203		if {[llength $change]} then {
204		    append r "\n$change"
205		} else {
206		    append r "\nno change"
207		}
208	    }
209	    default {
210		append r " (inconsistent value)"
211	    }
212	}
213	return $r
214    }
215
216
217    #########################################################################
218    # Methods for standard entries
219    #########################################################################
220
221    # Tells if the current entry is empty
222
223    method isempty {} {
224
225	$self compatible "standard"
226
227	return [expr {[array size attrvals] == 0}]
228    }
229
230    # Get all values for an attribute
231
232    method get {attr} {
233
234	$self compatible "standard"
235
236	set a [string tolower $attr]
237	if {[info exists attrvals($a)]} then {
238	    set r $attrvals($a)
239	} else {
240	    set r {}
241	}
242	return $r
243    }
244
245    # Get only the first value for an attribute
246
247    method get1 {attr} {
248
249	return [lindex [$self get $attr] 0]
250    }
251
252
253    # Set all values for an attribute
254
255    method set {attr vals} {
256
257	$self compatible "standard"
258
259	set a [string tolower $attr]
260	if {[llength $vals]} then {
261	    set attrvals($a) $vals
262	} else {
263	    unset -nocomplain attrvals($a)
264	}
265	return $vals
266    }
267
268    # Set only one value for an attribute
269
270    method set1 {attr val} {
271
272	if {$val eq ""} then {
273	    set l {}
274	} else {
275	    set l [list $val]
276	}
277
278	return [$self set $attr $l]
279    }
280
281    # Add some values to an attribute
282
283    method add {attr vals} {
284
285	$self compatible "standard"
286
287	set a [string tolower $attr]
288	foreach v $vals {
289	    lappend attrvals($a) $v
290	}
291	return $attrvals($a)
292    }
293
294    # Add only one value to an attribute
295
296    method add1 {attr val} {
297
298	return [$self add $attr [list $val]]
299    }
300
301    # Delete all values (or some values only) for an attribute
302
303    method del {attr {vals {}}} {
304
305	$self compatible "standard"
306
307	set a [string tolower $attr]
308	if {[llength $vals]} then {
309	    set l [$self get $attr]
310	    foreach v $vals {
311		while {[set pos [lsearch -exact $l $v]] != -1} {
312		    set l [lreplace $l $pos $pos]
313		}
314	    }
315	} else {
316	    set l {}
317	}
318
319	if {[llength $l]} then {
320	    $self set $attr $l
321	} else {
322	    unset -nocomplain attrvals($a)
323	}
324	return
325    }
326
327    # Delete only one value from an attribute
328
329    method del1 {attr val} {
330
331	$self del $attr [list $val]
332    }
333
334    # Get all attribute names
335
336    method getattr {} {
337
338	$self compatible "standard"
339
340	return [array names attrvals]
341    }
342
343    # Get all attribute names and values
344
345    method getall {} {
346
347	$self compatible "standard"
348
349	return [array get attrvals]
350    }
351
352    # Reset all attribute names and values at once
353
354    method setall {lst} {
355
356	$self compatible "standard"
357
358	array unset attrvals
359	foreach {attr vals} $lst {
360	    set a [string tolower $attr]
361	    set attrvals($a) $vals
362	}
363    }
364
365    # Back up current entry into a new one or into the internal backup state
366
367    method backup {{other {}}} {
368
369	$self compatible "standard"
370
371	if {$other eq ""} then {
372	    #
373	    # Back-up entry in $self->$oldav and $self->$dn
374	    #
375	    set backup 1
376	    set bckdn $dn
377
378	    array unset bckav
379	    array set bckav [array get attrvals]
380	} else {
381	    #
382	    # Back-up entry in $other
383	    #
384	    $other compatible "standard"
385	    $other dn $dn
386	    $other setall [array get attrvals]
387	}
388    }
389
390    # Restore current entry from an old one or from the internal backup state
391
392    method restore {{other {}}} {
393
394	$self compatible "standard"
395
396	if {$backup} then {
397	    if {$other eq ""} then {
398		#
399		# Restore in current context
400		#
401		set dn $bckdn
402		array unset attrvals
403		array set attrvals [array get bckav]
404	    } else {
405		#
406		# Restore in another object
407		#
408		$other compatible "standard"
409		$other dn $bckdn
410		$other setall [array get bckav]
411	    }
412	} else {
413	    return -code error \
414		"Cannot restore a non backuped object"
415	}
416    }
417
418    # Swap current and backup data, if they reside in the same entry
419
420    method swap {} {
421
422	$self compatible "standard"
423
424	if {$backup} then {
425	    #
426	    # Swap current and backup contexts
427	    #
428	    set swdn $dn
429	    set dn $bckdn
430	    set bckdn $swdn
431
432	    set swav [array get attrvals]
433	    array unset attrvals
434	    array set attrvals [array get bckav]
435	    array unset bckav
436	    array set bckav $swav
437	} else {
438	    return -code error \
439		"Cannot swap a non backuped object"
440	}
441    }
442
443    # Apply some modifications (given by a change entry) to current entry
444
445    method apply {chg} {
446
447	$self compatible "standard"
448	$chg  compatible "change"
449
450	#
451	# Apply $chg modifications to $self
452	#
453
454	foreach mod [$chg change] {
455	    set op [lindex $mod 0]
456	    switch -- $op {
457		add {
458		    if {! [$self isempty]} then {
459			return -code error \
460			    "Cannot add an entry to a non-empty entry"
461		    }
462		    $self setall [lindex $mod 1]
463		    if {[string equal [$self dn] ""]} then {
464			$self dn [$chg dn]
465		    }
466		}
467		mod {
468		    foreach submod [lindex $mod 1] {
469			set subop [lindex $submod 0]
470			set attr [lindex $submod 1]
471			set vals [lindex $submod 2]
472			switch -- $subop {
473			    modadd {
474				$self add $attr $vals
475			    }
476			    moddel {
477				$self del $attr $vals
478			    }
479			    modrepl {
480				$self del $attr
481				$self add $attr $vals
482			    }
483			    default {
484				return -code error \
485				    "Invalid submod operation '$subop'"
486			    }
487			}
488		    }
489		}
490		del {
491		    array unset attrvals
492		}
493		modrdn {
494		    set newrdn [lindex $mod 1]
495		    set delold [lindex $mod 2]
496		    set newsup [lindex $mod 3]
497
498		    if {! [regexp {^([^=]+)=([^,]+)$} $newrdn m nattr nval]} then {
499			return -code "Invalid new RDN '$newrdn'"
500		    }
501
502		    set olddn  [$self dn]
503		    if {! [regexp {^([^=]+)=([^,]+),(.*)} $olddn m oattr oval osup]} then {
504			return -code "Invalid old DN '$olddn'"
505		    }
506
507		    if {$newsup eq ""} then {
508			set dn "$newrdn,$osup"
509		    } else {
510			set dn "$newrdn,$newsup"
511		    }
512		    $self dn $dn
513
514		    if {$delold} then {
515			$self del1 $oattr $oval
516		    }
517
518		    # XXX should we ignore case ?
519		    if {[lsearch -exact [$self get $nattr] $nval] == -1} then {
520			$self add1 $nattr $nval
521		    }
522		}
523		default {
524		    return -code error \
525			"Invalid change operation '$op'"
526		}
527	    }
528	}
529    }
530
531    #########################################################################
532    # Methods for change entries
533    #########################################################################
534
535    # Get or set all modifications
536
537    method change {{newchg {-}}} {
538
539	$self compatible "change"
540
541	if {$newchg ne "-"} then {
542	    set change $newchg
543	}
544	return $change
545    }
546
547    # Compute the difference between two entries (or between an entry
548    # and the backed-up internal state) into the current change entry
549    # e1 : new, e2 : old
550    # if e2 is not given, it defaults to backup in e1
551
552    method diff {new {old {}}} {
553
554	$self compatible "change"
555
556	#
557	# Select where backup is. If internal, creates a temporary
558	# standard entry.
559	#
560
561	if {$old eq ""} then {
562	    set destroy_old 1
563	    set old [::ldapx::entry create %AUTO%]
564	    $new restore $old
565	} else {
566	    set destroy_old 0
567	}
568
569	#
570	# Computes differences between values in the two entries
571	#
572
573	if {[$old dn] ne ""} then {
574	    $self dn [$old dn]
575	} elseif {[$new dn] ne ""} then {
576	    $self dn [$new dn]
577	} else {
578	    $self dn ""
579	}
580
581	switch -- "[$new isempty][$old isempty]" {
582	    00 {
583		# They may differ
584		set change [DiffEntries $new $old]
585	    }
586	    01 {
587		# new has been added
588		set change [list [list "add" [$new getall]]]
589	    }
590	    10 {
591		# new has been deleted
592		set change [list [list "del"]]
593	    }
594	    11 {
595		# they are both empty: no change
596		set change {}
597	    }
598	}
599
600	#
601	# Remove temporary standard entry (backup was internal)
602	#
603
604	if {$destroy_old} then {
605	    $old destroy
606	}
607
608	return $change
609    }
610
611    # local procedure to compute differences between two non empty entries
612
613    proc DiffEntries {new old} {
614	array set tnew [$new getall]
615	array set told [$old getall]
616
617	set lmod {}
618
619	#
620	# First step : is there a DN change?
621	#
622
623	set moddn [DiffDn [$new dn] [$old dn] tnew told]
624
625	#
626	# Second step : pick up changes in attributes and/or values
627	#
628
629	foreach a [array names tnew] {
630	    if {[info exists told($a)]} then {
631		#
632		# They are new and old values for this attribute.
633		# We cannot use individual delete or add (rfc 4512,
634		# paragraph 2.5.1) for attributes which do not have an
635		# equality operator, so we use "replace" everywhere.
636		#
637
638		set lnew [lsort $tnew($a)]
639		set lold [lsort $told($a)]
640		if {$lold ne $lnew} then {
641		    lappend lmod [list "modrepl" $a $tnew($a)]
642		}
643
644		unset tnew($a)
645		unset told($a)
646	    } else {
647		lappend lmod [list "modadd" $a $tnew($a)]
648		unset tnew($a)
649	    }
650	}
651
652	foreach a [array names told] {
653	    lappend lmod [list "moddel" $a]
654	}
655
656	set lchg {}
657
658	if {[llength $lmod]} then {
659	    lappend lchg [list "mod" $lmod]
660	}
661
662	#
663	# Third step : insert modDN changes
664	#
665
666	if {[llength $moddn]} then {
667	    set newrdn       [lindex $moddn 0]
668	    set deleteoldrdn [lindex $moddn 1]
669	    set newsuperior  [lindex $moddn 2]
670
671	    set lmod [list "modrdn" $newrdn $deleteoldrdn]
672	    if {! [string equal $newsuperior ""]} then {
673		lappend lmod $newsuperior
674	    }
675	    lappend lchg $lmod
676	}
677
678	return $lchg
679    }
680
681    proc DiffDn {newdn olddn _tnew _told} {
682	upvar $_tnew tnew
683	upvar $_told told
684
685	#
686	# If DNs are the same, exit
687	#
688
689	if {[string equal -nocase $newdn $olddn]} then {
690	    return {}
691	}
692
693	#
694	# Split components of both DNs : attribute, value, superior
695	#
696
697	if {! [regexp {^([^=]+)=([^,]+),(.*)} $olddn m oattr oval osup]} then {
698	    return -code "Invalid old DN '$olddn'"
699	}
700	set oattr [string tolower $oattr]
701	set ordn "$oattr=$oval"
702
703	if {! [regexp {^([^=]+)=([^,]+),(.*)} $newdn m nattr nval nsup]} then {
704	    return -code "Invalid new DN '$newdn'"
705	}
706	set nattr [string tolower $nattr]
707	set nrdn "$nattr=$nval"
708
709	#
710	# Checks if superior has changed
711	#
712
713	if {! [string equal -nocase $osup $nsup]} then {
714	    set newsuperior $nsup
715	} else {
716	    set newsuperior ""
717	}
718
719	#
720	# Checks if rdn has changed
721	#
722
723	if {! [string equal -nocase $ordn $nrdn]} then {
724	    #
725	    # Checks if old rdn must be deleted
726	    #
727
728	    set deleteoldrdn 1
729	    if {[info exists tnew($oattr)]} then {
730		set pos [lsearch -exact [string tolower $tnew($oattr)] \
731					[string tolower $oval]]
732		if {$pos != -1} then {
733		    set deleteoldrdn 0
734		}
735	    }
736
737	    #
738	    # Remove old and new rdn such as DiffEntries doesn't
739	    # detect any modification.
740	    #
741
742	    foreach t {tnew told} {
743		foreach {a v} [list $oattr $oval $nattr $nval] {
744		    if {[info exists ${t}($a)]} then {
745			set l [set ${t}($a)]
746			set pos [lsearch -exact [string tolower $l] \
747						[string tolower $v] ]
748			if {$pos != -1} then {
749			    set l [lreplace $l $pos $pos]
750			    if {[llength $l]} then {
751				set ${t}($a) $l
752			    } else {
753				unset -nocomplain ${t}($a)
754			    }
755			}
756		    }
757		}
758	    }
759	} else {
760	    set deleteoldrdn 0
761	}
762
763	return [list $nrdn $deleteoldrdn $newsuperior]
764    }
765
766
767    #########################################################################
768    # End of ldapentry
769    #########################################################################
770}
771
772##############################################################################
773# UTF8 translator, component used to manage the -utf8 option
774##############################################################################
775
776snit::type ::ldapx::utf8trans {
777
778    #########################################################################
779    # Option
780    #########################################################################
781
782    option -utf8	 -default {{.*} {}}
783
784    #########################################################################
785    # Methods
786    #########################################################################
787
788    method must {attr} {
789	set utf8yes [lindex $options(-utf8) 0]
790	set utf8no  [lindex $options(-utf8) 1]
791	set r 0
792	if {[regexp -expanded -nocase "^$utf8yes$" $attr]} then {
793	    set r 1
794	    if {[regexp -expanded -nocase "^$utf8no$" $attr]} then {
795		set r 0
796	    }
797	}
798	return $r
799    }
800
801    method encode {attr val} {
802	if {[$self must $attr]} then {
803	    set val [encoding convertto utf-8 $val]
804	}
805	return $val
806    }
807
808    method decode {attr val} {
809	if {[$self must $attr]} then {
810	    set val [encoding convertfrom utf-8 $val]
811	}
812	return $val
813    }
814
815    method encodepairs {avpairs} {
816	set r {}
817	foreach {attr vals} $avpairs {
818	    if {[llength $vals]} then {
819		lappend r $attr [$self encode $attr $vals]
820	    } else {
821		lappend r $attr
822	    }
823	}
824	return $r
825    }
826
827    method decodepairs {avpairs} {
828	set r {}
829	foreach {attr vals} $avpairs {
830	    set vals [$self decode $attr $vals]
831	    lappend r $attr $vals
832	}
833	return $r
834    }
835}
836
837##############################################################################
838# LDAP object type
839##############################################################################
840
841snit::type ::ldapx::ldap {
842    #########################################################################
843    # Options
844    #
845    # note : options are lowercase
846    #########################################################################
847
848    option -scope        -default "sub"
849    option -derefaliases -default "never"
850    option -sizelimit	 -default 0
851    option -timelimit	 -default 0
852    option -attrsonly	 -default 0
853
854    component translator
855    delegate option -utf8 to translator
856
857    #
858    # Channel descriptor
859    #
860
861    variable channel ""
862    variable bind 0
863
864    #
865    # Last error
866    #
867
868    variable lastError ""
869
870    #
871    # Defaults connection modes
872    #
873
874    variable connect_defaults -array {
875				    ldap {389 ::ldap::connect}
876				    ldaps {636 ::ldap::secure_connect}
877				}
878
879
880    #########################################################################
881    # Constructor
882    #########################################################################
883
884    constructor {args} {
885	install translator using ::ldapx::utf8trans create %AUTO%
886	$self configurelist $args
887    }
888
889    destructor {
890	catch {$translator destroy}
891    }
892
893    #########################################################################
894    # Methods
895    #########################################################################
896
897    # Get or set the last error message
898
899    method error {{le {-}}} {
900
901	if {! [string equal $le "-"]} then {
902	    set lastError $le
903	}
904	return $lastError
905    }
906
907    # Connect to the LDAP directory, and binds to it if needed
908
909    method connect {url {binddn {}} {bindpw {}}} {
910
911	array set comp [::uri::split $url "ldap"]
912
913	if {! [::info exists comp(host)]} then {
914	    $self error "Invalid host in URL '$url'"
915	    return 0
916	}
917
918	set scheme $comp(scheme)
919	if {! [::info exists connect_defaults($scheme)]} then {
920	    $self error "Unrecognized URL '$url'"
921	    return 0
922	}
923
924	set defport [lindex $connect_defaults($scheme) 0]
925	set fct     [lindex $connect_defaults($scheme) 1]
926
927	if {[string equal $comp(port) ""]} then {
928	    set comp(port) $defport
929	}
930
931	if {[Check $selfns {set channel [$fct $comp(host) $comp(port)]}]} then {
932	    return 0
933	}
934
935	if {$binddn eq ""} then {
936	    set bind 0
937	} else {
938	    set bind 1
939	    if {[Check $selfns {::ldap::bind $channel $binddn $bindpw}]} then {
940		return 0
941	    }
942	}
943	return 1
944    }
945
946    # Disconnect from the LDAP directory
947
948    method disconnect {} {
949
950	Connected $selfns
951
952	if {$bind} {
953	    if {[Check $selfns {::ldap::unbind $channel}]} then {
954		return 0
955	    }
956	}
957	if {[Check $selfns {::ldap::disconnect $channel}]} then {
958	    return 0
959	}
960	set channel ""
961	return 1
962    }
963
964    # New control structure : traverse the DIT and execute the body
965    # for each found entry.
966
967    method traverse {base filter attrs entry body} {
968
969	Connected $selfns
970
971	global errorInfo errorCode
972
973	set lastError ""
974
975	#
976	# Initiate search
977	#
978
979	set opt [list                                             \
980			-scope        $options(-scope)            \
981			-derefaliases $options(-derefaliases)     \
982			-sizelimit    $options(-sizelimit)        \
983			-timelimit    $options(-timelimit)        \
984			-attrsonly    $options(-attrsonly)        \
985			]
986
987	::ldap::searchInit $channel $base $filter $attrs $opt
988
989	#
990	# Execute the specific body for each result found
991	#
992
993	while {1} {
994	    #
995	    # The first call to searchNext may fail when searchInit
996	    # is given some invalid parameters.
997	    # We must terminate the current search in order to allow
998	    # future searches.
999	    #
1000
1001	    set err [catch {::ldap::searchNext $channel} r]
1002
1003	    if {$err} then {
1004		set ei $errorInfo
1005		set ec $errorCode
1006		::ldap::searchEnd $channel
1007		return -code error -errorinfo $ei -errorcode $ec $r
1008	    }
1009
1010	    #
1011	    # End of result messages
1012	    #
1013
1014	    if {[llength $r] == 0} then {
1015		break
1016	    }
1017
1018	    #
1019	    # Set DN and attributes-values (converted from utf8 if needed)
1020	    # for the entry
1021	    #
1022
1023	    $entry reset
1024
1025	    $entry dn [lindex $r 0]
1026	    $entry setall [$translator decodepairs [lindex $r 1]]
1027
1028	    #
1029	    # Execute body with the entry
1030	    #
1031	    # http://wiki.tcl.tk/685
1032	    #
1033
1034	    set code [catch {uplevel 1 $body} msg]
1035	    switch -- $code {
1036		0 {
1037		    # ok
1038		}
1039		1 {
1040		    # error
1041		    set ei $errorInfo
1042		    set ec $errorCode
1043		    ::ldap::searchEnd $channel
1044		    return -code error -errorinfo $ei -errorcode $ec $msg
1045		}
1046		2 {
1047		    # return
1048		    ::ldap::searchEnd $channel
1049		    return -code return $msg
1050		}
1051		3 {
1052		    # break
1053		    ::ldap::searchEnd $channel
1054		    return {}
1055		}
1056		4 {
1057		    # continue
1058		}
1059		default {
1060		    # user defined
1061		    ::ldap::searchEnd $channel
1062		    return -code $code $msg
1063		}
1064	    }
1065	}
1066
1067	#
1068	# Terminate search
1069	#
1070
1071	::ldap::searchEnd $channel
1072    }
1073
1074    # Returns a list of newly created objects which match
1075
1076    method search {base filter attrs} {
1077
1078	Connected $selfns
1079
1080	set e [::ldapx::entry create %AUTO%]
1081	set r {}
1082	$self traverse $base $filter $attrs $e {
1083	    set new [::ldapx::entry create %AUTO%]
1084	    $e backup $new
1085	    lappend r $new
1086	}
1087	$e destroy
1088	return $r
1089    }
1090
1091    # Read one or more entries, and returns the number of entries found.
1092    # Useful to easily read one or more entries.
1093
1094    method read {base filter args} {
1095
1096	set n 0
1097	set max [llength $args]
1098	set e [::ldapx::entry create %AUTO%]
1099	$self traverse $base $filter {} $e {
1100	    if {$n < $max} then {
1101		$e backup [lindex $args $n]
1102	    }
1103	    incr n
1104	}
1105	return $n
1106    }
1107
1108    # Commit a list of changes (or standard, backuped entries)
1109
1110    method commit {args} {
1111
1112	Connected $selfns
1113
1114	foreach entry $args {
1115	    switch -- [$entry format] {
1116		uninitialized {
1117		    return -code error \
1118			"Uninitialized entry"
1119		}
1120		standard {
1121		    set echg [::ldapx::entry create %AUTO%]
1122		    set lchg [$echg diff $entry]
1123		    set dn   [$echg dn]
1124		    $echg destroy
1125		}
1126		change {
1127		    set dn   [$entry dn]
1128		    set lchg [$entry change]
1129		}
1130	    }
1131
1132	    foreach chg $lchg {
1133		set op   [lindex $chg 0]
1134
1135		switch -- $op {
1136		    {} {
1137			# nothing to do
1138		    }
1139		    add {
1140			set av [$translator encodepairs [lindex $chg 1]]
1141			if {[Check $selfns {::ldap::addMulti $channel $dn $av}]} then {
1142			    return 0
1143			}
1144		    }
1145		    del {
1146			if {[Check $selfns {::ldap::delete $channel $dn}]} then {
1147			    return 0
1148			}
1149		    }
1150		    mod {
1151			set lrep {}
1152			set ldel {}
1153			set ladd {}
1154
1155			foreach submod [lindex $chg 1] {
1156			    set subop [lindex $submod 0]
1157			    set attr [lindex $submod 1]
1158			    set vals [lindex $submod 2]
1159
1160			    set vals [$translator encode $attr $vals]
1161			    switch -- $subop {
1162				modadd {
1163				    lappend ladd $attr $vals
1164				}
1165				moddel {
1166				    lappend ldel $attr $vals
1167				}
1168				modrepl {
1169				    lappend lrep $attr $vals
1170				}
1171			    }
1172			}
1173
1174			if {[Check $selfns {::ldap::modifyMulti $channel $dn \
1175						    $lrep $ldel $ladd}]} then {
1176			    return 0
1177			}
1178		    }
1179		    modrdn {
1180			set newrdn [lindex $chg 1]
1181			set delOld [lindex $chg 2]
1182			set newSup [lindex $chg 3]
1183			if {[string equal $newSup ""]} then {
1184			    if {[Check $selfns {::ldap::modifyDN $channel $dn \
1185						    $newrdn $delOld}]} then {
1186				return 0
1187			    }
1188			} else {
1189			    if {[Check $selfns {::ldap::modifyDN $channel $dn \
1190						    $newrdn $delOld $newSup}]} then {
1191				return 0
1192			    }
1193			}
1194		    }
1195		}
1196	    }
1197	}
1198
1199	return 1
1200    }
1201
1202    #########################################################################
1203    # Local procedures
1204    #########################################################################
1205
1206    proc Connected {selfns} {
1207	if {$channel eq ""} then {
1208	    return -code error \
1209		"Object not connected"
1210	}
1211    }
1212
1213    proc Check {selfns script} {
1214	return [catch {uplevel 1 $script} lastError]
1215    }
1216
1217    #########################################################################
1218    # End of LDAP object type
1219    #########################################################################
1220}
1221
1222##############################################################################
1223# LDIF object type
1224##############################################################################
1225
1226snit::type ::ldapx::ldif {
1227
1228    #########################################################################
1229    # Options
1230    #########################################################################
1231
1232    #
1233    # Fields to ignore when reading change file
1234    #
1235
1236    option -ignore {}
1237
1238    component translator
1239    delegate option -utf8 to translator
1240
1241
1242    #########################################################################
1243    # Variables
1244    #########################################################################
1245
1246    #
1247    # Version of LDIF file (0 means : uninitialized)
1248    #
1249
1250    variable version 0
1251
1252    #
1253    # Channel descriptor
1254    #
1255
1256    variable channel ""
1257
1258    #
1259    # Line number
1260    #
1261
1262    variable lineno 0
1263
1264    #
1265    # Last error message
1266    #
1267
1268    variable lastError ""
1269
1270    #
1271    # Number of entries read or written
1272    #
1273
1274    variable nentries 0
1275
1276    #
1277    # Type of LDIF file
1278    #
1279
1280    variable format "uninitialized"
1281
1282    #########################################################################
1283    # Constructor
1284    #########################################################################
1285
1286    constructor {args} {
1287	install translator using ::ldapx::utf8trans create %AUTO%
1288	$self configurelist $args
1289    }
1290
1291    destructor {
1292	catch {$translator destroy}
1293    }
1294
1295    #########################################################################
1296    # Methods
1297    #########################################################################
1298
1299    # Initialize a channel
1300
1301    method channel {newchan} {
1302
1303	set channel   $newchan
1304	set version   0
1305	set nentries  0
1306	set format    "uninitialized"
1307	set lineno    0
1308	return
1309    }
1310
1311    # Get or set the last error message
1312
1313    method error {{le {-}}} {
1314
1315	if {$le ne "-"} then {
1316	    set lastError $le
1317	}
1318	return $lastError
1319    }
1320
1321    # An LDIF file cannot include both changes and standard entries
1322    # (see RFC 2849, page 2). Check this.
1323
1324    method compatible {ref} {
1325
1326	if {$format eq "uninitialized"} then {
1327	    set format $ref
1328	} elseif {$format ne $ref} then {
1329	    return -code error \
1330		"Invalid entry ($ref) type for LDIF $format file"
1331	}
1332    }
1333
1334    # Reads an LDIF entry (standard or change) from the channel
1335    # returns 1 if ok, 0 if error or EOF
1336
1337    # XXX this method is just coded for tests at this time
1338
1339    method debugread {entry} {
1340
1341	$entry compatible "standard"
1342	$entry dn "uid=joe,ou=org,o=com"
1343	$entry setall {uid {joe} sn {User} givenName {Joe} cn {{Joe User}}
1344	    telephoneNumber {+31415926535 +27182818285} objectClass {person}
1345	}
1346	return 1
1347    }
1348
1349    # Read an LDIF entry (standard or change) from the channel
1350    # returns 1 if ok, 0 if error or EOF
1351
1352    method read {entry} {
1353	if {$channel eq ""} then {
1354	    return -code error \
1355			"Channel not initialized"
1356	}
1357
1358	set r [Lexical $selfns]
1359	if {[lindex $r 0] ne "err"} then {
1360	    set r [Syntaxic $selfns [lindex $r 1]]
1361	}
1362
1363	if {[lindex $r 0] eq "err"} then {
1364	    set lastError [lindex $r 1]
1365	    return 0
1366	}
1367
1368	switch -- [lindex $r 0] {
1369	    uninitialized {
1370		$entry reset
1371		set lastError ""
1372		set r 0
1373	    }
1374	    standard {
1375		if {[catch {$self compatible "change"}]} then {
1376		    set lastError "Standard entry not allowed in LDIF change file"
1377		    set r 0
1378		} else {
1379		    $entry reset
1380		    $entry dn     [lindex $r 1]
1381		    $entry setall [lindex $r 2]
1382		    set r 1
1383		}
1384	    }
1385	    change {
1386		if {[catch {$self compatible "change"}]} then {
1387		    set lastError "Change entry not allowed in LDIF standard file"
1388		    set r 0
1389		} else {
1390		    $entry reset
1391		    $entry dn     [lindex $r 1]
1392		    $entry change [list [lindex $r 2]]
1393		    set r 1
1394		}
1395	    }
1396	    default {
1397		return -code error \
1398			"Internal error (invalid returned entry format)"
1399	    }
1400	}
1401
1402	return $r
1403    }
1404
1405    # Write an LDIF entry to the channel
1406
1407    method write {entry} {
1408
1409	if {$channel eq ""} then {
1410	    return -code error \
1411			"Channel not initialized"
1412	}
1413
1414	switch -- [$entry format] {
1415	    uninitialized {
1416		# nothing
1417	    }
1418	    standard {
1419		if {[llength [$entry getall]]} then {
1420		    $self compatible "standard"
1421
1422		    if {$nentries == 0} then {
1423			if {$version == 0} then {
1424			    set version 1
1425			}
1426			WriteLine $selfns "version" "$version"
1427			puts $channel ""
1428		    }
1429
1430		    WriteLine $selfns "dn" [$entry dn]
1431
1432		    foreach a [$entry getattr] {
1433			foreach v [$entry get $a] {
1434			    WriteLine $selfns $a $v
1435			}
1436		    }
1437		    puts $channel ""
1438		}
1439	    }
1440	    change {
1441		$self compatible "change"
1442
1443		set lchg [$entry change]
1444		foreach chg $lchg {
1445		    if {$nentries == 0} then {
1446			if {$version == 0} then {
1447			    set version 1
1448			}
1449			WriteLine $selfns "version" "$version"
1450			puts $channel ""
1451		    }
1452
1453		    WriteLine $selfns "dn" [$entry dn]
1454
1455		    set op [lindex $chg 0]
1456		    switch -- $op {
1457			add {
1458			    WriteLine $selfns "changetype" "add"
1459			    foreach {attr vals} [lindex $chg 1] {
1460				foreach v $vals {
1461				    WriteLine $selfns $attr $v
1462				}
1463			    }
1464			}
1465			del {
1466			    WriteLine $selfns "changetype" "delete"
1467			}
1468			mod {
1469			    WriteLine $selfns "changetype" "modify"
1470			    foreach submod [lindex $chg 1] {
1471				set subop [lindex $submod 0]
1472				set attr [lindex $submod 1]
1473				set vals [lindex $submod 2]
1474
1475				switch -- $subop {
1476				    modadd {
1477					WriteLine $selfns "add" $attr
1478				    }
1479				    moddel {
1480					WriteLine $selfns "delete" $attr
1481				    }
1482				    modrepl {
1483					WriteLine $selfns "replace" $attr
1484				    }
1485				}
1486				foreach v $vals {
1487				    WriteLine $selfns $attr $v
1488				}
1489				puts $channel "-"
1490			    }
1491			}
1492			modrdn {
1493			    WriteLine $selfns "changetype" "modrdn"
1494			    set newrdn [lindex $chg 1]
1495			    set delold [lindex $chg 2]
1496			    set newsup [lindex $chg 3]
1497			    WriteLine $selfns "newrdn" $newrdn
1498			    WriteLine $selfns "deleteOldRDN" $delold
1499			    if {$newsup ne ""} then {
1500				WriteLine $selfns "newSuperior" $newsup
1501			    }
1502			}
1503		    }
1504		    puts $channel ""
1505		    incr nentries
1506		}
1507	    }
1508	    default {
1509		return -code error \
1510			"Invalid entry format"
1511	    }
1512	}
1513	return 1
1514    }
1515
1516    #########################################################################
1517    # Local procedures to read an entry
1518    #########################################################################
1519
1520    #
1521    # Lexical analysis of an entry
1522    # Special case for "version:" entry.
1523    # Returns a list of lines {ok {{<attr1> <val1>} {<attr2> <val2>} ...}}
1524    # or a list {err <message>}
1525    #
1526
1527    proc Lexical {selfns} {
1528	set result {}
1529	set prev ""
1530
1531	while {[gets $channel line] > -1} {
1532	    incr lineno
1533
1534	    if {$line eq ""} then {
1535		#
1536		# Empty line: we are either before the beginning
1537		# of the entry or at the empty line after the
1538		# entry.
1539		# We don't give up before getting something.
1540		#
1541
1542		if {! [FlushLine $selfns "" result prev msg]} then {
1543		    return [list "err" $msg]
1544		}
1545
1546		if {[llength $result]} then {
1547		    break
1548		}
1549
1550	    } elseif {[regexp {^[ \t]} $line]} then {
1551		#
1552		# Continuation line. Remove the continuation character.
1553		#
1554
1555		append prev [string range $line 1 end]
1556
1557	    } elseif {[regexp {^-$} $line]} then {
1558		#
1559		# Separation between individual modifications
1560		#
1561
1562		if {! [FlushLine $selfns "" result prev msg]} then {
1563		    return [list "err" $msg]
1564		}
1565		lappend result [list "-" {}]
1566
1567	    } else {
1568		#
1569		# Should be a normal line (key: val)
1570		#
1571
1572		if {! [FlushLine $selfns $line result prev msg]} then {
1573		    return [list "err" $msg]
1574		}
1575
1576	    }
1577	}
1578
1579	#
1580	# End of file, or end of entry. Flush buffered data from $prev
1581	# for EOF case.
1582	#
1583
1584	if {! [FlushLine $selfns "" result prev msg]} then {
1585	    return [list "err" $msg]
1586	}
1587
1588	return [list "ok" $result]
1589    }
1590
1591    proc FlushLine {selfns line _result _prev _msg} {
1592	upvar $_result result  $_prev prev  $_msg msg
1593
1594	if {$prev ne ""} then {
1595	    set r [DecodeLine $selfns $prev]
1596	    if {[llength $r] != 2} then {
1597		set msg "$lineno: invalid syntax"
1598		return 0
1599	    }
1600
1601	    #
1602	    # Special case for "version: 1". This code should not
1603	    # be in lexical analysis, but this would be too disruptive
1604	    # in syntaxic analysis
1605	    #
1606
1607	    if {[string equal -nocase [lindex $r 0] "version"]} then {
1608		if {$version != 0} then {
1609		    set msg "version attribute allowed only at the beginning of the LDIF file"
1610		    return 0
1611		}
1612		set val [lindex $r 1]
1613		if {[catch {set val [expr {$val+0}]}]} then {
1614		    set msg "invalid version value"
1615		    return 0
1616		}
1617		if {$val != 1} then {
1618		    set msg "unrecognized version '$val'"
1619		    return 0
1620		}
1621		set version 1
1622	    } else {
1623		lappend result $r
1624	    }
1625	}
1626	set prev $line
1627
1628	return 1
1629    }
1630
1631    proc DecodeLine {selfns str} {
1632	if {[regexp {^([^:]*)::[ \t]*(.*)} $str d key val]} then {
1633	    set key [string tolower $key]
1634	    set val [::base64::decode $val]
1635	    set val [$translator decode $key $val]
1636	    set r [list $key $val]
1637	} elseif {[regexp {^([^:]*):[ \t]*(.*)} $str d key val]} then {
1638	    set key [string tolower $key]
1639	    set val [$translator decode $key $val]
1640	    set r [list $key $val]
1641	} else {
1642	    # syntax error
1643	    set r {}
1644	}
1645	return $r
1646    }
1647
1648    #
1649    # Array indexed by current state of the LDIF automaton
1650    # Each element is a list of actions, each with the format:
1651    #	pattern on on "attribute:value"
1652    #	next state
1653    #	script (to be evaled in Syntaxic local procedure)
1654    #
1655
1656    variable ldifautomaton -array {
1657	begin {
1658	    {dn:*		dn		{set dn $val}}
1659	    {EOF:*		end		{set r [list "empty"]}}
1660	}
1661	dn {
1662	    {changetype:modify	mod		{set t "change" ; set r {mod}}}
1663	    {changetype:modrdn	modrdn		{set t "change" ; set newsup {}}}
1664	    {changetype:add	add		{set t "change"}}
1665	    {changetype:delete	del		{set t "change"}}
1666	    {*:*		standard	{set t "standard" ; lappend tab($key) $val}}
1667	}
1668	standard {
1669	    {EOF:*		end		{set r [array get tab]}}
1670	    {*:*		standard	{lappend tab($key) $val}}
1671	}
1672	mod {
1673	    {add:*		mod-add		{set attr [string tolower $val] ; set vals {}}}
1674	    {delete:*		mod-del		{set attr [string tolower $val] ; set vals {}}}
1675	    {replace:*		mod-repl	{set attr [string tolower $val] ; set vals {}}}
1676	    {EOF:*		end		{}}
1677	}
1678	mod-add {
1679	    {*:*		mod-add-attr	{lappend vals $val}}
1680	}
1681	mod-add-attr {
1682	    {-:*		mod		{lappend r [list "modadd" $attr $vals]}}
1683	    {*:*		mod-add-attr	{lappend vals $val}}
1684	}
1685	mod-del {
1686	    {-:*		mod		{lappend r [list "moddel" $attr $vals]}}
1687	    {*:*		mod-del		{lappend vals $val}}
1688	}
1689	mod-repl {
1690	    {-:*		mod		{lappend r [list "modrepl" $attr $vals]}}
1691	    {*:*		mod-repl	{lappend vals $val}}
1692	}
1693	modrdn {
1694	    {newrdn:*		modrdn-new	{set newrdn $val}}
1695	}
1696	modrdn-new {
1697	    {deleteoldrdn:0	modrdn-del	{set delold 0}}
1698	    {deleteoldrdn:1	modrdn-del	{set delold 1}}
1699	}
1700	modrdn-del {
1701	    {newsuperior:*	modrdn-end	{set newsup $val}}
1702	    {EOF:*		end		{set r [list modrdn $newrdn $delold] }}
1703	}
1704	modrdn-end {
1705	    {EOF:*		end		{set r [list modrdn $newrdn $delold $newsup]}}
1706	}
1707	add {
1708	    {EOF:*		end		{set r [list add [array get tab]]}}
1709	    {*:*		add		{lappend tab($key) $val}}
1710	}
1711	del {
1712	    {EOF:*		end		{set r [list del]}}
1713	}
1714    }
1715
1716    proc Syntaxic {selfns lcouples} {
1717	set state "begin"
1718	set newsup {}
1719	set t "uninitialized"
1720	foreach c $lcouples {
1721	    set key [lindex $c 0]
1722	    if {[lsearch [string tolower $options(-ignore)] $key] == -1} then {
1723		set val [lindex $c 1]
1724		set a [Automaton $selfns $state $key $val]
1725		if {$a eq ""} then {
1726		    return [list "err" "Syntax error before line $lineno"]
1727		}
1728		set state [lindex $a 0]
1729		set script [lindex $a 1]
1730		eval $script
1731	    }
1732	}
1733
1734	set a [Automaton $selfns $state "EOF" "EOF"]
1735	if {$a eq ""} then {
1736	    return [list "err" "Premature EOF"]
1737	}
1738	set script [lindex $a 1]
1739	eval $script
1740
1741	set result [list $t]
1742	switch $t {
1743	    uninitialized {
1744		# nothing
1745	    }
1746	    standard {
1747		lappend result $dn $r
1748	    }
1749	    change {
1750		lappend result $dn $r
1751	    }
1752	}
1753
1754	return $result
1755    }
1756
1757    proc Automaton {selfns state key val} {
1758	set r {}
1759	if {[info exists ldifautomaton($state)]} then {
1760	    foreach a $ldifautomaton($state) {
1761		if {[string match [lindex $a 0] "$key:$val"]} then {
1762		    set r [lreplace $a 0 0]
1763		    break
1764		}
1765	    }
1766	}
1767	return $r
1768    }
1769
1770    #########################################################################
1771    # Local procedures to write an entry
1772    #########################################################################
1773
1774    proc WriteLine {selfns attr val} {
1775
1776	if {[string is ascii $val] && [string is print $val]} then {
1777	    set sep ":"
1778	} else {
1779	    set sep "::"
1780	    set val [$translator encode $attr $val]
1781	    set val [::base64::encode $val]
1782	}
1783
1784	set first 1
1785	foreach line [split $val "\n"] {
1786	    if {$first} then {
1787		puts $channel "$attr$sep $line"
1788		set first 0
1789	    } else {
1790		puts $channel " $line"
1791	    }
1792	}
1793    }
1794}
1795