Subversion Repositories oidplus

Compare Revisions

No changes between revisions

Regard whitespace Rev 747 → Rev 748

/trunk_dos/OIDFILE.PAS
3,7 → 3,7
(************************************************)
(* OIDFILE.PAS *)
(* Author: Daniel Marschall *)
(* Revision: 2022-02-15 *)
(* Revision: 2022-02-19 *)
(* License: Apache 2.0 *)
(* This file contains: *)
(* - Functions to handle an OID ASCII format *)
20,6 → 20,7
FileId: string;
DotNotation: string;
ASNIds: PStringList;
UnicodeLabels: PStringList;
Description: string;
SubIds: PStringList; (* first 8 chars are FileId, followed by DotNotation *)
ParentFileId: string;
39,7 → 40,7
implementation
 
uses
VtsFuncs, OidUtils;
VtsFuncs, OidUtils, Crt;
 
const
WANT_VERS = '2022';
46,7 → 47,11
 
procedure CreateOidDef(var oid: POid);
begin
oid := nil;
GetMem(oid, SizeOf(TOID));
 
if oid <> nil then
begin
oid^.FileId := '';
oid^.DotNotation := '';
oid^.Description := '';
53,15 → 58,34
oid^.ParentFileId := '';
oid^.ParentDotNotation := '';
CreateList(oid^.ASNIds);
CreateList(oid^.UnicodeLabels);
CreateList(oid^.SubIds);
end
else
begin
Beep;
WriteLn('CreateOidDef failed! (GetMem returned nil)');
ReadKey;
end;
end;
 
procedure FreeOidDef(oid: POid);
begin
if oid <> nil then
begin
FreeList(oid^.ASNIds);
FreeList(oid^.UnicodeLabels);
FreeList(oid^.SubIds);
FreeMem(oid, SizeOf(TOID));
oid := nil;
end
else
begin
Beep;
WriteLn('FreeOidDef failed! (Argument is nil)');
ReadKey;
end;
end;
 
procedure ClearOidDef(oid: POid);
begin
71,6 → 95,7
oid^.ParentFileId := '';
oid^.ParentDotNotation := '';
ListClear(oid^.ASNIds);
ListClear(oid^.UnicodeLabels);
ListClear(oid^.SubIds);
end;
 
142,6 → 167,12
WriteLn(f, 'ASN1' + sTmp);
end;
 
for i := 0 to ListCount(oid^.UnicodeLabels)-1 do
begin
sTmp := ListGetElement(oid^.UnicodeLabels, i);
WriteLn(f, 'UNIL' + sTmp);
end;
 
desc := Trim(oid^.Description);
if desc <> '' then
begin
214,6 → 245,11
ListAppend(oid^.ASNIds, line);
end;
 
if cmd = 'UNIL' then
begin
ListAppend(oid^.UnicodeLabels, line);
end;
 
if cmd = 'DESC' then
begin
oid^.Description := oid^.Description + line + #13#10;
/trunk_dos/OIDPLUS.EXE
Cannot display: file marked as a binary type.
svn:mime-type = application/octet-stream
/trunk_dos/OIDPLUS.PAS
3,7 → 3,7
(************************************************)
(* OIDPLUS.PAS *)
(* Author: Daniel Marschall *)
(* Revision: 2022-02-16 *)
(* Revision: 2022-02-19 *)
(* License: Apache 2.0 *)
(* This file contains: *)
(* - "OIDplus for DOS" program *)
18,10 → 18,11
(* Instead, use the tool "TPPATCH" by Andreas Bauer. *)
 
uses
Dos, Crt, Drivers, StrList, VtsFuncs, VtsCui, OidFile, OidUtils;
Dos, Crt, Drivers, StrList, VtsFuncs, VtsCui, OidFile, OidUtils,
Weid;
 
const
VERSIONINFO = 'Revision: 2022-02-16';
VERSIONINFO = 'Revision: 2022-02-19';
DEFAULT_STATUSBAR = '(C)2020-2022 ViaThinkSoft. Licensed under the terms of the Apache 2.0 license.';
TITLEBAR_LEFT_TEXT = 'OIDplus';
DISKIO_SOUND_DEBUGGING = false;
253,6 → 254,144
until false;
end;
 
