/pliant/util/encoding/general.pli
1	module "/pliant/language/unsafe.pli"
2
3	constant optimized true
4
5	if optimized
6
7	function general_encode clear tag code -> encoded
8	arg Str clear ; arg Int tag ; arg (Array uInt8 256) code ; arg Str encoded
9	var Int reserved := 2*clear:len+4
10	var Address buf := memory_allocate reserved addressof:encoded
11	var Address dest := buf
12	var Address src := clear characters
13	var Address stop := src translate Char clear:len
14	while src<>stop
15	var Int c := src map uInt8
16	var Int cc := code c
17	if cc<>0
18	dest map uInt8 := cc ; dest := dest translate Char 1
19	else
20	var Int required := ((cast dest Int).-.(cast buf Int))+2+((cast stop Int).-.(cast src Int))
21	if required>reserved
22	var Int offset := (cast dest Int).-.(cast buf Int)
23	reserved := 2*reserved+2
24	buf := memory_resize buf reserved addressof:encoded
25	dest := buf translate Byte offset
26	dest map uInt8 := tag ; dest := dest translate Char 1
27	var Int cc := c\16
28	dest map uInt8 := cc+(shunt cc<10 "0":number "A":number-10) ; dest := dest translate Char 1
29	var Int cc := c%16
30	dest map uInt8 := cc+(shunt cc<10 "0":number "A":number-10) ; dest := dest translate Char 1
31	src := src translate Char 1
32	check (cast dest Int).-.(cast buf Int)<=reserved
33	reserved := (cast dest Int).-.(cast buf Int)
34	buf := memory_resize buf reserved addressof:encoded
35	encoded set buf reserved true
36
37	else
38
39	function general_encode clear tag code -> encoded
40	arg Str clear ; arg Int tag ; arg (Array uInt8 256) code ; arg Str encoded
41	encoded := clear
42	var Int i := 0
43	while i<encoded:len
44	var Int c := encoded:i:number
45	var Int cc := code c
46	if cc<>0
47	encoded:i := character cc
48	i += 1
49	else
50	encoded := (encoded 0 i)+character:tag+(right (string c "radix 16") 2 "0")+(encoded i+1 encoded:len)
51	i += 3
52
53
54	if optimized
55
56	function unhexa c -> i
57	arg Int c i
58	if c>="0":number and c<="9":number
59	i := c-"0":number
60	eif c>="A":number and c<="F":number
61	i := c-("A":number-10)
62	eif c>="a":number and c<="f":number
63	i := c-("a":number-10)
64	else
65	i := 0
66
67	function general_decode encoded tag -> clear
68	arg Str encoded clear ; arg Int tag
69	var Address buf := memory_allocate encoded:len addressof:clear
70	var Address dest := buf
71	var Address src := encoded:characters
72	var Address stop := encoded:characters translate Char encoded:len
73	var uInt8 tag8 := tag
74	while true
75	var Address tag1 := memory_search src (max (cast stop Int).-.(cast src Int)-2 0) addressof:tag8 1
76	if tag1=null
77	tag1 := stop
78	var Int step := (cast tag1 Int).-.(cast src Int)
79	memory_copy src dest step ; dest := dest translate Byte step
80	if tag1=stop
81	clear set buf (cast dest Int).-.(cast buf Int) true
82	return
83	src := src translate Byte step
84	dest map uInt8 := unhexa:((src translate uInt8 1) map uInt8)*16+unhexa:((src translate uInt8 2) map uInt8)
85	src := src translate uInt8 3
86	dest := dest translate uInt8 1
87	var Int len := (cast dest Int).-.(cast buf Int)
88	buf := memory_resize buf len addressof:encoded
89	clear set buf len true
90
91	else
92
93	function unhexa s -> i
94	arg Str s ; arg Int i
95	i := 0
96	for (var Int j) 0 s:len-1
97	var Int c := s:j number
98	if c>="0":0:number and c<="9":0:number
99	i := i*16+(c-"0":0:number)
100	eif c>="A":0:number and c<="F":0:number
101	i := i*16+(c-"A":0:number+10)
102	eif c>="a":0:number and c<="f":0:number
103	i := i*16+(c-"a":0:number+10)
104	else
105	return undefined
106
107	function general_decode encoded tag -> clear
108	arg Str encoded clear ; arg Int tag
109	clear := encoded
110	var Int i := -1
111	while { i := ((clear i+1 clear:len) search character:tag -(i+2))+(i+1) ; i<>(-1) } and i+2<clear:len
112	var Int h := unhexa (clear i+1 2)
113	if h=defined
114	clear := (clear 0 i)+character:h+(clear i+3 clear:len)
115
116
117	function general_code keep -> code
118	arg Str keep ; arg (Array uInt8 256) code
119	for (var Int u) 0 255
120	code u := shunt u>="a":0:number and u<="z":0:number or u>="A":0:number and u<="Z":0:number or u>="0":0:number and u<="9":0:number or (keep search character:u -1)<>(-1) u 0
121
122	export general_encode general_decode general_code