decoder
alarming
autosfx
aysalia
calllib
checksum-tools
colormanager
cryptochat
currency_converter
delphiutils
distributed
dpcstudio
dpg2
fastphp
fileformats
filter_foundry
forest
gridgame
ht46f47_simulator
indexer_suite
ipe_artfile_utils
javautils
jumper
lightgame
logviewer
musikbox
mystic_house
oidconverter
oidinfo_api
oidinfo_new_design
oidplus
personal-webbase
php_antispam
php_clientchallenge
php_guestbook
php_utils
plumbers
prepend
recyclebinunit
simple_log_event
sokoban
spacemission
stackman
userdetect2
uuid_mac_utils
vgwhois
vnag
webcounter
winbugtracker
yt_downloader
BlueGrey
calm
Elegant
Català-Valencià – Catalan
中文 – Chinese (Simplified)
中文 – Chinese (Traditional)
Česky – Czech
Dansk – Danish
Nederlands – Dutch
English – English
Suomi – Finnish
Français – French
Deutsch – German
עברית – Hebrew
हिंदी – Hindi
Magyar – Hungarian
Bahasa Indonesia – Indonesian
Italiano – Italian
日本語 – Japanese
한국어 – Korean
Македонски – Macedonian
मराठी – Marathi
Norsk – Norwegian
Polski – Polish
Português – Portuguese
Português – Portuguese (Brazil)
Русский – Russian
Slovenčina – Slovak
Slovenščina – Slovenian
Español – Spanish
Svenska – Swedish
Türkçe – Turkish
Українська – Ukrainian
Oëzbekcha – Uzbek
Subversion Repositories
decoder
decoder
/
trunk
/
VCL_DEC
/
DECFmt.pas
@ 2
– Rev
Rev
Blame
|
Last modification
|
View Log
|
RSS feed
{Copyright: Hagen Reddmann HaReddmann at T-Online dot de
Author: Hagen Reddmann
Version: 5.1, Delphi Encryption Compendium
Delphi 5-7, BCB 3-4, designed and testet under D5
Description: Format Konvertion Utilitys for the DEC Packages
known Problems: none
Remarks: freeware, but this Copyright must be included
add about 10Kb code if all TFormats used
designed to made universal code, not very fast implementations
use lookup tables and formats can contains special chars
* THIS SOFTWARE IS PROVIDED BY THE AUTHORS ''AS IS'' AND ANY EXPRESS
* OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
* WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
* ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE
* LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
* CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
* SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR
* BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
* WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE
* OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE,
* EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
}
unit
DECFmt
;
interface
uses
Windows
,
SysUtils
,
Classes
,
DECUtil
;
{$I VER.INC}
type
TDECFormat
=
class
;
TFormat_Copy
=
class
;
// copy input to output, it's the Default Format, eg FormaClass = nil
TFormat_HEX
=
class
;
// HEXadecimal in UpperCase
TFormat_HEXL
=
class
;
// HEXadecimal in Lowercase
TFormat_MIME32
=
class
;
// MIME like format for Base 32
TFormat_MIME64
=
class
;
// MIME Base 64 format
TFormat_PGP
=
class
;
// PGP's MIME Base 64 with PGP's Checksums
TFormat_UU
=
class
;
// Unix UU Base 64
TFormat_XX
=
class
;
// Unix XX base 64
TFormat_ESCAPE
=
class
;
// Escaped Strings
TDECFormatClass
=
class
of
TDECFormat
;
TDECFormat
=
class
(
TDECObject
)
// for binary one to one convert = fmtCOPY
protected
class
function
DoEncode
(
const
Value
;
Size
:
Integer
)
:
Binary
;
virtual
;
abstract
;
class
function
DoDecode
(
const
Value
;
Size
:
Integer
)
:
Binary
;
virtual
;
abstract
;
class
function
DoIsValid
(
const
Value
;
Size
:
Integer
)
:
Boolean
;
virtual
;
abstract
;
public
class
function
Encode
(
const
Value
:
Binary
)
:
Binary
;
overload
;
class
function
Encode
(
const
Value
;
Size
:
Integer
)
:
Binary
;
overload
;
class
function
Decode
(
const
Value
:
Binary
)
:
Binary
;
overload
;
class
function
Decode
(
const
Value
;
Size
:
Integer
)
:
Binary
;
overload
;
class
function
IsValid
(
const
Value
:
Binary
)
:
Boolean
;
overload
;
class
function
IsValid
(
const
Value
;
Size
:
Integer
)
:
Boolean
;
overload
;
end
;
TFormat_Copy
=
class
(
TDECFormat
)
protected
class
function
DoEncode
(
const
Value
;
Size
:
Integer
)
:
Binary
;
override
;
class
function
DoDecode
(
const
Value
;
Size
:
Integer
)
:
Binary
;
override
;
class
function
DoIsValid
(
const
Value
;
Size
:
Integer
)
:
Boolean
;
override
;
end
;
TFormat_HEX
=
class
(
TDECFormat
)
// Hexadecimal = fmtHEX
protected
class
function
DoEncode
(
const
Value
;
Size
:
Integer
)
:
Binary
;
override
;
class
function
DoDecode
(
const
Value
;
Size
:
Integer
)
:
Binary
;
override
;
class
function
DoIsValid
(
const
Value
;
Size
:
Integer
)
:
Boolean
;
override
;
public
class
function
CharTable
:
PChar
;
virtual
;
end
;
TFormat_HEXL
=
class
(
TFormat_HEX
)
// Hexadecimal lowercase = fmtHEXL
public
class
function
CharTable
:
PChar
;
override
;
end
;
TFormat_MIME32
=
class
(
TFormat_HEX
)
// MIME Base 32 = fmtMIME32
protected
class
function
DoEncode
(
const
Value
;
Size
:
Integer
)
:
Binary
;
override
;
class
function
DoDecode
(
const
Value
;
Size
:
Integer
)
:
Binary
;
override
;
public
class
function
CharTable
:
PChar
;
override
;
end
;
TFormat_MIME64
=
class
(
TFormat_HEX
)
// MIME Base 64 = fmtMIME64
protected
class
function
DoEncode
(
const
Value
;
Size
:
Integer
)
:
Binary
;
override
;
class
function
DoDecode
(
const
Value
;
Size
:
Integer
)
:
Binary
;
override
;
public
class
function
CharTable
:
PChar
;
override
;
end
;
TFormat_PGP
=
class
(
TFormat_MIME64
)
protected
class
function
DoExtractCRC
(
const
Value
;
var
Size
:
Integer
)
:
LongWord
;
class
function
DoEncode
(
const
Value
;
Size
:
Integer
)
:
Binary
;
override
;
class
function
DoDecode
(
const
Value
;
Size
:
Integer
)
:
Binary
;
override
;
end
;
TFormat_UU
=
class
(
TDECFormat
)
// UU Encode = fmtUU
protected
class
function
DoEncode
(
const
Value
;
Size
:
Integer
)
:
Binary
;
override
;
class
function
DoDecode
(
const
Value
;
Size
:
Integer
)
:
Binary
;
override
;
class
function
DoIsValid
(
const
Value
;
Size
:
Integer
)
:
Boolean
;
override
;
public
class
function
CharTable
:
PChar
;
virtual
;
end
;
TFormat_XX
=
class
(
TFormat_UU
)
// XX Encode = fmtXX
public
class
function
CharTable
:
PChar
;
override
;
end
;
TFormat_ESCAPE
=
class
(
TDECFormat
)
protected
class
function
DoEncode
(
const
Value
;
Size
:
Integer
)
:
Binary
;
override
;
class
function
DoDecode
(
const
Value
;
Size
:
Integer
)
:
Binary
;
override
;
end
;
function
ValidFormat
(
FormatClass
:
TDECFormatClass
=
nil
)
:
TDECFormatClass
;
function
FormatByName
(
const
Name
:
String
)
:
TDECFormatClass
;
function
FormatByIdentity
(
Identity
:
LongWord
)
:
TDECFormatClass
;
// insert #13#10 Chars in Blocks from BlockSize
function
InsertCR
(
const
Value
:
String
;
BlockSize
:
Integer
)
:
String
;
// delete all #13 and #10 Chars
function
DeleteCR
(
const
Value
:
String
)
:
String
;
// format any String to a Block
function
InsertBlocks
(
const
Value
,
BlockStart
,
BlockEnd
:
String
;
BlockSize
:
Integer
)
:
String
;
// remove any Block format
function
RemoveBlocks
(
const
Value
,
BlockStart
,
BlockEnd
:
String
)
:
String
;
var
PGPCharsPerLine
:
Integer
=
80
;
implementation
uses
CRC
;
resourcestring
sStringFormatExists
=
'String format "%d" not exists.'
;
sInvalidStringFormat
=
'Input is not an valid %s Format.'
;
sInvalidFormatString
=
'Input can not be convert to %s Format.'
;
sFormatNotRegistered
=
'String format not registered.'
;
function
ValidFormat
(
FormatClass
:
TDECFormatClass
=
nil
)
:
TDECFormatClass
;
begin
if
FormatClass <>
nil
then
Result
:
=
FormatClass
else
Result
:
=
TFormat_Copy
;
end
;
function
FormatByName
(
const
Name
:
String
)
:
TDECFormatClass
;
begin
Result
:
=
TDECFormatClass
(
DECClassByName
(
Name
,
TDECFormat
)
)
;
end
;
function
FormatByIdentity
(
Identity
:
LongWord
)
:
TDECFormatClass
;
begin
Result
:
=
TDECFormatClass
(
DECClassByIdentity
(
Identity
,
TDECFormat
)
)
;
end
;
class
function
TDECFormat
.
Encode
(
const
Value
:
Binary
)
:
Binary
;
begin
Result
:
=
DoEncode
(
Value
[
1
]
,
Length
(
Value
)
)
;
end
;
class
function
TDECFormat
.
Encode
(
const
Value
;
Size
:
Integer
)
:
Binary
;
begin
Result
:
=
DoEncode
(
Value
,
Size
)
;
end
;
class
function
TDECFormat
.
Decode
(
const
Value
:
Binary
)
:
Binary
;
begin
Result
:
=
DoDecode
(
Value
[
1
]
,
Length
(
Value
)
)
;
end
;
class
function
TDECFormat
.
Decode
(
const
Value
;
Size
:
Integer
)
:
Binary
;
begin
Result
:
=
DoDecode
(
Value
,
Size
)
;
end
;
class
function
TDECFormat
.
IsValid
(
const
Value
:
Binary
)
:
Boolean
;
begin
Result
:
=
DoIsValid
(
Value
[
1
]
,
Length
(
Value
)
)
;
end
;
class
function
TDECFormat
.
IsValid
(
const
Value
;
Size
:
Integer
)
:
Boolean
;
begin
Result
:
=
DoIsValid
(
Value
,
Size
)
;
end
;
// .TFormat_Copy
class
function
TFormat_Copy
.
DoEncode
(
const
Value
;
Size
:
Integer
)
:
Binary
;
begin
SetLength
(
Result
,
Size
)
;
Move
(
Value
,
Result
[
1
]
,
Size
)
;
end
;
class
function
TFormat_Copy
.
DoDecode
(
const
Value
;
Size
:
Integer
)
:
Binary
;
begin
SetLength
(
Result
,
Size
)
;
Move
(
Value
,
Result
[
1
]
,
Size
)
;
end
;
class
function
TFormat_Copy
.
DoIsValid
(
const
Value
;
Size
:
Integer
)
:
Boolean
;
begin
Result
:
=
Size >
=
0
;
end
;
function
TableFind
(
Value
:
Char
;
Table
:
PChar
;
Len
:
Integer
)
:
Integer
;
assembler
;
asm
// Utility for TStringFormat_XXXXX
PUSH EDI
MOV EDI
,
EDX
REPNE SCASB
MOV EAX
,
0
JNE
@@
1
MOV EAX
,
EDI
SUB EAX
,
EDX
@@
1
:
DEC EAX
POP EDI
end
;
class
function
TFormat_HEX
.
DoEncode
(
const
Value
;
Size
:
Integer
)
:
Binary
;
var
S
:
PByte
;
D
,
T
:
PChar
;
begin
Result
:
=
''
;
if
Size <
=
0
then
Exit
;
SetLength
(
Result
,
Size
*
2
)
;
T
:
=
CharTable
;
D
:
=
PChar
(
Result
)
;
S
:
=
PByte
(
@
Value
)
;
while
Size >
0
do
begin
D
[
0
]
:
=
T
[
S
^
shr
4
]
;
D
[
1
]
:
=
T
[
S
^
and
$F
]
;
Inc
(
D
,
2
)
;
Inc
(
S
)
;
Dec
(
Size
)
;
end
;
end
;
class
function
TFormat_HEX
.
DoDecode
(
const
Value
;
Size
:
Integer
)
:
Binary
;
var
S
:
PChar
;
D
:
PByte
;
T
:
PChar
;
I
,
P
:
Integer
;
HasIdent
:
Boolean
;
begin
Result
:
=
''
;
if
Size <
=
0
then
Exit
;
SetLength
(
Result
,
Size
div
2
+
1
)
;
T
:
=
CharTable
;
D
:
=
PByte
(
Result
)
;
S
:
=
PChar
(
@
Value
)
;
I
:
=
0
;
HasIdent
:
=
False
;
while
Size >
0
do
begin
P
:
=
TableFind
(
S
^
,
T
,
18
)
;
if
P <
0
then
P
:
=
TableFind
(
UpCase
(
S
^
)
,
T
,
16
)
;
if
P <
0
then
raise
EDECException
.
CreateFmt
(
sInvalidStringFormat
,
[
DECClassname
(
Self
)
]
)
;
Inc
(
S
)
;
if
P >
=
0
then
if
P >
16
then
begin
if
not
HasIdent
then
begin
HasIdent
:
=
True
;
I
:
=
0
;
D
:
=
PByte
(
Result
)
;
end
;
end
else
begin
if
Odd
(
I
)
then
begin
D
^
:
=
D
^
or
P
;
Inc
(
D
)
;
end
else
D
^
:
=
P
shl
4
;
Inc
(
I
)
;
end
;
Dec
(
Size
)
;
end
;
SetLength
(
Result
,
PChar
(
D
)
-
PChar
(
Result
)
)
;
end
;
class
function
TFormat_HEX
.
DoIsValid
(
const
Value
;
Size
:
Integer
)
:
Boolean
;
var
S
,
T
:
PChar
;
L
:
Integer
;
begin
Result
:
=
True
;
T
:
=
CharTable
;
L
:
=
StrLen
(
T
)
;
S
:
=
PChar
(
@
Value
)
;
while
Result
and
(
Size >
0
)
do
if
TableFind
(
S
^
,
T
,
L
)
>
=
0
then
begin
Dec
(
Size
)
;
Inc
(
S
)
;
end
else
Result
:
=
False
;
end
;
class
function
TFormat_HEX
.
CharTable
:
PChar
;
assembler
;
asm
MOV EAX
,
OFFSET
@@
1
RET
@@
1
:
DB
'0123456789ABCDEF'
// Table must be >= 18 Chars
DB
'X$ abcdefhHx()[]{},;:-_/\*+"'
''
,
9
,
10
,
13
,
0
end
;
class
function
TFormat_HEXL
.
CharTable
:
PChar
;
asm
MOV EAX
,
OFFSET
@@
1
RET
@@
1
:
DB
'0123456789abcdef'
// Table must be >= 18 Chars
DB
'X$ ABCDEFhHx()[]{},;:-_/\*+"'
''
,
9
,
10
,
13
,
0
end
;
class
function
TFormat_MIME32
.
DoEncode
(
const
Value
;
Size
:
Integer
)
:
Binary
;
var
S
:
PByteArray
;
D
,
T
:
PChar
;
I
:
Integer
;
begin
Result
:
=
''
;
if
Size <
=
0
then
Exit
;
Size
:
=
Size
*
8
;
SetLength
(
Result
,
Size
div
5
+
5
)
;
D
:
=
PChar
(
Result
)
;
T
:
=
CharTable
;
S
:
=
PByteArray
(
@
Value
)
;
I
:
=
0
;
while
I < Size
do
begin
D
^
:
=
T
[
PWord
(
@
S
[
I
shr
3
]
)
^
shr
(
I
and
$7
)
and
$1F
]
;
Inc
(
D
)
;
Inc
(
I
,
5
)
;
end
;
SetLength
(
Result
,
D
-
PChar
(
Result
)
)
;
end
;
class
function
TFormat_MIME32
.
DoDecode
(
const
Value
;
Size
:
Integer
)
:
Binary
;
var
S
,
T
,
D
:
PChar
;
I
,
V
:
Integer
;
begin
Result
:
=
''
;
if
Size <
=
0
then
Exit
;
T
:
=
CharTable
;
SetLength
(
Result
,
Size
*
5
div
8
)
;
D
:
=
PChar
(
Result
)
;
FillChar
(
D
^
,
Length
(
Result
)
,
0
)
;
S
:
=
PChar
(
@
Value
)
;
Size
:
=
Size
*
5
;
I
:
=
0
;
while
I < Size
do
begin
V
:
=
TableFind
(
S
^
,
T
,
32
)
;
if
V <
0
then
V
:
=
TableFind
(
UpCase
(
S
^
)
,
T
,
32
)
;
if
V >
=
0
then
begin
PWord
(
@
D
[
I
shr
3
]
)
^
:
=
PWord
(
@
D
[
I
shr
3
]
)
^
or
(
V
shl
(
I
and
$7
)
)
;
Inc
(
I
,
5
)
;
end
else
Dec
(
Size
,
5
)
;
Inc
(
S
)
;
end
;
SetLength
(
Result
,
Size
div
8
)
;
end
;
class
function
TFormat_MIME32
.
CharTable
:
PChar
;
asm
MOV EAX
,
OFFSET
@@
1
RET
// must be >= 32 Chars
@@
1
:
DB
'abcdefghijklnpqrstuwxyz123456789'
DB
' =$()[]{},;:-_\*"'
''
,
9
,
10
,
13
,
0
// special and skipped chars
end
;
class
function
TFormat_MIME64
.
DoEncode
(
const
Value
;
Size
:
Integer
)
:
Binary
;
var
B
:
Cardinal
;
I
:
Integer
;
D
,
T
:
PChar
;
S
:
PByteArray
;
begin
Result
:
=
''
;
if
Size <
=
0
then
Exit
;
SetLength
(
Result
,
Size
*
4
div
3
+
4
)
;
D
:
=
PChar
(
Result
)
;
T
:
=
CharTable
;
S
:
=
PByteArray
(
@
Value
)
;
while
Size >
=
3
do
begin
Dec
(
Size
,
3
)
;
B
:
=
S
[
0
]
shl
16
or
S
[
1
]
shl
8
or
S
[
2
]
;
D
[
0
]
:
=
T
[
B
shr
18
and
$3F
]
;
D
[
1
]
:
=
T
[
B
shr
12
and
$3F
]
;
D
[
2
]
:
=
T
[
B
shr
6
and
$3F
]
;
D
[
3
]
:
=
T
[
B
and
$3F
]
;
Inc
(
D
,
4
)
;
S
:
=
@
S
[
3
]
;
end
;
while
Size >
0
do
begin
B
:
=
0
;
for
I
:
=
0
to
2
do
begin
B
:
=
B
shl
8
;
if
Size >
0
then
begin
B
:
=
B
or
S
[
0
]
;
S
:
=
@
S
[
1
]
;
end
;
Dec
(
Size
)
;
end
;
for
I
:
=
3
downto
0
do
begin
if
Size <
0
then
begin
D
[
I
]
:
=
T
[
64
]
;
Inc
(
Size
)
;
end
else
D
[
I
]
:
=
T
[
B
and
$3F
]
;
B
:
=
B
shr
6
;
end
;
Inc
(
D
,
4
)
;
end
;
SetLength
(
Result
,
D
-
PChar
(
Result
)
)
;
end
;
class
function
TFormat_MIME64
.
DoDecode
(
const
Value
;
Size
:
Integer
)
:
Binary
;
var
B
:
Cardinal
;
J
,
I
:
Integer
;
S
,
D
,
L
,
T
:
PChar
;
begin
Result
:
=
''
;
if
Size <
=
0
then
Exit
;
SetLength
(
Result
,
Size
)
;
Move
(
Value
,
PChar
(
Result
)
^
,
Size
)
;
T
:
=
CharTable
;
D
:
=
PChar
(
Result
)
;
S
:
=
D
;
L
:
=
S
+
Size
;
J
:
=
0
;
while
S < L
do
begin
B
:
=
0
;
J
:
=
4
;
while
(
J >
0
)
and
(
S < L
)
do
begin
I
:
=
TableFind
(
S
^
,
T
,
65
)
;
Inc
(
S
)
;
if
I >
=
0
then
if
I <
64
then
begin
B
:
=
B
shl
6
or
Byte
(
I
)
;
Dec
(
J
)
;
end
else
L
:
=
S
;
end
;
if
J >
0
then
if
J >
=
4
then
begin
J
:
=
0
;
Break
;
end
else
B
:
=
B
shl
(
6
*
J
)
;
I
:
=
2
;
while
I >
=
0
do
begin
D
[
I
]
:
=
Char
(
B
)
;
B
:
=
B
shr
8
;
Dec
(
I
)
;
end
;
Inc
(
D
,
3
)
;
end
;
SetLength
(
Result
,
D
-
PChar
(
Result
)
-
J
)
;
end
;
class
function
TFormat_MIME64
.
CharTable
:
PChar
;
assembler
;
asm
MOV EAX
,
OFFSET
@@
1
RET
// must be >= 65 Chars
@@
1
:
DB
'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/='
DB
' $()[]{},;:-_\*"'
''
,
9
,
10
,
13
,
0
// special and skipped chars
end
;
class
function
TFormat_PGP
.
DoExtractCRC
(
const
Value
;
var
Size
:
Integer
)
:
LongWord
;
var
L
:
PChar
;
C
:
Char
;
R
:
String
;
begin
Result
:
=
$FFFFFFFF
;
C
:
=
CharTable
[
64
]
;
// get padding char, per default '='
L
:
=
PChar
(
@
Value
)
+
Size
;
while
L <>
PChar
(
@
Value
)
do
if
L
^
=
C
then
Break
else
Dec
(
L
)
;
// scan reverse for padding char
if
L
-
PChar
(
@
Value
)
>
=
Size
-
5
then
// remaining chars must be > 4 ,i.e. '=XQRT'
try
Inc
(
L
)
;
R
:
=
inherited
DoDecode
(
L
^
,
Size
-
(
L
-
PChar
(
@
Value
)
)
)
;
if
Length
(
R
)
>
=
3
then
begin
Result
:
=
0
;
Move
(
PChar
(
R
)
^
,
Result
,
3
)
;
Size
:
=
L
-
PChar
(
@
Value
)
;
end
;
except
end
;
end
;
class
function
TFormat_PGP
.
DoEncode
(
const
Value
;
Size
:
Integer
)
:
Binary
;
var
CRC
:
LongWord
;
begin
Result
:
=
''
;
if
Size <
=
0
then
Exit
;
Result
:
=
InsertCR
(
inherited
DoEncode
(
Value
,
Size
)
,
PGPCharsPerLine
)
;
// 80 chars per line
CRC
:
=
CRCCalc
(
CRC_24
,
Value
,
Size
)
;
// calculate 24Bit Checksum
SwapBytes
(
CRC
,
3
)
;
// PGP use Big Endian
if
Result
[
Length
(
Result
)
]
<>
#10
then
Result
:
=
Result
+
#13
#10
;
// insert CR iff needed, CRC must be in next line
Result
:
=
Result
+
'='
+
inherited
DoEncode
(
CRC
,
3
)
;
// append CRC
end
;
class
function
TFormat_PGP
.
DoDecode
(
const
Value
;
Size
:
Integer
)
:
Binary
;
var
CRC
:
LongWord
;
begin
Result
:
=
''
;
if
Size <
=
0
then
Exit
;
CRC
:
=
DoExtractCRC
(
Value
,
Size
)
;
Result
:
=
inherited
DoDecode
(
Value
,
Size
)
;
if
CRC <>
$FFFFFFFF
then
// iff CRC found check it
begin
SwapBytes
(
CRC
,
3
)
;
if
CRC <> CRCCalc
(
CRC_24
,
PChar
(
Result
)
^
,
Length
(
Result
)
)
then
raise
EDECException
.
CreateFmt
(
sInvalidStringFormat
,
[
DECClassname
(
Self
)
]
)
;
end
;
end
;
class
function
TFormat_UU
.
DoEncode
(
const
Value
;
Size
:
Integer
)
:
Binary
;
var
S
,
T
,
D
:
PChar
;
L
,
I
:
Integer
;
B
:
Cardinal
;
begin
Result
:
=
''
;
if
Size <
=
0
then
Exit
;
SetLength
(
Result
,
Size
*
4
div
3
+
Size
div
45
+
10
)
;
D
:
=
PChar
(
Result
)
;
T
:
=
CharTable
;
S
:
=
PChar
(
@
Value
)
;
while
Size >
0
do
begin
L
:
=
Size
;
if
L >
45
then
L
:
=
45
;
Dec
(
Size
,
L
)
;
D
^
:
=
T
[
L
]
;
while
L >
0
do
begin
B
:
=
0
;
for
I
:
=
0
to
2
do
begin
B
:
=
B
shl
8
;
if
L >
0
then
begin
B
:
=
B
or
Byte
(
S
^
)
;
Inc
(
S
)
;
end
;
Dec
(
L
)
;
end
;
for
I
:
=
4
downto
1
do
begin
D
[
I
]
:
=
T
[
B
and
$3F
]
;
B
:
=
B
shr
6
;
end
;
Inc
(
D
,
4
)
;
end
;
Inc
(
D
)
;
end
;
SetLength
(
Result
,
D
-
PChar
(
Result
)
)
;
end
;
class
function
TFormat_UU
.
DoDecode
(
const
Value
;
Size
:
Integer
)
:
Binary
;
var
T
,
D
,
L
,
S
:
PChar
;
I
,
E
:
Integer
;
B
:
Cardinal
;
begin
Result
:
=
''
;
if
Size <
=
0
then
Exit
;
SetLength
(
Result
,
Size
)
;
S
:
=
PChar
(
@
Value
)
;
L
:
=
S
+
Size
;
D
:
=
PChar
(
Result
)
;
T
:
=
CharTable
;
repeat
Size
:
=
TableFind
(
S
^
,
T
,
64
)
;
if
(
Size <
0
)
or
(
Size >
45
)
then
raise
EDECException
.
CreateFmt
(
sInvalidStringFormat
,
[
DECClassName
(
Self
)
]
)
;
Inc
(
S
)
;
while
Size >
0
do
begin
B
:
=
0
;
I
:
=
4
;
while
(
I >
0
)
and
(
S <
=
L
)
do
begin
E
:
=
TableFind
(
S
^
,
T
,
64
)
;
if
E >
=
0
then
begin
B
:
=
B
shl
6
or
Byte
(
E
)
;
Dec
(
I
)
;
end
;
Inc
(
S
)
;
end
;
I
:
=
2
;
repeat
D
[
I
]
:
=
Char
(
B
)
;
B
:
=
B
shr
8
;
Dec
(
I
)
;
until
I <
0
;
if
Size >
3
then
Inc
(
D
,
3
)
else
Inc
(
D
,
Size
)
;
Dec
(
Size
,
3
)
;
end
;
until
S >
=
L
;
SetLength
(
Result
,
D
-
PChar
(
Result
)
)
;
end
;
class
function
TFormat_UU
.
DoIsValid
(
const
Value
;
Size
:
Integer
)
:
Boolean
;
var
S
,
T
:
PChar
;
L
,
I
,
P
:
Integer
;
begin
Result
:
=
False
;
T
:
=
CharTable
;
L
:
=
StrLen
(
T
)
;
S
:
=
PChar
(
@
Value
)
;
P
:
=
0
;
while
Size >
0
do
begin
I
:
=
TableFind
(
S
^
,
T
,
L
)
;
if
I >
=
0
then
begin
Dec
(
Size
)
;
Inc
(
S
)
;
if
P
=
0
then
begin
if
I >
45
then
Exit
;
P
:
=
(
I
*
4
+
2
)
div
3
;
end
else
if
I <
64
then
Dec
(
P
)
;
end
else
Exit
;
end
;
if
P <>
0
then
Exit
;
Result
:
=
True
;
end
;
class
function
TFormat_UU
.
CharTable
:
PChar
;
asm
MOV EAX
,
OFFSET
@@
1
RET
// must be >= 64 Chars
@@
1
:
DB
'`!"#$%&'
'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_'
DB
' '
,
9
,
10
,
13
,
0
end
;
class
function
TFormat_XX
.
CharTable
:
PChar
;
asm
MOV EAX
,
OFFSET
@@
1
RET
@@
1
:
DB
'+-0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz'
DB
' "()[]'
''
,
9
,
10
,
13
,
0
end
;
const
ESCAPE_CodesL
:
PChar
=
'abtnvfr'
;
ESCAPE_CodesU
:
PChar
=
'ABTNVFR'
;
class
function
TFormat_ESCAPE
.
DoDecode
(
const
Value
;
Size
:
Integer
)
:
Binary
;
var
D
,
S
,
T
:
PChar
;
I
:
Integer
;
begin
Result
:
=
''
;
if
Size <
=
0
then
Exit
;
SetLength
(
Result
,
Size
)
;
D
:
=
PChar
(
Result
)
;
S
:
=
PChar
(
@
Value
)
;
T
:
=
S
+
Size
;
while
S < T
do
begin
if
S
^
=
'\'
then
begin
Inc
(
S
)
;
if
S > T
then
Break
;
if
UpCase
(
S
^
)
=
'X'
then
begin
if
S
+
2
> T
then
raise
EDECException
.
CreateFmt
(
sInvalidStringFormat
,
[
DECClassName
(
Self
)
]
)
;
I
:
=
TableFind
(
UpCase
(
S
[
1
]
)
,
TFormat_HEX
.
CharTable
,
16
)
;
if
I <
0
then
raise
EDECException
.
CreateFmt
(
sInvalidStringFormat
,
[
DECClassName
(
Self
)
]
)
;
D
^
:
=
Char
(
I
shl
4
)
;
I
:
=
TableFind
(
UpCase
(
S
[
2
]
)
,
TFormat_HEX
.
CharTable
,
16
)
;
if
I <
0
then
raise
EDECException
.
CreateFmt
(
sInvalidStringFormat
,
[
DECClassName
(
Self
)
]
)
;
D
^
:
=
Char
(
Byte
(
D
^
)
or
I
)
;
Inc
(
S
,
2
)
;
end
else
begin
I
:
=
TableFind
(
UpCase
(
S
^
)
,
ESCAPE_CodesU
,
7
)
;
if
I >
=
0
then
D
^
:
=
Char
(
I
+
7
)
else
D
^
:
=
S
^
;
end
;
end
else
D
^
:
=
S
^
;
Inc
(
D
)
;
Inc
(
S
)
;
end
;
SetLength
(
Result
,
D
-
PChar
(
Result
)
)
;
end
;
class
function
TFormat_ESCAPE
.
DoEncode
(
const
Value
;
Size
:
Integer
)
:
Binary
;
var
S
:
PByte
;
D
,
T
:
PChar
;
I
:
Integer
;
begin
Result
:
=
''
;
if
Size
=
0
then
Exit
;
SetLength
(
Result
,
Size
+
8
)
;
I
:
=
Size
;
D
:
=
PChar
(
Result
)
;
S
:
=
PByte
(
@
Value
)
;
T
:
=
TFormat_HEX
.
CharTable
;
while
Size >
0
do
begin
if
I <
=
0
then
begin
I
:
=
D
-
PChar
(
Result
)
;
SetLength
(
Result
,
I
+
Size
+
8
)
;
D
:
=
PChar
(
Result
)
+
I
;
I
:
=
Size
;
end
;
if
(
S
^
<
32
)
{or (S^ > $7F)}
then
if
(
S
^
>
=
7
)
and
(
S
^
<
=
13
)
then
begin
D
[
0
]
:
=
'\'
;
D
[
1
]
:
=
ESCAPE_CodesL
[
S
^
-
7
]
;
Inc
(
D
,
2
)
;
Dec
(
I
,
2
)
;
end
else
begin
D
[
0
]
:
=
'\'
;
D
[
1
]
:
=
'x'
;
D
[
2
]
:
=
T
[
S
^
shr
4
]
;
D
[
3
]
:
=
T
[
S
^
and
$F
]
;
Inc
(
D
,
4
)
;
Dec
(
I
,
4
)
;
end
else
if
S
^
=
Ord
(
'\'
)
then
begin
D
[
0
]
:
=
'\'
;
D
[
1
]
:
=
'\'
;
Inc
(
D
,
2
)
;
Dec
(
I
,
2
)
;
end
else
if
S
^
=
Ord
(
'"'
)
then
begin
D
[
0
]
:
=
'\'
;
D
[
1
]
:
=
'"'
;
Inc
(
D
,
2
)
;
Dec
(
I
,
2
)
;
end
else
begin
D
^
:
=
Char
(
S
^
)
;
Inc
(
D
)
;
Dec
(
I
)
;
end
;
Dec
(
Size
)
;
Inc
(
S
)
;
end
;
SetLength
(
Result
,
D
-
PChar
(
Result
)
)
;
end
;
function
InsertCR
(
const
Value
:
String
;
BlockSize
:
Integer
)
:
String
;
var
I
:
Integer
;
S
,
D
:
PChar
;
begin
if
(
BlockSize <
=
0
)
or
(
Length
(
Value
)
<
=
BlockSize
)
then
begin
Result
:
=
Value
;
Exit
;
end
;
I
:
=
Length
(
Value
)
;
SetLength
(
Result
,
I
+
I
*
2
div
BlockSize
+
2
)
;
S
:
=
PChar
(
Value
)
;
D
:
=
PChar
(
Result
)
;
repeat
Move
(
S
^
,
D
^
,
BlockSize
)
;
Inc
(
S
,
BlockSize
)
;
Inc
(
D
,
BlockSize
)
;
D
^
:
=
#13
;
Inc
(
D
)
;
D
^
:
=
#10
;
Inc
(
D
)
;
Dec
(
I
,
BlockSize
)
;
until
I < BlockSize
;
Move
(
S
^
,
D
^
,
I
)
;
Inc
(
D
,
I
)
;
SetLength
(
Result
,
D
-
PChar
(
Result
)
)
;
end
;
function
DeleteCR
(
const
Value
:
String
)
:
String
;
var
S
,
D
:
PChar
;
I
:
Integer
;
begin
I
:
=
Length
(
Value
)
;
SetLength
(
Result
,
I
)
;
D
:
=
PChar
(
Result
)
;
S
:
=
PChar
(
Value
)
;
while
I >
0
do
begin
if
(
S
^
<>
#10
)
and
(
S
^
<>
#13
)
then
begin
D
^
:
=
S
^
;
Inc
(
D
)
;
end
;
Inc
(
S
)
;
Dec
(
I
)
;
end
;
SetLength
(
Result
,
D
-
PChar
(
Result
)
)
;
end
;
function
InsertBlocks
(
const
Value
,
BlockStart
,
BlockEnd
:
String
;
BlockSize
:
Integer
)
:
String
;
var
I
,
LS
,
LE
:
Integer
;
D
,
S
:
PChar
;
begin
if
(
BlockSize <
=
0
)
or
(
Length
(
Value
)
<
=
BlockSize
)
then
begin
Result
:
=
Value
;
Exit
;
end
;
I
:
=
Length
(
Value
)
;
LS
:
=
Length
(
BlockStart
)
;
LE
:
=
Length
(
BlockEnd
)
;
SetLength
(
Result
,
I
+
(
I
div
BlockSize
+
1
)
*
(
LS
+
LE
)
)
;
S
:
=
PChar
(
Value
)
;
D
:
=
PChar
(
Result
)
;
repeat
Move
(
PChar
(
BlockStart
)
^
,
D
^
,
LS
)
;
Inc
(
D
,
LS
)
;
Move
(
S
^
,
D
^
,
BlockSize
)
;
Inc
(
D
,
BlockSize
)
;
Move
(
PChar
(
BlockEnd
)
^
,
D
^
,
LE
)
;
Inc
(
D
,
LE
)
;
Dec
(
I
,
BlockSize
)
;
Inc
(
S
,
BlockSize
)
;
until
I < BlockSize
;
if
I >
0
then
begin
Move
(
PChar
(
BlockStart
)
^
,
D
^
,
LS
)
;
Inc
(
D
,
LS
)
;
Move
(
S
^
,
D
^
,
I
)
;
Inc
(
D
,
I
)
;
Move
(
PChar
(
BlockEnd
)
^
,
D
^
,
LE
)
;
Inc
(
D
,
LE
)
;
end
;
SetLength
(
Result
,
D
-
PChar
(
Result
)
)
;
end
;
function
RemoveBlocks
(
const
Value
,
BlockStart
,
BlockEnd
:
String
)
:
String
;
var
LS
,
LE
:
Integer
;
S
,
D
,
L
,
K
:
PChar
;
begin
SetLength
(
Result
,
Length
(
Value
)
)
;
LS
:
=
Length
(
BlockStart
)
;
LE
:
=
Length
(
BlockEnd
)
;
D
:
=
PChar
(
Result
)
;
S
:
=
PChar
(
Value
)
;
L
:
=
S
+
Length
(
Value
)
;
repeat
if
S > L
then
Break
;
if
LS >
0
then
begin
S
:
=
StrPos
(
S
,
PChar
(
BlockStart
)
)
;
if
S
=
nil
then
Break
;
Inc
(
S
,
LS
)
;
if
S > L
then
Break
;
end
;
K
:
=
StrPos
(
S
,
PChar
(
BlockEnd
)
)
;
if
K
=
nil
then
K
:
=
L
;
Move
(
S
^
,
D
^
,
K
-
S
)
;
Inc
(
D
,
K
-
S
)
;
S
:
=
K
+
LE
;
until
S >
=
L
;
SetLength
(
Result
,
D
-
PChar
(
Result
)
)
;
end
;
end
.