function UnicodeLabelAlreadyExisting(oid: POID; unicodeLabel: string): boolean;
begin
UnicodeLabelAlreadyExisting := ListContains(oid^.UnicodeLabels, unicodeLabel);
end;
 
function IriEditor(oid: POID): boolean;
var
iriList: PStringList;
i: integer;
x, y, w, h: integer;
res: integer;
sInput: string;
menuIdNew, menuIdSave, menuIdExit: integer;
begin
IriEditor := false;
 
repeat
CreateList(iriList);
 
for i := 0 to ListCount(oid^.UnicodeLabels)-1 do
begin
ListAppend(iriList, ListGetElement(oid^.UnicodeLabels, i));
end;
menuIdNew := ListAppend(iriList, '<NEW>');
menuIdSave := ListAppend(iriList, '<SAVE>');
menuIdExit := ListAppend(iriList, '<CANCEL>');
 
DrawStatusBar(DEFAULT_STATUSBAR);
x := SINGLE_LINE_BOX_PADDING;
y := ScreenHeight div 2 - ASNEDIT_LINES div 2;
w := ScreenWidth - (SINGLE_LINE_BOX_PADDING-1)*2;
h := ASNEDIT_LINES;
res := DrawSelectionList(x, y, w, h,
iriList, true,
'EDIT UNICODE LABELS',
2);
FreeList(iriList);
 
(* Change double-border to thin-border *)
DrawThinBorder(x-1, y-1, w+2, h+2);
GoToXY(x+1, y-1);
Write('EDIT UNICODE LABELS');
 
if res = -1 then
begin
exit;
end
else if res = menuIdNew then
begin
(* "NEW" item was selected *)
sInput := '';
CursorOn;
repeat
if QueryVal(sInput,
SINGLE_LINE_BOX_PADDING_INNER,
ScreenHeight div 2,
ScreenWidth - (SINGLE_LINE_BOX_PADDING_INNER-1)*2,
1,
'ADD SINGLE UNICODE LABEL',
2) then
begin
if sInput = '' then continue;
if not UnicodeLabelValid(sInput) then
begin
ShowMessage('Invalid Unicode Label!', 'ERROR', true);
_Pause;
end
else if UnicodeLabelAlreadyExisting(oid, sInput) then
begin
ShowMessage('Unicode Label is already existing on this arc', 'ERROR', true);
_Pause;
end
else
begin
ListAppend(oid^.UnicodeLabels, sInput);
break;
end;
end
else break;
until false;
CursorOff;
end
else if res = menuIdSave then
begin
(* "SAVE" item was selected *)
IriEditor := true;
Exit;
end
else if res = menuIdExit then
begin
(* "CANCEL" item was selected *)
IriEditor := false;
Exit;
end
else
begin
DrawStatusBar('Note: Remove the text to delete the Unicode Label');
sInput := ListGetElement(oid^.UnicodeLabels, res);
CursorOn;
repeat
if QueryVal(sInput,
SINGLE_LINE_BOX_PADDING_INNER,
ScreenHeight div 2,
ScreenWidth - (SINGLE_LINE_BOX_PADDING_INNER-1)*2,
1,
'EDIT SINGLE UNICODE LABEL',
2) then
begin
if sInput = '' then
begin
(* Empty input = Delete Unicode label *)
ListDeleteElementByIndex(oid^.UnicodeLabels, res);
break;
end
else if not UnicodeLabelValid(sInput) then
begin
ShowMessage('Invalid Unicode Label!', 'ERROR', true);
_Pause;
end
else if UnicodeLabelAlreadyExisting(oid, sInput) and
not (ListGetElement(oid^.UnicodeLabels, res) = sInput) then
begin
ShowMessage('Unicode Label is already existing on this arc', 'ERROR', true);
_Pause;
end
else
begin
ListSetElement(oid^.UnicodeLabels, res, sInput);
break;
end;
end
else break;
until false;
CursorOff;
end;
until false;
end;
 
function DescEditor(oid: POID): boolean;
var
sInput: string;
395,6 → 534,7
newOID^.ParentDotNotation := oid^.DotNotation;
if NumIdEditor(newOID, oid) and
AsnEditor(newOID) and
IriEditor(newOID) and
DescEditor(newOID) then
begin
newfilename := newOID^.FileId + OID_EXTENSION;
505,17 → 645,109
DrawTitleBar('OID ' + oid^.DotNotation, TITLEBAR_LEFT_TEXT, filename);
end;
 
