WebSVN – oidplus – Diff – /trunk_dos/WEID_Delphi.pas


unit WEID_Delphi;
 
(*
 * WEID<=>OID Converter for Delphi
 * (c) Webfan.de, ViaThinkSoft
 * Revision 2022-02-19
 *)
 
(*
  What is a WEID?
    A WEID (WEhowski IDentifier) is an alternative representation of an
     OID (Object IDentifier) defined by Till Wehowski.
     In OIDs, arcs are in decimal base 10. In WEIDs, the arcs are in base 36.
     Also, each WEID has a check digit at the end (called WeLohn Check Digit).
 
  Changes in the December 2021 definition by Daniel Marschall:
     - There are several classes of WEIDs which have different OID bases:
           "Class C" WEID:  weid:EXAMPLE-3      (base .1.3.6.1.4.1.37553.8.)
                            oid:1.3.6.1.4.1.37553.8.32488192274
           "Class B" WEID:  weid:pen:SX0-7PR-6  (base .1.3.6.1.4.1.)
                            oid:1.3.6.1.4.1.37476.9999
           "Class A" WEID:  weid:root:2-RR-2    (base .)
                            oid:2.999
     - The namespace (weid:, weid:pen:, weid:root:) is now case insensitive.
     - Padding with '0' characters is valid (e.g. weid:000EXAMPLE-3)
       The paddings do not count into the WeLuhn check-digit.
*)
 
interface
 
(*
Translates a weid to an oid
"weid:EXAMPLE-3" becomes "1.3.6.1.4.1.37553.8.32488192274"
If it failed (e.g. wrong namespace, wrong checksum, etc.) then false is returned.
If the weid ends with '?', then it will be replaced with the checksum,
e.g. weid:EXAMPLE-? becomes weid:EXAMPLE-3
*)
function WeidToOid(var weid: string): string;
 
(*
Converts an OID to WEID
"1.3.6.1.4.1.37553.8.32488192274" becomes "weid:EXAMPLE-3"
*)
function OidToWeid(oid: string): string;
 
implementation
 
uses
  SysUtils;
 
function LastCharPos(const S: string; const Chr: char): integer;
var
  i: Integer;
begin
  for i := length(S) downto 1 do
  begin
    if S[i] = Chr then
    begin
      result := i;
      Exit;
    end;
  end;
  result := 0;
  Exit;
end;
 
function base_convert_bigint(numstring: string; frombase, tobase: integer): string;
var
  i: Integer;
  frombase_str: string;
  tobase_str: string;
  len: Integer;
  number: string;
  divide: Integer;
  newlen: Integer;
  res: string;
begin
  frombase_str := '';
  for i := 0 to frombase-1 do
  begin
    if i < 10 then
      frombase_str := frombase_str + IntToStr(i)
    else
      frombase_str := frombase_str + Chr(Ord('A') + (i-10));
  end;
 
  tobase_str := '';
  for i := 0 to tobase-1 do
  begin
    if i < 10 then
      tobase_str := tobase_str + IntToStr(i)
    else
      tobase_str := tobase_str + Chr(Ord('A') + (i-10));
  end;
 
  len := Length(numstring);
  result := '';
  number := numstring; (* this is a fake "Int8" array (implemented with chars) *)
  for i := 0 to len-1 do
  begin
    number[i+1] := Chr(Pos(UpCase(numstring[i+1]), frombase_str)-1);
  end;
  res := '';
  repeat (* Loop until whole number is converted *)
    divide := 0;
    newlen := 0;
    for i := 0 to len-1 do (* Perform division manually (which is why this works with big numbers) *)
    begin
      divide := divide * frombase + Ord(number[i+1]);
      if (divide >= tobase) then
      begin
        number[newlen+1] := Chr(divide div tobase);
        Inc(newlen);
        divide := divide mod tobase;
      end
      else if newlen > 0 then
      begin
        number[newlen+1] := #0;
        Inc(newlen);
      end;
    end;
    len := newlen;
    res := tobase_str[divide+1] + res; (* Divide is basically "numstring mod tobase" (i.e. the new character) *)
  until newlen = 0;
  result := res;
end;
 