function DotNotation(oid: POid): string;
var
res: string;
begin
res := oid^.DotNotation;
if res = '' then res := '.'; (* root *)
DotNotation := res;
end;
 
function OidLastArc(oid: POid): string;
var
s: string;
p: integer;
begin
s := oid^.DotNotation;
 
while true do
begin
p := Pos('.', s);
if p = 0 then break;
Delete(s, 1, p);
end;
 
OidLastArc := s;
end;
 
function AsnNotation(oid: POid): string;
var
prevOid, curOid: POid;
res: string;
begin
CreateOidDef(curOid);
prevOid := oid;
res := '';
 
while true do
begin
(* Note: BackRef is not checked yet! Infinite loop is possible! (TODO) *)
ReadOidFile(prevOid^.ParentFileId + '.OID', curOid);
if curOid^.ParentFileId = '' then break;
if curOid^.ParentFileId = curOid^.FileId then break;
if ListCount(curOid^.AsnIds) > 0 then
res := ListGetElement(curOid^.AsnIds, 0) + '('+OidLastArc(curOid)+') ' + res
else
res := OidLastArc(curOid) + ' ' + res;
prevOid := curOid;
end;
FreeOidDef(curOid);
if ListCount(oid^.AsnIds) > 0 then
res := res + ListGetElement(oid^.AsnIds, 0) + '('+OidLastArc(oid)+')'
else
res := res + OidLastArc(oid);
if res = '' then
AsnNotation := ''
else
AsnNotation := '{ ' + res + ' }';
end;
 
function IriNotation(oid: POid): string;
var
prevOid, curOid: POid;
res: string;
begin
CreateOidDef(curOid);
prevOid := oid;
res := '';
 
while true do
begin
(* Note: BackRef is not checked yet! Infinite loop is possible! (TODO) *)
ReadOidFile(prevOid^.ParentFileId + '.OID', curOid);
if curOid^.ParentFileId = '' then break;
if curOid^.ParentFileId = curOid^.FileId then break;
if ListCount(curOid^.UnicodeLabels) > 0 then
res := ListGetElement(curOid^.UnicodeLabels, 0) + '/' + res
else
res := OidLastArc(curOid) + '/' + res;
prevOid := curOid;
end;
FreeOidDef(curOid);
if ListCount(oid^.UnicodeLabels) > 0 then
res := res + ListGetElement(oid^.UnicodeLabels, 0)
else
res := res + OidLastArc(oid);
IriNotation := '/' + res;
end;
 
function WeidNotation(oid: POid): string;
begin
WeidNotation := OidToWeid(oid^.DotNotation);
end;
 
procedure DisplayOIDFile(filename: string);
var
isRoot: boolean;
oid, tmpOID: POID;
i, menuX, menuY: integer;
linesLeft, linesRequired: integer;
i: integer;
sTmp, subfile: string;
subsel, subfiles: PStringList;
subselres: integer;
exitRequest: boolean;
menuIdExit, menuIdAsnEdit, menuIdDescEdit, menuIdAdd, menuIdDelete: integer;
menuIdExit, menuIdAsnEdit, menuIdIriEdit, menuIdDescEdit, menuIdAdd, menuIdDelete: integer;
menuX, menuY: integer;
begin
exitRequest := false;
repeat
534,50 → 766,30
DrawStatusBar(DEFAULT_STATUSBAR);
GotoXY(1,2);
 
if oid^.DotNotation <> '' then
(*if oid^.DotNotation <> '' then*)
begin
WriteLn('Dot-Notation:');
WriteLn(oid^.DotNotation);
Write('Dot notation: ');
WriteLnKeepX(DotNotation(oid));
Write('IRI notation: ');
WriteLnKeepX(IriNotation(oid));
Write('ASN.1 notation: ');
WriteLnKeepX(AsnNotation(oid));
Write('WEID notation: ');
WriteLnKeepX(WeidNotation(oid));
WriteLn('');
end;
 
if Trim(oid^.Description) <> '' then
begin
WriteLn('Description:');
(* WriteLn('Description:'); *)
WriteLn(oid^.Description);
WriteLn('');
end;
 
menuX := WhereX + 1;
menuY := ScreenHeight - ACTIONMENU_SIZE - 1;
 
if ListCount(oid^.ASNIDs) > 0 then
begin
linesLeft := menuY - WhereY - 1;
linesRequired := 1 + ListCount(oid^.ASNIds);
 
if LinesLeft < LinesRequired then
begin
(* Compact display of ASN.1 identifiers *)
Write('ASN.1-Identifiers: ');
for i := 0 to ListCount(oid^.ASNIds)-1 do
begin
if i > 0 then Write(', ');
Write(ListGetElement(oid^.ASNIds, i));
end;
WriteLn('');
end
else
begin
(* Long display of ASN.1 identifiers *)
WriteLn('ASN.1-Identifiers:');
for i := 0 to ListCount(oid^.ASNIds)-1 do
begin
WriteLn('- '+ListGetElement(oid^.ASNIds, i));
end;
WriteLn('(No description has been added to this OID.)');
WriteLn('');
end;
end;
 
(* Now prepare the menu entries *)
 
659,11 → 871,18
 
if oid^.DotNotation <> '' then
begin
menuIdAsnEdit := ListAppend(subsel, 'Edit ASN.1 identifiers');
menuIdAsnEdit := ListAppend(subsel, 'View/Edit ASN.1 identifiers');
ListAppend(subfiles, '');
end
else menuIdAsnEdit := -99;
 
if oid^.DotNotation <> '' then
begin
menuIdIriEdit := ListAppend(subsel, 'View/Edit Unicode Labels');
ListAppend(subfiles, '');
end
else menuIdIriEdit := -99;
 
menuIdDescEdit := ListAppend(subsel, 'Edit description');
ListAppend(subfiles, '');
 
679,6 → 898,8
 
(* Show menu *)
 