function weLuhnGetCheckDigit(s: string): integer;
var
  p: integer;
  wrkstr: string;
  c: Char;
  i: Integer;
  sum: integer;
  nbdigits: Integer;
  parity: Integer;
  n: Integer;
  digit: Integer;
begin
  (* Padding zeros don't count to the check digit (December 2021) *)
  s := '-' + s + '-';
  while Pos('-0', s) > 0 do
  begin
    s := StringReplace(s, '-0-', #1, [rfReplaceAll]);
    s := StringReplace(s, '-0', '-', [rfReplaceAll]);
  end;
  s := StringReplace(s, #1, '-0-', [rfReplaceAll]);
  s := Copy(s, 2, Length(s)-2);
 
  (* remove separators of the WEID string *)
  wrkstr := StringReplace(s, '-', '', [rfReplaceAll]);
 
  (* Replace 'a' with '10', 'b' with '11', etc. *)
  for c := 'A' to 'Z' do
  begin
    wrkstr := StringReplace(wrkstr, c, IntToStr(Ord(c)-Ord('A')+10), [rfReplaceAll]);
  end;
 
  (* At the end, wrkstr should only contain digits! Verify it! *)
  for i := 1 to Length(wrkstr) do
  begin
    if not (wrkstr[i] in ['0'..'9']) then
    begin
      result := -1;
      exit;
    end;
  end;
 
  (* Now do the standard Luhn algorithm *)
  nbdigits := Length(wrkstr);
  parity := nbdigits and 1; (* mod 2 *)
  sum := 0;
  for n := nbdigits-1 downto 0 do
  begin
    digit := StrToInt(wrkstr[n+1]);
    if (n and 1) <> parity then digit := digit * 2;
    if digit > 9 then digit := digit - 9;
    sum := sum + digit;
  end;
 
  if sum mod 10 = 0 then
    result := 0
  else
    result := 10 - (sum mod 10);
end;
 
function WeidToOid(var weid: string): string;
var
  base: string;
  namespace: string;
  p: integer;
  rest: string;
  actual_checksum: string;
  expected_checksum: integer;
  complete: string;
  oidstr: string;
  arc: string;
begin
  p := LastCharPos(weid,':');
  namespace := Copy(weid, 1, p);
  rest := Copy(weid, p+1, Length(weid)-p);
 
  namespace := LowerCase(namespace); (* namespace is case insensitive *)
  if namespace = 'weid:' then
  begin
    (* Class C *)
    base := '1-3-6-1-4-1-SZ5-8';
  end
  else if namespace = 'weid:pen:' then
  begin
    (* Class B *)
    base := '1-3-6-1-4-1';
  end
  else if namespace = 'weid:root:' then
  begin
    (* Class A *)
    base := '';
  end
  else
  begin
    (* Wrong namespace *)
    result := '';
    Exit;
  end;
 
  weid := rest;
 
  if base <> '' then
    complete := base + '-' + weid
  else
    complete := weid;
  p := LastCharPos(complete, '-');
  actual_checksum := Copy(complete, p+1, 1);
  complete := Copy(complete, 1, p-1);
  expected_checksum := weLuhnGetCheckDigit(complete);
  if (actual_checksum <> '?') then
  begin
    if actual_checksum <> IntToStr(expected_checksum) then
    begin
      result := ''; (* wrong checksum *)
      Exit;
    end;
  end
  else
  begin
    (* If checksum is '?', it will be replaced by the actual checksum, *)
    (* e.g. weid:EXAMPLE-? becomes weid:EXAMPLE-3                      *)
    weid := StringReplace(weid, '?', IntToStr(expected_checksum), [rfReplaceAll]);
  end;
 
  oidstr := '';
  while true do
  begin
    p := Pos('-', complete);
    if p = 0 then p := Length(complete)+1;
    arc := Copy(complete, 1, p-1);
    Delete(complete, 1, p);
    oidstr := oidstr + base_convert_bigint(arc, 36, 10) + '.';
    if complete = '' then break;
  end;
  oidstr := Copy(oidstr, 1, Length(oidstr)-1);
 
  weid := namespace + weid; (* add namespace again *)
 
  result := oidstr;
end;
 
function OidToWeid(oid: string): string;
var
  is_class_a: boolean;
  is_class_b: boolean;
  is_class_c: boolean;
  weidstr: string;
  checksum: string;
  namespace: string;
  p: Integer;
  cd: Integer;
  res: string;
begin
  if Copy(oid,1,1) = '.' then
    Delete(oid,1,1); (* remove leading dot *)
 
  if oid <> '' then
  begin
    weidstr := '';
    while true do
    begin
      p := Pos('.', oid);
      if p = 1 then
      begin
        Delete(oid, 1, 1);
      end
      else if p > 0 then
      begin
        weidstr := weidstr + base_convert_bigint(Copy(oid, 1, p-1),10,36) + '-';
        Delete(oid, 1, p);
      end
      else
      begin
        weidstr := weidstr + base_convert_bigint(oid,10,36) + '-';
        break;
      end;
    end;
    weidstr := Copy(weidstr, 1, Length(weidstr)-1);
  end
  else
  begin
    weidstr := '';
  end;
 
  is_class_c := (Pos('1-3-6-1-4-1-SZ5-8-', weidstr) = 1) or
                (weidstr = '1-3-6-1-4-1-SZ5-8');
  is_class_b := ((Pos('1-3-6-1-4-1-', weidstr) = 1) or
                (weidstr = '1-3-6-1-4-1'))
                and not is_class_c;
  is_class_a := not is_class_b and not is_class_c;
 
  cd := weLuhnGetCheckDigit(weidstr);
  if cd < 0 then
  begin
    result := weidstr;
    exit;
  end;
  checksum := IntToStr(cd);
 
  if is_class_c then
  begin
    Delete(weidstr, 1, Length('1-3-6-1-4-1-SZ5-8-'));
    namespace := 'weid:';
  end
  else if is_class_b then
  begin
    Delete(weidstr, 1, Length('1-3-6-1-4-1-'));
    namespace := 'weid:pen:';
  end
  else if is_class_a then
  begin
    (* weidstr stays *)
    namespace := 'weid:root:';
  end
  else
  begin
    (* should not happen *)
    result := '';
    Exit;
  end;
 
  res := namespace;
  if weidstr = '' then
    res := res + checksum
  else
    res := res + weidstr + '-' + checksum;
  result := res;
end;
 
end.
 

Rev 748	Rev 749
1	unit WEID;	1	unit WEID_Delphi;
2		2
3	(*	3	(*
4	* WEID<=>OID Converter for Delphi	4	* WEID<=>OID Converter for Delphi
5	* (c) Webfan.de, ViaThinkSoft	5	* (c) Webfan.de, ViaThinkSoft
6	* Revision 2022-02-19	6	* Revision 2022-02-19
7	*)	7	*)
8		8
9	(*	9	(*
10	What is a WEID?	10	What is a WEID?
11	A WEID (WEhowski IDentifier) is an alternative representation of an	11	A WEID (WEhowski IDentifier) is an alternative representation of an
12	OID (Object IDentifier) defined by Till Wehowski.	12	OID (Object IDentifier) defined by Till Wehowski.
13	In OIDs, arcs are in decimal base 10. In WEIDs, the arcs are in base 36.	13	In OIDs, arcs are in decimal base 10. In WEIDs, the arcs are in base 36.
14	Also, each WEID has a check digit at the end (called WeLohn Check Digit).	14	Also, each WEID has a check digit at the end (called WeLohn Check Digit).
15		15
16	Changes in the December 2021 definition by Daniel Marschall:	16	Changes in the December 2021 definition by Daniel Marschall:
17	- There are several classes of WEIDs which have different OID bases:	17	- There are several classes of WEIDs which have different OID bases:
18	"Class C" WEID: weid:EXAMPLE-3 (base .1.3.6.1.4.1.37553.8.)	18	"Class C" WEID: weid:EXAMPLE-3 (base .1.3.6.1.4.1.37553.8.)
19	oid:1.3.6.1.4.1.37553.8.32488192274	19	oid:1.3.6.1.4.1.37553.8.32488192274
20	"Class B" WEID: weid:pen:SX0-7PR-6 (base .1.3.6.1.4.1.)	20	"Class B" WEID: weid:pen:SX0-7PR-6 (base .1.3.6.1.4.1.)
21	oid:1.3.6.1.4.1.37476.9999	21	oid:1.3.6.1.4.1.37476.9999
22	"Class A" WEID: weid:root:2-RR-2 (base .)	22	"Class A" WEID: weid:root:2-RR-2 (base .)
23	oid:2.999	23	oid:2.999
24	- The namespace (weid:, weid:pen:, weid:root:) is now case insensitive.	24	- The namespace (weid:, weid:pen:, weid:root:) is now case insensitive.
25	- Padding with '0' characters is valid (e.g. weid:000EXAMPLE-3)	25	- Padding with '0' characters is valid (e.g. weid:000EXAMPLE-3)
26	The paddings do not count into the WeLuhn check-digit.	26	The paddings do not count into the WeLuhn check-digit.
27	*)	27	*)
28		28
29	interface	29	interface
30		30
31	(*	31	(*
32	Translates a weid to an oid	32	Translates a weid to an oid
33	"weid:EXAMPLE-3" becomes "1.3.6.1.4.1.37553.8.32488192274"	33	"weid:EXAMPLE-3" becomes "1.3.6.1.4.1.37553.8.32488192274"
34	If it failed (e.g. wrong namespace, wrong checksum, etc.) then false is returned.	34	If it failed (e.g. wrong namespace, wrong checksum, etc.) then false is returned.
35	If the weid ends with '?', then it will be replaced with the checksum,	35	If the weid ends with '?', then it will be replaced with the checksum,
36	e.g. weid:EXAMPLE-? becomes weid:EXAMPLE-3	36	e.g. weid:EXAMPLE-? becomes weid:EXAMPLE-3
37	*)	37	*)
38	function WeidToOid(var weid: string): string;	38	function WeidToOid(var weid: string): string;
39		39
40	(*	40	(*
41	Converts an OID to WEID	41	Converts an OID to WEID
42	"1.3.6.1.4.1.37553.8.32488192274" becomes "weid:EXAMPLE-3"	42	"1.3.6.1.4.1.37553.8.32488192274" becomes "weid:EXAMPLE-3"
43	*)	43	*)
44	function OidToWeid(oid: string): string;	44	function OidToWeid(oid: string): string;
45		45
46	implementation	46	implementation
47		47
48	uses	48	uses
49	SysUtils;	49	SysUtils;
50		50
51	function LastCharPos(const S: string; const Chr: char): integer;	51	function LastCharPos(const S: string; const Chr: char): integer;
52	var	52	var
53	i: Integer;	53	i: Integer;
54	begin	54	begin
55	for i := length(S) downto 1 do	55	for i := length(S) downto 1 do
56	begin	56	begin
57	if S[i] = Chr then	57	if S[i] = Chr then
58	begin	58	begin
59	LastCharPos := i;	59	result := i;
60	Exit;	60	Exit;
61	end;	61	end;
62	end;	62	end;
63	LastCharPos := 0;	63	result := 0;
64	Exit;	64	Exit;
65	end;	65	end;
66		66
67	function base_convert_bigint(numstring: string; frombase, tobase: integer): string;	67	function base_convert_bigint(numstring: string; frombase, tobase: integer): string;
68	var	68	var
69	i: Integer;	69	i: Integer;
70	frombase_str: string;	70	frombase_str: string;
71	tobase_str: string;	71	tobase_str: string;
72	len: Integer;	72	len: Integer;
73	number: string;	73	number: string;
74	divide: Integer;	74	divide: Integer;
75	newlen: Integer;	75	newlen: Integer;
76	res: string;	76	res: string;
77	begin	77	begin
78	frombase_str := '';	78	frombase_str := '';
79	for i := 0 to frombase-1 do	79	for i := 0 to frombase-1 do
80	begin	80	begin
81	if i < 10 then	81	if i < 10 then
82	frombase_str := frombase_str + IntToStr(i)	82	frombase_str := frombase_str + IntToStr(i)
83	else	83	else
84	frombase_str := frombase_str + Chr(Ord('A') + (i-10));	84	frombase_str := frombase_str + Chr(Ord('A') + (i-10));
85	end;	85	end;
86		86
87	tobase_str := '';	87	tobase_str := '';
88	for i := 0 to tobase-1 do	88	for i := 0 to tobase-1 do
89	begin	89	begin
90	if i < 10 then	90	if i < 10 then
91	tobase_str := tobase_str + IntToStr(i)	91	tobase_str := tobase_str + IntToStr(i)
92	else	92	else
93	tobase_str := tobase_str + Chr(Ord('A') + (i-10));	93	tobase_str := tobase_str + Chr(Ord('A') + (i-10));
94	end;	94	end;
95		95
96	len := Length(numstring);	96	len := Length(numstring);
97	base_convert_bigint := '';	97	result := '';
98	number := numstring; (* this is a fake "Int8" array (implemented with chars) *)	98	number := numstring; (* this is a fake "Int8" array (implemented with chars) *)
99	for i := 0 to len-1 do	99	for i := 0 to len-1 do
100	begin	100	begin
101	number[i+1] := Chr(Pos(UpCase(numstring[i+1]), frombase_str)-1);	101	number[i+1] := Chr(Pos(UpCase(numstring[i+1]), frombase_str)-1);
102	end;	102	end;
103	res := '';	103	res := '';
104	repeat (* Loop until whole number is converted *)	104	repeat (* Loop until whole number is converted *)
105	divide := 0;	105	divide := 0;
106	newlen := 0;	106	newlen := 0;
107	for i := 0 to len-1 do (* Perform division manually (which is why this works with big numbers) *)	107	for i := 0 to len-1 do (* Perform division manually (which is why this works with big numbers) *)
108	begin	108	begin
109	divide := divide * frombase + Ord(number[i+1]);	109	divide := divide * frombase + Ord(number[i+1]);
110	if (divide >= tobase) then	110	if (divide >= tobase) then
111	begin	111	begin
112	number[newlen+1] := Chr(divide div tobase);	112	number[newlen+1] := Chr(divide div tobase);
113	Inc(newlen);	113	Inc(newlen);
114	divide := divide mod tobase;	114	divide := divide mod tobase;
115	end	115	end
116	else if newlen > 0 then	116	else if newlen > 0 then
117	begin	117	begin
118	number[newlen+1] := #0;	118	number[newlen+1] := #0;
119	Inc(newlen);	119	Inc(newlen);
120	end;	120	end;
121	end;	121	end;
122	len := newlen;	122	len := newlen;
123	res := tobase_str[divide+1] + res; (* Divide is basically $numstring % $tobase (i.e. the new character) *)	123	res := tobase_str[divide+1] + res; (* Divide is basically "numstring mod tobase" (i.e. the new character) *)
124	until newlen = 0;	124	until newlen = 0;
125	base_convert_bigint := res;	125	result := res;
126	end;	126	end;
127		127
128	function weLuhnGetCheckDigit(s: string): integer;	128	function weLuhnGetCheckDigit(s: string): integer;
129	var	129	var
130	p: integer;	130	p: integer;
131	wrkstr: string;	131	wrkstr: string;
132	c: Char;	132	c: Char;
133	i: Integer;	133	i: Integer;
134	sum: integer;	134	sum: integer;
135	nbdigits: Integer;	135	nbdigits: Integer;
136	parity: Integer;	136	parity: Integer;
137	n: Integer;	137	n: Integer;
138	digit: Integer;	138	digit: Integer;
139	begin	139	begin
140	(* Padding zeros don't count to the check digit (December 2021) *)	140	(* Padding zeros don't count to the check digit (December 2021) *)
141	s := '-' + s + '-';	141	s := '-' + s + '-';
142	while Pos('-0', s) > 0 do	142	while Pos('-0', s) > 0 do
143	begin	143	begin
144	s := StringReplace(s, '-0-', #1, [rfReplaceAll]);	144	s := StringReplace(s, '-0-', #1, [rfReplaceAll]);
145	s := StringReplace(s, '-0', '-', [rfReplaceAll]);	145	s := StringReplace(s, '-0', '-', [rfReplaceAll]);
146	end;	146	end;
147	s := StringReplace(s, #1, '-0-', [rfReplaceAll]);	147	s := StringReplace(s, #1, '-0-', [rfReplaceAll]);
148	s := Copy(s, 2, Length(s)-2);	148	s := Copy(s, 2, Length(s)-2);
149		149
150	(* remove separators of the WEID string *)	150	(* remove separators of the WEID string *)
151	wrkstr := StringReplace(s, '-', '', [rfReplaceAll]);	151	wrkstr := StringReplace(s, '-', '', [rfReplaceAll]);
152		152
153	(* Replace 'a' with '10', 'b' with '11', etc. *)	153	(* Replace 'a' with '10', 'b' with '11', etc. *)
154	for c := 'A' to 'Z' do	154	for c := 'A' to 'Z' do
155	begin	155	begin
156	wrkstr := StringReplace(wrkstr, c, IntToStr(Ord(c)-Ord('A')+10), [rfReplaceAll]);	156	wrkstr := StringReplace(wrkstr, c, IntToStr(Ord(c)-Ord('A')+10), [rfReplaceAll]);
157	end;	157	end;
158		158
159	(* At the end, $wrkstr should only contain digits! Verify it! *)	159	(* At the end, wrkstr should only contain digits! Verify it! *)
160	for i := 1 to Length(wrkstr) do	160	for i := 1 to Length(wrkstr) do
161	begin	161	begin
162	if not (wrkstr[i] in ['0'..'9']) then	162	if not (wrkstr[i] in ['0'..'9']) then
163	begin	163	begin
164	weLuhnGetCheckDigit := -1;	164	result := -1;
165	exit;	165	exit;
166	end;	166	end;
167	end;	167	end;
168		168
169	(* Now do the standard Luhn algorithm *)	169	(* Now do the standard Luhn algorithm *)
170	nbdigits := Length(wrkstr);	170	nbdigits := Length(wrkstr);
171	parity := nbdigits and 1; (* mod 2 *)	171	parity := nbdigits and 1; (* mod 2 *)
172	sum := 0;	172	sum := 0;
173	for n := nbdigits-1 downto 0 do	173	for n := nbdigits-1 downto 0 do
174	begin	174	begin
175	digit := StrToInt(wrkstr[n+1]);	175	digit := StrToInt(wrkstr[n+1]);
176	if (n and 1) <> parity then digit := digit * 2;	176	if (n and 1) <> parity then digit := digit * 2;
177	if digit > 9 then digit := digit - 9;	177	if digit > 9 then digit := digit - 9;
178	sum := sum + digit;	178	sum := sum + digit;
179	end;	179	end;
180		180
181	if sum mod 10 = 0 then	181	if sum mod 10 = 0 then
182	weLuhnGetCheckDigit := 0	182	result := 0
183	else	183	else
184	weLuhnGetCheckDigit := 10 - (sum mod 10);	184	result := 10 - (sum mod 10);
185	end;	185	end;
186		186
187	function WeidToOid(var weid: string): string;	187	function WeidToOid(var weid: string): string;
188	var	188	var
189	base: string;	189	base: string;
190	namespace: string;	190	namespace: string;
191	p: integer;	191	p: integer;
192	rest: string;	192	rest: string;
193	actual_checksum: string;	193	actual_checksum: string;
194	expected_checksum: integer;	194	expected_checksum: integer;
195	complete: string;	195	complete: string;
196	oidstr: string;	196	oidstr: string;
197	arc: string;	197	arc: string;
198	begin	198	begin
199	p := LastCharPos(weid,':');	199	p := LastCharPos(weid,':');
200	namespace := Copy(weid, 1, p);	200	namespace := Copy(weid, 1, p);
201	rest := Copy(weid, p+1, Length(weid)-p);	201	rest := Copy(weid, p+1, Length(weid)-p);
202		202
203	namespace := LowerCase(namespace); (* namespace is case insensitive *)	203	namespace := LowerCase(namespace); (* namespace is case insensitive *)
204	if namespace = 'weid:' then	204	if namespace = 'weid:' then
205	begin	205	begin
206	(* Class C *)	206	(* Class C *)
207	base := '1-3-6-1-4-1-SZ5-8';	207	base := '1-3-6-1-4-1-SZ5-8';
208	end	208	end
209	else if namespace = 'weid:pen:' then	209	else if namespace = 'weid:pen:' then
210	begin	210	begin
211	(* Class B *)	211	(* Class B *)
212	base := '1-3-6-1-4-1';	212	base := '1-3-6-1-4-1';
213	end	213	end
214	else if namespace = 'weid:root:' then	214	else if namespace = 'weid:root:' then
215	begin	215	begin
216	(* Class A *)	216	(* Class A *)
217	base := '';	217	base := '';
218	end	218	end
219	else	219	else
220	begin	220	begin
221	(* Wrong namespace *)	221	(* Wrong namespace *)
222	WeidToOid := '';	222	result := '';
223	Exit;	223	Exit;
224	end;	224	end;
225		225
226	weid := rest;	226	weid := rest;
227		227
228	if base <> '' then	228	if base <> '' then
229	complete := base + '-' + weid	229	complete := base + '-' + weid
230	else	230	else
231	complete := weid;	231	complete := weid;
232	p := LastCharPos(complete, '-');	232	p := LastCharPos(complete, '-');
233	actual_checksum := Copy(complete, p+1, 1);	233	actual_checksum := Copy(complete, p+1, 1);
234	complete := Copy(complete, 1, p-1);	234	complete := Copy(complete, 1, p-1);
235	expected_checksum := weLuhnGetCheckDigit(complete);	235	expected_checksum := weLuhnGetCheckDigit(complete);
236	if (actual_checksum <> '?') then	236	if (actual_checksum <> '?') then
237	begin	237	begin
238	if actual_checksum <> IntToStr(expected_checksum) then	238	if actual_checksum <> IntToStr(expected_checksum) then
239	begin	239	begin
240	WeidToOid := ''; (* wrong checksum *)	240	result := ''; (* wrong checksum *)
241	Exit;	241	Exit;
242	end;	242	end;
243	end	243	end
244	else	244	else
245	begin	245	begin
246	(* If checksum is '?', it will be replaced by the actual checksum, *)	246	(* If checksum is '?', it will be replaced by the actual checksum, *)
247	(* e.g. weid:EXAMPLE-? becomes weid:EXAMPLE-3 *)	247	(* e.g. weid:EXAMPLE-? becomes weid:EXAMPLE-3 *)
248	weid := StringReplace(weid, '?', IntToStr(expected_checksum), [rfReplaceAll]);	248	weid := StringReplace(weid, '?', IntToStr(expected_checksum), [rfReplaceAll]);
249	end;	249	end;
250		250
251	oidstr := '';	251	oidstr := '';
252	while true do	252	while true do
253	begin	253	begin
254	p := Pos('-', complete);	254	p := Pos('-', complete);
255	if p = 0 then p := Length(complete)+1;	255	if p = 0 then p := Length(complete)+1;
256	arc := Copy(complete, 1, p-1);	256	arc := Copy(complete, 1, p-1);
257	Delete(complete, 1, p);	257	Delete(complete, 1, p);
258	oidstr := oidstr + base_convert_bigint(arc, 36, 10) + '.';	258	oidstr := oidstr + base_convert_bigint(arc, 36, 10) + '.';
259	if complete = '' then break;	259	if complete = '' then break;
260	end;	260	end;
261	oidstr := Copy(oidstr, 1, Length(oidstr)-1);	261	oidstr := Copy(oidstr, 1, Length(oidstr)-1);
262		262
263	weid := namespace + weid; (* add namespace again *)	263	weid := namespace + weid; (* add namespace again *)
264		264
265	WeidToOid := oidstr;	265	result := oidstr;
266	end;	266	end;
267		267
268	function OidToWeid(oid: string): string;	268	function OidToWeid(oid: string): string;
269	var	269	var
270	is_class_a: boolean;	270	is_class_a: boolean;
271	is_class_b: boolean;	271	is_class_b: boolean;
272	is_class_c: boolean;	272	is_class_c: boolean;
273	weidstr: string;	273	weidstr: string;
274	checksum: string;	274	checksum: string;
275	namespace: string;	275	namespace: string;
276	p: Integer;	276	p: Integer;
277	cd: Integer;	277	cd: Integer;
278	res: string;	278	res: string;
279	begin	279	begin
280	if Copy(oid,1,1) = '.' then	280	if Copy(oid,1,1) = '.' then
281	Delete(oid,1,1); (* remove leading dot *)	281	Delete(oid,1,1); (* remove leading dot *)
282		282
283	if oid <> '' then	283	if oid <> '' then
284	begin	284	begin
285	weidstr := '';	285	weidstr := '';
286	while true do	286	while true do
287	begin	287	begin
288	p := Pos('.', oid);	288	p := Pos('.', oid);
289	if p = 1 then	289	if p = 1 then
290	begin	290	begin
291	Delete(oid, 1, 1);	291	Delete(oid, 1, 1);
292	end	292	end
293	else if p > 0 then	293	else if p > 0 then
294	begin	294	begin
295	weidstr := weidstr + base_convert_bigint(Copy(oid, 1, p-1),10,36) + '-';	295	weidstr := weidstr + base_convert_bigint(Copy(oid, 1, p-1),10,36) + '-';
296	Delete(oid, 1, p);	296	Delete(oid, 1, p);
297	end	297	end
298	else	298	else
299	begin	299	begin
300	weidstr := weidstr + base_convert_bigint(oid,10,36) + '-';	300	weidstr := weidstr + base_convert_bigint(oid,10,36) + '-';
301	break;	301	break;
302	end;	302	end;
303	end;	303	end;
304	weidstr := Copy(weidstr, 1, Length(weidstr)-1);	304	weidstr := Copy(weidstr, 1, Length(weidstr)-1);
305	end	305	end
306	else	306	else
307	begin	307	begin
308	weidstr := '';	308	weidstr := '';
309	end;	309	end;
310		310
311	is_class_c := (Pos('1-3-6-1-4-1-SZ5-8-', weidstr) = 1) or	311	is_class_c := (Pos('1-3-6-1-4-1-SZ5-8-', weidstr) = 1) or
312	(weidstr = '1-3-6-1-4-1-SZ5-8');	312	(weidstr = '1-3-6-1-4-1-SZ5-8');
313	is_class_b := ((Pos('1-3-6-1-4-1-', weidstr) = 1) or	313	is_class_b := ((Pos('1-3-6-1-4-1-', weidstr) = 1) or
314	(weidstr = '1-3-6-1-4-1'))	314	(weidstr = '1-3-6-1-4-1'))
315	and not is_class_c;	315	and not is_class_c;
316	is_class_a := not is_class_b and not is_class_c;	316	is_class_a := not is_class_b and not is_class_c;
317		317
318	cd := weLuhnGetCheckDigit(weidstr);	318	cd := weLuhnGetCheckDigit(weidstr);
319	if cd < 0 then	319	if cd < 0 then
320	begin	320	begin
321	OidToWeid := weidstr;	321	result := weidstr;
322	exit;	322	exit;
323	end;	323	end;
324	checksum := IntToStr(cd);	324	checksum := IntToStr(cd);
325		325
326	if is_class_c then	326	if is_class_c then
327	begin	327	begin
328	Delete(weidstr, 1, Length('1-3-6-1-4-1-SZ5-8-'));	328	Delete(weidstr, 1, Length('1-3-6-1-4-1-SZ5-8-'));
329	namespace := 'weid:';	329	namespace := 'weid:';
330	end	330	end
331	else if is_class_b then	331	else if is_class_b then
332	begin	332	begin
333	Delete(weidstr, 1, Length('1-3-6-1-4-1-'));	333	Delete(weidstr, 1, Length('1-3-6-1-4-1-'));
334	namespace := 'weid:pen:';	334	namespace := 'weid:pen:';
335	end	335	end
336	else if is_class_a then	336	else if is_class_a then
337	begin	337	begin
338	(* weidstr stays *)	338	(* weidstr stays *)
339	namespace := 'weid:root:';	339	namespace := 'weid:root:';
340	end	340	end
341	else	341	else
342	begin	342	begin
343	(* should not happen *)	343	(* should not happen *)
344	OidToWeid := '';	344	result := '';
345	Exit;	345	Exit;
346	end;	346	end;
347		347
348	res := namespace;	348	res := namespace;
349	if weidstr = '' then	349	if weidstr = '' then
350	res := res + checksum	350	res := res + checksum
351	else	351	else
352	res := res + weidstr + '-' + checksum;	352	res := res + weidstr + '-' + checksum;
353	OidToWeid := res;	353	result := res;
354	end;	354	end;
355		355
356	end.	356	end.
357		357

Subversion Repositories oidplus

oidplus/trunk_dos/WEID_Delphi.pas – Rev 748 → 749