menuX := WhereX + 1;
menuY := ScreenHeight - ACTIONMENU_SIZE - 1;
subselres := DrawSelectionList(menuX, menuY,
ScreenWidth-2,
ACTIONMENU_SIZE,
698,6 → 919,11
if AsnEditor(oid) then
_WriteOidFile(filename, oid, true);
end
else if subselres = menuIdIriEdit then
begin
if IriEditor(oid) then
_WriteOidFile(filename, oid, true);
end
else if subselres = menuIdDescEdit then
begin
if DescEditor(oid) then
891,9 → 1117,12
var
list: PStringList;
begin
ClrScr;
DrawTitleBar('TreeView Export', TITLEBAR_LEFT_TEXT, TREEVIEW_FILENAME);
DrawStatusBar('Press ESC to return to the main menu');
 
CreateList(list);
 
DrawStatusBar('Press ESC to return to the main menu');
ListLoadFromFile(list, TREEVIEW_FILENAME);
DrawSelectionList(2, 3, ScreenWidth-2, ScreenHeight-4,
list, true, 'PREVIEW OF '+TREEVIEW_FILENAME, 2);
/trunk_dos/OIDUTILS.PAS
3,7 → 3,7
(************************************************)
(* OIDUTILS.PAS *)
(* Author: Daniel Marschall *)
(* Revision: 2022-02-14 *)
(* Revision: 2022-02-19 *)
(* License: Apache 2.0 *)
(* This file contains: *)
(* - Various OID functions *)
18,6 → 18,7
function CompareOID(a, b: string): integer;
procedure ListBubbleSortOID(list: PStringList);
function ASN1IDValid(asn1id: string): boolean;
function UnicodeLabelValid(unicodeLabel: string): boolean;
 
implementation
 
73,6 → 74,8
OIDtoArcList(a, la);
OIDtoArcList(b, lb);
CompareOID := CompareOIDArcList(la, lb);
FreeList(la);
FreeList(lb);
end;
 
procedure ListBubbleSortOID(list: PStringList);
126,4 → 129,77
ASN1IDValid := true;
end;
 
function UnicodeLabelValid(unicodeLabel: string): boolean;
begin
UnicodeLabelValid := true;
(* TODO: Implement *)
(*
 
 
function iri_char_valid($c, $firstchar, $lastchar) {
// see Rec. ITU-T X.660, clause 7.5
 
if (($firstchar || $lastchar) && ($c == '-')) return false;
 
if ($c == '-') return true;
if ($c == '.') return true;
if ($c == '_') return true;
if ($c == '~') return true;
if (($c >= '0') && ($c <= '9') && (!$firstchar)) return true;
if (($c >= 'A') && ($c <= 'Z')) return true;
if (($c >= 'a') && ($c <= 'z')) return true;
 
$v = mb_ord($c);
 
if (($v >= 0x000000A0) && ($v <= 0x0000DFFE)) return true;
if (($v >= 0x0000F900) && ($v <= 0x0000FDCF)) return true;
if (($v >= 0x0000FDF0) && ($v <= 0x0000FFEF)) return true;
if (($v >= 0x00010000) && ($v <= 0x0001FFFD)) return true;
if (($v >= 0x00020000) && ($v <= 0x0002FFFD)) return true;
if (($v >= 0x00030000) && ($v <= 0x0003FFFD)) return true;
if (($v >= 0x00040000) && ($v <= 0x0004FFFD)) return true;
if (($v >= 0x00050000) && ($v <= 0x0005FFFD)) return true;
if (($v >= 0x00060000) && ($v <= 0x0006FFFD)) return true;
if (($v >= 0x00070000) && ($v <= 0x0007FFFD)) return true;
if (($v >= 0x00080000) && ($v <= 0x0008FFFD)) return true;
if (($v >= 0x00090000) && ($v <= 0x0009FFFD)) return true;
if (($v >= 0x000A0000) && ($v <= 0x000AFFFD)) return true;
if (($v >= 0x000B0000) && ($v <= 0x000BFFFD)) return true;
if (($v >= 0x000C0000) && ($v <= 0x000CFFFD)) return true;
if (($v >= 0x000D0000) && ($v <= 0x000DFFFD)) return true;
if (($v >= 0x000E1000) && ($v <= 0x000EFFFD)) return true;
 
// Note: Rec. ITU-T X.660, clause 7.5.3 would also forbid ranges which are marked
// in ISO/IEC 10646 as "(This position shall not be used)"
// But tool implementers should be tolerate them, since these limitations can be removed in future.
 
return false;
}
 
function iri_arc_valid($arc, $allow_numeric=true) {
if ($arc == '') return false;
 
$m = array();
if ($allow_numeric && preg_match('@^(\\d+)$@', $arc, $m)) return true; # numeric arc
 
// Question: Should we strip RTL/LTR characters?
 
if (mb_substr($arc, 2, 2) == '--') return false; // see Rec. ITU-T X.660, clause 7.5.4
 
$array = array();
preg_match_all('/./u', $arc, $array, PREG_SET_ORDER);
$len = count($array);
foreach ($array as $i => $char) {
if (!iri_char_valid($char[0], $i==0, $i==$len-1)) return false;
}
 
return true;
}
 
 
*)
end;
 
end.
/trunk_dos/STRLIST.PAS
3,7 → 3,7
(************************************************)
(* STRLIST.PAS *)
(* Author: Daniel Marschall *)
(* Revision: 2022-02-16 *)
(* Revision: 2022-02-19 *)
(* License: Apache 2.0 *)
(* This file contains: *)
(* - StringList implementation for Turbo Pascal *)
194,8 → 194,11
tmp: PStringList;
i: integer;
begin
if idx < 0 then exit;
if idx > ListCount(list)-1 then exit;
if (idx < 0) or (idx > ListCount(list)-1) then
begin
ListGetElement := '';
Exit;
end;
 
tmp := list;
i := 0;
/trunk_dos/VTSCUI.PAS
3,7 → 3,7
(************************************************)
(* VTSCUI.PAS *)
(* Author: Daniel Marschall *)
(* Revision: 2022-02-16 *)
(* Revision: 2022-02-19 *)
(* License: Apache 2.0 *)
(* This file contains: *)
(* - ViaThinkSoft CUI (Console User Interface) *)
37,6 → 37,7
procedure CursorOn;
procedure CursorOff;
procedure ResetDefaultDosColors;
procedure WriteLnKeepX(s: string);
 
implementation
 
603,4 → 604,25
TextColor(LightGray);
end;
 
procedure WriteLnKeepX(s: string);
var
i: integer;
initX: integer;
bytesToWrite: integer;
pNewLine: integer;
begin
initX := WhereX;
while Length(s) > 0 do
begin
pNewLine := Pos(#13#10, s);
GoToXy(initX, WhereY);
bytesToWrite := ScreenWidth - initX + 1;
if (pNewLine > 0) and (pNewLine < bytesToWrite) then
bytesToWrite := pNewLine;
Write(Copy(s, 1, bytesToWrite)); (* No WriteLn because there is automatic scrolling *)
Delete(s, 1, bytesToWrite);
end;
WriteLn('');
end;
 
end.
/trunk_dos/VTSFUNCS.PAS
3,7 → 3,7
(************************************************)
(* VTSFUNCS.PAS *)
(* Author: Daniel Marschall *)
(* Revision: 2022-02-16 *)
(* Revision: 2022-02-19 *)
(* License: Apache 2.0 *)
(* This file contains: *)
(* - Various functions *)
35,6 → 35,10
 
function StringReplace(s, search, replace: string): string;
 
function LastCharPos(const S: string; const Chr: char): integer;
function LowerCase(s: string): string;
function base_convert_bigint(numstring: string; frombase, tobase: integer): string;
 
implementation
 
uses
241,8 → 245,16
i: integer;
output: string;
begin
if s = '' then exit;
if search = '' then exit; (* invalid arg *)
if s = '' then
begin
StringReplace := '';
Exit;
end;
if search = '' then
begin
StringReplace := s;
exit; (* invalid arg *)
end;
 
output := '';
while s <> '' do
262,4 → 274,101
StringReplace := output;
end;
 
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
LastCharPos := i;
Exit;
end;
end;
LastCharPos := 0;
Exit;
end;
 
function LowerCase(s: string): string;
var
res: string;
i: integer;
begin
res := '';
for i := 1 to Length(s) do
begin
if s[i] in ['A'..'Z'] then
begin
res := res + Chr(Ord('a')+(Ord(s[i])-Ord('A')));
end
else
begin
res := res + s[i];
end;
end;
LowerCase := res;
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);
base_convert_bigint := '';
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 % $tobase (i.e. the new character) *)
until newlen = 0;
base_convert_bigint := res;
end;
 
end.
/trunk_dos/WEID.PAS
0,0 → 1,279
unit WEID;
 
(*
* WEID<=>OID Converter for TurboPascal
* (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
VtsFuncs;
 
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);
s := StringReplace(s, '-0', '-');
end;
s := StringReplace(s, #1, '-0-');
s := Copy(s, 2, Length(s)-2);
 
(* remove separators of the WEID string *)
wrkstr := StringReplace(s, '-', '');
 
(* 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));
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
weLuhnGetCheckDigit := -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
weLuhnGetCheckDigit := 0
else
weLuhnGetCheckDigit := 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 *)
WeidToOid := '';
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
WeidToOid := ''; (* 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));
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 *)
 
WeidToOid := 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
OidToWeid := 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 *)
OidToWeid := '';
Exit;
end;
 
res := namespace;
if weidstr = '' then
res := res + checksum
else
res := res + weidstr + '-' + checksum;
OidToWeid := res;
end;
 
end.
/trunk_dos/WEID_Delphi.pas
0,0 → 1,356
unit WEID;
 
(*
* 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
LastCharPos := i;
Exit;
end;
end;
LastCharPos := 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);
base_convert_bigint := '';
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 % $tobase (i.e. the new character) *)
until newlen = 0;
base_convert_bigint := 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
weLuhnGetCheckDigit := -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
weLuhnGetCheckDigit := 0
else
weLuhnGetCheckDigit := 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 *)
WeidToOid := '';
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
WeidToOid := ''; (* 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 *)
 
WeidToOid := 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
OidToWeid := 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 *)
OidToWeid := '';
Exit;
end;
 
res := namespace;
if weidstr = '' then
res := res + checksum
else
res := res + weidstr + '-' + checksum;
OidToWeid := res;
end;
 
end.
/trunk_dos/screenshot.PNG
Cannot display: file marked as a binary type.
svn:mime-type = application/octet-stream