' Simplexity Cypher example program as a Windows (DOS) executable program. ' See www.SimplexityCypher.com for more information. ' ' WARNING!!! This program ***ONLY*** works with programming languages with at least 64-bit integers!!! (like QB64) ' ' This implementation will FAIL with 32-bit integer programming languages!!! ' (see M$ Visual Basic 6 version for 32-bit programming language conversion) ' ' Copyright (c) 2005-2014 by William H. Donnelly; All Rights Reserved ' ' Simplexity Cypher (Beelzebub variation) ' Simplexity:Beelzebub ' Simplexity:Key=ASCII: A-Z;Oper=ACSNXLWR;OpTyp=HLNBUWLS;KeyDir=F;DatDir=F;OperSeed=13;OpTypSeed=437;DataOffSeed=35976;DataOff=27; ' This program is made specifically to only work in QB64. ' This program is made specifically to only work in QB64. _TITLE "Simplexity Cypher - Beelzebub variation" ON ERROR GOTO LBL_ErrorHandler ' hopefully the only "GOTO" (and Label) used here (eventually) DEFINT A-Z ' overall function and variable specification _DEFINE U AS _UNSIGNED INTEGER ' function name prefixing specification for Unsigned Integer DEFSTR S ' function name prefixing specification for String SCREEN 0 ' text screen WIDTH 100, 40 ' 100 columns, 40 lines IF _FILEEXISTS ("c:\windows\fonts\lucon.ttf") THEN fH& = _LOADFONT ("c:\windows\fonts\lucon.ttf", 21, "MONOSPACE") _FONT fH& ELSE IF _FILEEXISTS ("lucon.ttf") THEN fH& = _LOADFONT ("lucon.ttf", 21, "MONOSPACE") _FONT fH& END IF END IF IF INSTR (_OS$, "[WINDOWS]") THEN _ _SCREENMOVE _MIDDLE ' center the window on the desktop DIM SHARED gnERR AS INTEGER ' error # from ON ERROR, internal ERR value CONST FALSE = 0, TRUE = NOT FALSE ' every program should have this line (and the character constants below-following) DIM SHARED C_DBLQ AS STRING * 1 ' constant Double Quote DIM SHARED C_CR AS STRING * 1 ' constant Carriage Return (ENTER) DIM SHARED C_LF AS STRING * 1 ' constant Line Feed DIM SHARED C_BS AS STRING * 1 ' constant Backspace DIM SHARED C_FF AS STRING * 1 ' constant Form Feed DIM SHARED C_TAB AS STRING * 1 ' constant Tab DIM SHARED C_ESC AS STRING * 1 ' constant ESCape DIM SHARED C_EOL AS STRING * 1 ' constant End of Line (CR) DIM SHARED C_SPC AS STRING * 1 ' constant SPACE DIM SHARED C_CUR_UP AS STRING * 1 ' constant Cursor Up character string code DIM SHARED C_CUR_DN AS STRING * 1 ' constant Cursor Down character string code DIM SHARED C_CUR_LFT AS STRING * 1 ' constant Cursor Left character string code DIM SHARED C_CUR_RGT AS STRING * 1 ' constant Cursor Right character string code C_DBLQ = CHR$ (34) ' constant Double Quote C_CR = CHR$ (13) ' constant Carriage Return (ENTER) C_LF = CHR$ (10) ' constant Line Feed C_BS = CHR$ (8) ' constant Backspace C_FF = CHR$ (12) ' constant Form Feed C_TAB = CHR$ (9) ' constant Tab C_ESC = CHR$ (27) ' constant ESCape C_EOL = C_CR ' constant End of Line (CR) C_SPC = " " ' constant SPACE C_CUR_UP = CHR$ (30) ' constant Cursor Up character string code C_CUR_DN = CHR$ (31) ' constant Cursor Down character string code C_CUR_LFT = CHR$ (29) ' constant Cursor Left character string code C_CUR_RGT = CHR$ (28) ' constant Cursor Right character string code RANDOMIZE TIMER CONST KEYHIT_F1 = 15104 CONST KEYHIT_F2 = 15360 CONST KEYHIT_F3 = 15616 CONST KEYHIT_F4 = 15872 CONST KEYHIT_F5 = 16128 CONST KEYHIT_F6 = 16384 CONST KEYHIT_F7 = 16640 CONST KEYHIT_F8 = 16896 CONST KEY_RSHIFT = 100303 CONST KEY_LSHIFT = 100304 CONST KEY_RCTRL = 100305 CONST KEY_LCTRL = 100306 CONST KEY_RALT = 100307 CONST KEY_LALT = 100308 CONST SUPER_ENTRY_NOOPT = 0 ' no options selected (powers of 2 that can be OR'ed or added together) CONST SUPER_ENTRY_UCASE = 1 ' convert all input alpha to uppercase CONST SUPER_ENTRY_SHADO = 2 ' treat default value like shadow text (darker text that disappears when you type) CONST SUPER_ENTRY_PASWD = 4 ' password entry mode = show entry chars as asterisks ("*") CONST SUPER_ENTRY_MAXCE = 8 ' auto-return when maximum number of characters entered ("full field entry") ' to be included as a reusable routine for superInkey$ function ' NOTE: take care with "" versus " " -- fixed-length string issue -- see bNull and bKeyPress TYPE typeSuperInkey sChar AS STRING * 1 ' simple ASCII character values, or blank (" " -- see bNull) sCharExt AS STRING * 2 ' extended 2-character code, or blank (" ") sExt AS STRING * 10 ' descriptive value of extended keys (F10, Alt+F1, etc.) sName AS STRING * 20 ' descriptive 'Name' of key sPrintable AS STRING * 1 ' Printable character (non-Control), or blank (" ") nASC AS INTEGER ' ASCII value of key character (simple ASCII), or zero nExtASC AS INTEGER ' ASCII value of second character of extended key code, or zero for 'simple ASCII' bKeyPress AS INTEGER ' FALSE = no keypress, TRUE = keypress bNull AS INTEGER ' sChar is "" (not " " -- fixed-length string issue) bCtrl AS INTEGER ' Control key was used to generate keypress bAlt AS INTEGER ' Alt key was used to generate keypress bShift AS INTEGER ' Shift key was used to generate keypress bFunc AS INTEGER ' Function key was pressed (all modified variations) bArrow AS INTEGER ' 'arrow' key was pressed bCursor AS INTEGER ' 'cursor' key was pressed (arrow keys, Home, PageUp, etc.) bKeyPad AS INTEGER ' keypad key was pressed END TYPE ' typeSuperInkey DIM SHARED gtSuperInkey AS typeSuperInkey CONST CS_META_OPERATOR = 0 CONST CS_META_OPERAND_SELECTOR = 1 CONST CS_META_OPERAND_VALUE = 2 CONST CS_META_DATASET_OFFSET = 3 CONST CS_META_PROC_DIR = 4 CONST CS_META_PROC_DIR_FORW = 1 CONST CS_META_PROC_DIR_BACK = -1 CONST CS_OPER_ADD = 0 CONST CS_OPER_COMPLEMENT = 1 CONST CS_OPER_SUBTRACT = 2 CONST CS_OPER_NEGATE = 3 CONST CS_OPER_XOR = 4 CONST CS_OPER_ROTATE_LEFT = 5 CONST CS_OPER_SWAP = 6 CONST CS_OPER_ROTATE_RIGHT = 7 CONST CS_OPSEL_UNSIGNED_NYBBLE_HI = 0 CONST CS_OPSEL_UNSIGNED_NYBBLE_LO = 1 CONST CS_OPSEL_BOTH_UNYBBLES = 2 CONST CS_OPSEL_UNSIGNED_BYTE = 3 CONST CS_OPSEL_UNSIGNED_WORD = 4 CONST CS_OPSEL_SIGNED_WORD = 5 CONST CS_OPSEL_UNSIGNED_LONG = 6 CONST CS_OPSEL_SIGNED_LONG = 7 CONST CS_2_POW_2 = &H04~&& ' 1000 CONST CS_2_POW_2_MIN_1 = &H03~&& ' 0111 CONST CS_2_POW_4 = &H10~&& ' 0001 0000 CONST CS_2_POW_4_MIN_1 = &H0f~&& ' 0000 1111 CONST CS_2_POW_8 = &H100~&& ' 0001 0000 0000 CONST CS_2_POW_8_MIN_1 = &Hff~&& ' 1111 1111 CONST CS_2_POW_15 = &H8000~&& ' 1000 0000 0000 0000 CONST CS_2_POW_15_MIN_1 = &H7fff~&& ' 0111 1111 1111 1111 CONST CS_2_POW_16 = &H10000~&& ' 0001 0000 0000 0000 0000 CONST CS_2_POW_16_MIN_1 = &Hffff~&& ' 1111 1111 1111 1111 CONST CS_2_POW_24 = &H1000000~&& ' 0001 0000 0000 0000 0000 0000 0000 CONST CS_2_POW_31 = &H80000000~&& ' 1000 0000 0000 0000 0000 0000 0000 0000 CONST CS_2_POW_31_MIN_1 = &H7fffffff~&& ' 0111 1111 1111 1111 1111 1111 1111 1111 CONST CS_2_POW_32 = &H100000000~&& ' 0001 0000 0000 0000 0000 0000 0000 0000 0000 CONST CS_2_POW_32_MIN_1 = &Hffffffff~&& ' 1111 1111 1111 1111 1111 1111 1111 1111 CONST CS_MASK_DIT_HI = &H0c~&& ' 1100 CONST CS_MASK_DIT_LO = &H03~&& ' 0011 CONST CS_MASK_NYBBLE_HI = &Hf0~&& ' 1111 0000 CONST CS_MASK_NYBBLE_LO = &H0f~&& ' 0000 1111 CONST CS_MASK_BYTE_HI = &Hff00~&& ' 1111 1111 0000 0000 CONST CS_MASK_BYTE_LO = &Hff~&& ' 0000 0000 1111 1111 CONST CS_MASK_WORD_HI = &Hffff0000~&& ' 1111 1111 1111 1111 0000 0000 0000 0000 CONST CS_MASK_WORD_LO = &Hffff ' 0000 0000 0000 0000 1111 1111 1111 1111 CONST CS_MASK_BYTE1 = &Hff000000~&& ' 1111 1111 0000 0000 0000 0000 0000 0000 CONST CS_MASK_BYTE2 = &Hff0000~&& ' 0000 0000 1111 1111 0000 0000 0000 0000 CONST CS_MASK_BYTE3 = &Hff00~&& ' 0000 0000 0000 0000 1111 1111 0000 0000 CONST CS_MASK_BYTE4 = &Hff~&& ' 0000 0000 0000 0000 0000 0000 1111 1111 CONST CS_MASK_BYTE = &Hff~&& ' 1111 1111 CONST CS_MASK_WORD = &Hffff~&& ' 1111 1111 1111 1111 CONST CS_MASK_LONG = &Hffffffff~&& ' 1111 1111 1111 1111 1111 1111 1111 1111 CONST CS_MASK_BITSHIFT_NYBBLE = &H03~&& ' 3 CONST CS_MASK_BITSHIFT_BYTE = &H07~&& ' 7 CONST CS_MASK_BITSHIFT_WORD = &H0f~&& ' 15 CONST CS_MASK_BITSHIFT_LONG = &H1f~&& ' 31 DIM SHARED ganBitsToShiftMultDiv (0 TO 31) AS _UNSIGNED LONG ' Bits to Shift Multiplier / Divider DIM nPow2 AS INTEGER DIM nPow2Value AS _UNSIGNED LONG nPow2 = 1 nPow2Value = 1 FOR nPow2 = 0 TO 31 ganBitsToShiftMultDiv (nPow2) = nPow2Value nPow2Value = nPow2Value * 2 NEXT CONST CS_OPERATOR_SEED = 13 ' arbitrarily chosen initial seed; hardcoded for this implementation (Byte) CONST CS_OPERAND_SEED = 437 ' arbitrarily chosen initial seed; hardcoded for this implementation (Byte) CONST CS_DATASET_OFFSET_SEED = 35976 ' arbitrarily chosen initial seed; hardcoded for this implementation (Unsigned Long) CONST CS_DATASET_OFFSET = 27 ' arbitrarily chosen initial dataset offset; hardcoded for this implementation (Unsigned Long) CONST CS_KEY_CHARS = " ABCDEFGHIJKLMNOPQRSTUVWXYZ" DIM SHARED gasOperators (0 TO 7) AS STRING DIM SHARED gasOperands (0 TO 7) AS STRING gasOperators (0) = "ADD" gasOperators (1) = "COMPLEMENT" gasOperators (2) = "SUBTRACT" gasOperators (3) = "NEGATE" gasOperators (4) = "XOR" gasOperators (5) = "ROTATE LEFT" gasOperators (6) = "SWAP" gasOperators (7) = "ROTATE RIGHT" gasOperands (0) = "NYBBLE HI" gasOperands (1) = "NYBBLE LO" gasOperands (2) = "BOTH UNYBBLES" gasOperands (3) = "BYTE" gasOperands (4) = "UNSIGNED WORD" gasOperands (5) = "SIGNED WORD" gasOperands (6) = "UNSIGNED LONG" gasOperands (7) = "SIGNED LONG" DIM SHARED gsMessage AS STRING DIM SHARED gsError AS STRING DIM SHARED gbDebug AS INTEGER DIM gnStartTime AS DOUBLE DIM gnEndTime AS DOUBLE DIM gnTime AS DOUBLE DIM gsLastCypherKey AS STRING DIM gsLastFilename AS STRING DIM gsCypherKey AS STRING DIM gsFilename AS STRING DIM gsCryption AS STRING DIM gsDelimiter AS STRING DIM gbDone AS INTEGER DIM gsOutput AS STRING DIM gsLastOutput AS STRING DIM gsSuggest AS STRING DIM gsYN AS STRING DIM gsCrypting AS STRING DIM gsCrypted AS STRING DIM gbResult AS INTEGER DIM gnFound AS INTEGER DIM gsExtension AS STRING DIM gsTemp AS STRING gbDebug = FALSE 'gbDebug = TRUE CLS COLOR 7 ' default color LOCATE , , 1 ' show cursor for inkey$ (only (need to) do once?) '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' IF gbDebug THEN ' clear debug output file OPEN "simplexitycypherexample.debug" FOR OUTPUT AS #9 CLOSE #9 END IF LBL_Main: COLOR 15 ' bright white PRINT "Simplexity Cypher "; COLOR 12 ' bright red PRINT "(Beelzebub variation)" PRINT COLOR 14 ' bright yellow PRINT "Proof of Concept Example Implementation" COLOR 7 ' default color PRINT PRINT "This program is a functional equivalent of the PHP example program located" PRINT "on the "; COLOR 15 ' bright white PRINT "www.SimplexityCypher.com"; COLOR 7 ' default color PRINT " website. See the website for more info." PRINT PRINT "This program is written in QB64 compiled BASIC, found at www.QB64.net." PRINT "The GUI is a simple Windows DOS-based textual interface." PRINT "Although the program could be made to run on Apple OS and *Nix, only Win is available." PRINT "The source file is available on the Simplexity website." PRINT "For a larger font and screen size, the true type font file c:\windows\fonts\lucon.ttf" PRINT "must be available, or install lucon.ttf in the executable directory." PRINT PRINT "WARNING - This implementation of the cypher has NOT been thoroughly tested," PRINT "so you might encrypt something that is not encrypted correctly and/or" PRINT "may not be decryptable. Therefore it is STRONGLY recommended that you" PRINT "NOT use this program to encrypt or decrypt "; C_DBLQ ; "important"; C_DBLQ ; " information, and ONLY" PRINT "use this program for testing, playing, edification, and educational purposes." PRINT PRINT "Users are also strongly encouraged to read the 'Casual Treatise' document and" PRINT "other information located on the website to better understand Simplexity before use." PRINT "Please address all comments, questions, and issues to: Simplexity /@@@/ SimplexityCypher ... com" DO ' allow multiple cryptions IF gsMessage <> "" THEN gbDone = FALSE PRINT DO IF LEN (gsMessage) > 77 THEN gsTemp = LEFT$ (gsMessage, 78) gnFound = strrpos% (gsTemp, " ", 0) gsTemp = LEFT$ (gsTemp, gnFound - 1) gsMessage = LTRIM$ (MID$ (gsMessage, gnFound)) ELSE gsTemp = gsMessage gsMessage = "" END IF IF gbDone THEN _ PRINT " "; PRINT gsTemp gbDone = TRUE LOOP WHILE gsMessage <> "" END IF IF gsError <> "" THEN gbDone = FALSE COLOR 12 ' bright red PRINT DO IF LEN (gsError) > 77 THEN gsTemp = LEFT$ (gsError, 78) gnFound = strrpos% (gsTemp, " ", 0) gsTemp = LEFT$ (gsTemp, gnFound - 1) gsError = LTRIM$ (MID$ (gsError, gnFound)) ELSE gsTemp = gsError gsError = "" END IF IF gbDone THEN _ PRINT " "; PRINT gsTemp gbDone = TRUE LOOP WHILE gsMessage <> "" COLOR 7 ' default color END IF gsMessage = "" gsError = "" gsCryption = "" DO PRINT PRINT PRINT "Encrypt or Decrypt ("; COLOR 9 ' bright blue PRINT "E, D"; COLOR 7 ' default color PRINT " | "; COLOR 8 ' dark gray PRINT "ESC = Quit"; COLOR 7 ' default color PRINT "): "; gsDelimiter = C_CR + C_ESC COLOR 3 ' aqua gsCryption = LEFT$ (TRIM$ (superEntry$ ("", "", gsDelimiter, SUPER_ENTRY_UCASE, 0)), 1) COLOR 7 ' default color PRINT IF gsCryption <> "E" AND gsCryption <> "D" AND gsDelimiter <> C_ESC THEN _ beepAlert LOOP WHILE gsCryption <> "E" AND gsCryption <> "D" AND gsDelimiter <> C_ESC IF gsDelimiter = C_ESC THEN _ EXIT DO ' end program IF gsCryption = "E" THEN gsCrypting = "Encrypting" gsCrypted = "Encrypted" END IF IF gsCryption = "D" THEN gsCrypting = "Decrypting" gsCrypted = "Decrypted" END IF DO PRINT COLOR 6 ' brown PRINT " (non-blank, nominally 20 to 50 characters, SPACE and A-Z --" PRINT " all other characters will be ignored)" COLOR 7 ' default color PRINT "Cypher Key: "; gsDelimiter = C_CR + C_ESC COLOR 3 ' aqua gsCypherKey = superEntry$ ("", gsLastCypherKey, gsDelimiter, SUPER_ENTRY_UCASE, 0) COLOR 7 ' default color PRINT IF gsDelimiter <> C_ESC THEN _ gsLastCypherKey = gsCypherKey LOOP UNTIL gsCypherKey <> "" OR gsDelimiter = C_ESC gbDone = FALSE WHILE NOT (gbDone) AND gsDelimiter <> C_ESC PRINT COLOR 6 ' brown PRINT " (encrypted files default extension = '.simplexity' and decrypted files = '.decrypted'" COLOR 7 ' default color PRINT "Data file to encrypt or decrypt: "; gsDelimiter = C_CR + C_ESC COLOR 3 ' aqua gsFilename = superEntry$ ("", gsLastFilename, gsDelimiter, SUPER_ENTRY_NOOPT, 0) COLOR 7 ' default color PRINT IF gsDelimiter <> C_ESC THEN gsLastFilename = gsFilename IF _FILEEXISTS (gsFilename) THEN gbDone = TRUE ELSE IF gsCryption = "D" AND _FILEEXISTS (gsFilename + ".simplexity") THEN gsFilename = gsFilename + ".simplexity" gsLastFilename = gsFilename gbDone = TRUE ELSE IF _FILEEXISTS (gsFilename + ".decrypted") THEN gsFilename = gsFilename + ".decrypted" gsLastFilename = gsFilename gbDone = TRUE ELSE PRINT "File does not exist: " + gsFilename END IF END IF END IF END IF WEND IF gsDelimiter <> C_ESC THEN gnFound = strrpos% (gsFilename, ".", 0) IF gnFound = 0 THEN _ gnFound = LEN (gsFilename) + 1 gsExtension = MID$ (gsFilename, gnFound) IF UCASE$ (gsExtension) = ".SIMPLEXITY" THEN gsSuggest = LEFT$ (gsFilename, gnFound - 1) + ".decrypted" ELSE gsSuggest = LEFT$ (gsFilename, gnFound - 1) + ".simplexity" END IF END IF gbDone = FALSE WHILE NOT (gbDone) AND gsDelimiter <> C_ESC PRINT PRINT "Output filename: "; gsDelimiter = C_CR + C_ESC COLOR 3 ' aqua gsOutput = superEntry$ (gsSuggest, gsLastOutput, gsDelimiter, SUPER_ENTRY_NOOPT, 0) COLOR 7 ' default color PRINT IF gsDelimiter <> C_ESC THEN gsLastOutput = gsOutput IF _FILEEXISTS (gsOutput) THEN PRINT PRINT "Output file exists, do you want to overwrite? "; gsDelimiter = C_CR + C_ESC COLOR 3 ' aqua gsYN = LEFT$ (TRIM$ (superEntry$ ("", "", gsDelimiter, SUPER_ENTRY_UCASE, 0)), 1) COLOR 7 ' default color PRINT IF gsDelimiter = C_ESC THEN _ gsYN = "N" IF gsYN = "Y" THEN _ gbDone = TRUE ELSE gnERR = 0 OPEN gsOutput FOR OUTPUT AS #1 IF gnERR = 0 THEN CLOSE #1 gbDone = TRUE ELSE PRINT PRINT errorText$ (gnErr, TRUE) sDelimiter = C_ESC END IF END IF END IF WEND IF gsDelimiter <> C_ESC THEN IF gbDebug THEN ' append to the debug output file OPEN "simplexitycypherexample.debug" FOR APPEND AS #9 PRINT #9, "" PRINT #9, gsCrypting; " file..." PRINT #9, DATE$; " "; TIME$; " ----------------------------------------" END IF PRINT PRINT gsCrypting; " file..."; gnStartTime = timer COLOR 12 ' bright red gbResult = processFile% (gsCryption, gsCypherKey, gsFilename, gsOutput) ' encrypt or decrypt the file COLOR 7 ' default color gnEndTime = timer IF gnEndTime < gnStartTime THEN _ gnEndTime = gnEndTime + 86400 ' correct for midnight crossover gnTime = gnEndTime - gnStartTime PRINT PRINT PRINT "File "; gsCrypted; "." PRINT "Processing time in seconds ="; gnTime PRINT IF gbDebug THEN PRINT #9, "" PRINT #9, "File "; gsCrypted; "." PRINT #9, "Processing time in seconds ="; gnTime CLOSE #9 END IF END IF LOOP WHILE TRUE END '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ' Error handler -- the end of the Main program proper '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' LBL_ErrorHandler: ' error handler routine (MUST be located here) gnERR = ERR ' save value, because Resume clears it, so remember to reset first when needed RESUME NEXT ' we will try to handle errors as they occur when needed '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ' SUBroutines and FUNCTIONs '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ' NOTE: one or more of the following routines requires the TRUE and FALSE constants to be defined. ' To be 'safe', always define these constants (at least, and others) at the top of every program with: ' CONST FALSE = 0, TRUE = NOT FALSE FUNCTION processFile% ( _ psCryption AS STRING, _ psCypherKey AS STRING, _ psFilename AS STRING, _ psOutput AS STRING _ ) REDIM aData (0 TO 1) AS _UNSIGNED _BYTE ' ReDIM below REDIM aOpsProcList (0 TO 1, 0 TO 4) AS _INTEGER64 ' ReDIM below DIM nDataLen AS LONG DIM nKeyLen AS INTEGER DIM bEncrypt AS INTEGER DIM bDecrypt AS INTEGER DIM nOperatorSeed AS INTEGER ' (byte) DIM nOperandSeed AS INTEGER ' (byte)) DIM nDatasetOffsetSeed AS LONG ' (unsigned word) DIM nDatasetOffset AS LONG ' (unsigned word) DIM sCypherKey AS STRING DIM nCypherKey AS INTEGER DIM sKey AS STRING DIM nOpsProcListCnt AS INTEGER DIM nOpValue AS _INTEGER64 DIM sDate AS STRING DIM sTime AS STRING DIM sTimer AS STRING DIM sOutFile AS STRING DIM nChar AS INTEGER DIM sChar AS STRING DIM nIdx AS INTEGER DIM nByte1 AS INTEGER DIM nByte2 AS INTEGER DIM nByte3 AS INTEGER DIM nByte4 AS INTEGER DIM nDataByte1 AS INTEGER DIM nDataByte2 AS INTEGER DIM nDataByte3 AS INTEGER DIM nDataByte4 AS INTEGER DIM nOPLIdx AS INTEGER DIM nOPLDir AS INTEGER DIM nKeyOperator AS INTEGER DIM nKeyOperand AS INTEGER DIM nDirection AS INTEGER DIM nKeyOperatorStart AS INTEGER DIM nDataIdx AS _INTEGER64 DIM nDataCnt AS LONG DIM nCryptOperand AS INTEGER DIM nCryptOperator AS INTEGER DIM nDataSize AS INTEGER DIM nBitShiftMask AS _INTEGER64 DIM nDataValueMask AS _INTEGER64 DIM nOperandValue AS _INTEGER64 DIM nOperandValueUns AS _INTEGER64 DIM nOperandData AS _INTEGER64 DIM nOperandDataUns AS _INTEGER64 DIM nOperandValue2 AS _INTEGER64 DIM nOperandValueUns2 AS _INTEGER64 DIM nOperandData2 AS _INTEGER64 DIM nOperandDataUns2 AS _INTEGER64 DIM nResult AS _INTEGER64 DIM nResult2 AS _INTEGER64 DIM nOpValueSeed AS INTEGER DIM nDataMask AS _INTEGER64 DIM nUpperValue AS _INTEGER64 DIM nLowerValue AS _INTEGER64 DIM nDitHi AS _INTEGER64 DIM nDitLo AS _INTEGER64 DIM nNybbleHi AS _INTEGER64 DIM nNybbleLo AS _INTEGER64 DIM nByteHi AS _INTEGER64 DIM nByteLo AS _INTEGER64 DIM nWordHi AS _INTEGER64 DIM nWordLo AS _INTEGER64 DIM bProccessed AS INTEGER bEncrypt = FALSE bDecrypt = FALSE bProccessed = FALSE ' assume failure by default sCypherKey = UCASE$ (TRIM$ (psCypherKey)) IF psCryption = "E" THEN _ bEncrypt = TRUE IF psCryption = "D" THEN _ bDecrypt = TRUE nCypherKey = LEN (sCypherKey) sKey = "" FOR nChar = 1 TO nCypherKey sChar = MID$ (sCypherKey, nChar, 1) IF (sChar >= "A" AND sChar <= "Z") or sChar = " " THEN _ sKey = sKey + sChar NEXT nChar sKey = TRIM$ (sKey) ' in case removal of invalid key characters causes leading or trailing SPACE characters nKeyLen = LEN (sKey) IF nKeyLen = 0 THEN gsError = "Error: Cypher Key is blank." processFile% = bProccessed EXIT FUNCTION END IF IF nKeyLen > 100 THEN gsError = "Error: Cypher Key is too long. (arbitrary maximum for this program implementation is 100 characters)" processFile% = bProccessed EXIT FUNCTION END IF IF nKeyLen > 0 and nKeyLen < 20 THEN _ gsMessage = gsMessage + "-- WARNING: Cypher Key SHOULD be at least 20 characters in length, but processing using requested key." ' sDate = DATE$ ' MM-DD-YYYY ' sTime = TIME$ ' HH:MM:SS ' sTimer = LTRIM$ (STR$ (CLNG (TIMER))) ' sOutFile = MID$ (sDate, 7, 4) + MID$ (sDate, 1, 2) + MID$ (sDate, 4, 2) + _ ' MID$ (sTime, 1, 2) + MID$ (sTime, 4, 2) + MID$ (sTime, 7, 2) + sTimer + _ ' LPAD$ (LTRIM$ (STR$ (CINT (RND * 9999))), "0", 4) + LPAD$ (LTRIM$ (STR$ (CINT (RND * 9999))), "0", 4) IF NOT (_FILEEXISTS (psFilename)) THEN gsError = "Error: File does not exist: " + psFilename processFile% = bProccessed EXIT FUNCTION END IF OPEN psFilename FOR BINARY ACCESS READ AS #1 nDataLen = LOF (1) IF nDataLen = 0 THEN CLOSE #1 gsError = "Unexpected Error: No data found to process." processFile% = bProccessed EXIT FUNCTION END IF REDIM aData (0 TO (nDataLen - 1)) AS _UNSIGNED _BYTE GET #1, , aData() CLOSE #1 ' IF gbDebug THEN ' nIdx = 0 ' ' FOR nChar = 0 TO nDataLen - 1 ' ' PRINT #9, "'"; CHR$ (aData (nChar)); "' ("; toHex2$ (aData (nChar)); ") "; ' nIdx = nIdx + 1 ' ' IF nIdx > 10 THEN ' nIdx = 0 ' PRINT #9, "" ' END IF ' ' NEXT nChar ' ' PRINT #9, "" ' END IF REDIM aOpsProcList (0 TO (nKeyLen - 1), 0 TO 4) AS _INTEGER64 nOperatorSeed = CS_OPERATOR_SEED ' arbitrarily chosen initial seed; hardcoded for this implementation (Byte) nOperandSeed = CS_OPERAND_SEED ' arbitrarily chosen initial seed; hardcoded for this implementation (Byte) nDatasetOffsetSeed = CS_DATASET_OFFSET_SEED ' arbitrarily chosen initial seed; hardcoded for this implementation (Unsigned Long) nDatasetOffset = CS_DATASET_OFFSET ' arbitrarily chosen initial dataset offset; hardcoded for this implementation (Unsigned Long) nOpsProcListCnt = 0 FOR nKeyCnt = 0 TO nKeyLen - 1 ' create the Operators Processing List sChar = MID$ (sKey, nKeyCnt + 1, 1) nKeyOperator = INSTR (CS_KEY_CHARS, sChar) - 1 + nOperatorSeed nOperatorSeed = nKeyOperator AND CS_MASK_BYTE nKeyOperator = nKeyOperator MOD 8 sChar = MID$ (sKey, (nKeyCnt + 1) MOD nKeyLen + 1, 1) nKeyOperand = INSTR (CS_KEY_CHARS, sChar) - 1 + nOperandSeed nOperandSeed = nKeyOperand AND CS_MASK_BYTE nKeyOperand = nKeyOperand MOD 8 sChar = MID$ (sKey, (nKeyCnt + 2) MOD nKeyLen + 1, 1) nKeyDataByte1 = (ASC (sChar) + nOpValueSeed) AND CS_MASK_BYTE nOpValueSeed = nKeyDataByte1 sChar = MID$ (sKey, (nKeyCnt + 3) MOD nKeyLen + 1, 1) nKeyDataByte2 = (ASC (sChar) + nOpValueSeed) AND CS_MASK_BYTE nOpValueSeed = nKeyDataByte2 sChar = MID$ (sKey, (nKeyCnt + 4) MOD nKeyLen + 1, 1) nKeyDataByte3 = (ASC (sChar) + nOpValueSeed) AND CS_MASK_BYTE nOpValueSeed = nKeyDataByte3 sChar = MID$ (sKey, (nKeyCnt + 5) MOD nKeyLen + 1, 1) nKeyDataByte4 = (ASC (sChar) + nOpValueSeed) AND CS_MASK_BYTE nOpValueSeed = nKeyDataByte4 nOpValue = (nKeyDataByte1 * CS_2_POW_24) + (nKeyDataByte2 * CS_2_POW_16) + (nKeyDataByte3 * CS_2_POW_8) + nKeyDataByte4 ' MSB aOpsProcList (nOpsProcListCnt, CS_META_OPERATOR) = nKeyOperator ' Operator to execute (initial) = 0 - 7 aOpsProcList (nOpsProcListCnt, CS_META_OPERAND_SELECTOR) = nKeyOperand ' Operand Selector (initial) = 0 - 7 aOpsProcList (nOpsProcListCnt, CS_META_OPERAND_VALUE) = nOpValue ' Unsigned Long value for two-operand operations aOpsProcList (nOpsProcListCnt, CS_META_DATASET_OFFSET) = nDatasetOffset ' where to start processing inside dataset aOpsProcList (nOpsProcListCnt, CS_META_PROC_DIR) = CS_META_PROC_DIR_FORW ' hardcoded forward direction nDatasetOffset = (nDatasetOffset + nDatasetOffsetSeed) AND CS_MASK_LONG nDatasetOffsetSeed = nDatasetOffset + 1 ' prevent from zeroing nDatasetOffset = nDatasetOffset MOD nDataLen nOpsProcListCnt = nOpsProcListCnt + 1 NEXT nKeyCnt IF nOpsProcListCnt = 0 THEN gsError = "Unexpected Error: While attempting to process cryption key." processFile% = bProccessed EXIT FUNCTION END IF IF gbDebug THEN PRINT #9, "** Simplexity Cypher processing run debug data." PRINT #9, "" PRINT #9, "Key = '"; sKey; "'" PRINT #9, "KeyLen = "; num$ (nKeyLen) PRINT #9, "* Operations Processing List" PRINT #9, "" PRINT #9, "Operator, Operand Selector, Operand Value, Data Offset, Proc-Dir" PRINT #9, "" FOR nIdx = 0 TO nOpsProcListCnt - 1 PRINT #9, num$ (nIdx); ": "; _ num$ (aOpsProcList (nIdx, CS_META_OPERATOR)); ", "; _ num$ (aOpsProcList (nIdx, CS_META_OPERAND_SELECTOR)); ", "; _ num$ (aOpsProcList (nIdx, CS_META_OPERAND_VALUE)); "; "; _ num$ (aOpsProcList (nIdx, CS_META_DATASET_OFFSET)); "; "; _ num$ (aOpsProcList (nIdx, CS_META_PROC_DIR)) NEXT nIdx PRINT #9, "" PRINT #9, "DataLen = "; num$ (nDataLen) PRINT #9, "" END IF IF bEncrypt THEN nOPLIdx = 0 ' start at the beginning of the key list nOPLDir = 1 ' direction = forward IF gbDebug THEN PRINT #9, "Encrypting ("; num$ (nOPLIdx); ","; num$ (nOPLDir); ")" PRINT #9, "" END IF END IF IF bDecrypt THEN nOPLIdx = nOpsProcListCnt - 1 ' start at the end of the key list nOPLDir = -1 ' reverse the direction = backward IF gbDebug THEN PRINT #9, "Decrypting ("; num$ (nOPLIdx); ","; num$ (nOPLDir); ")" PRINT #9, "" END IF END IF DO ' process the Operations Processing List (encrypt/decrypt the dataset) nKeyOperator = aOpsProcList (nOPLIdx, CS_META_OPERATOR) nKeyOperand = aOpsProcList (nOPLIdx, CS_META_OPERAND_SELECTOR) nOpValue = aOpsProcList (nOPLIdx, CS_META_OPERAND_VALUE) nDatasetOffset = aOpsProcList (nOPLIdx, CS_META_DATASET_OFFSET) nDirection = aOpsProcList (nOPLIdx, CS_META_PROC_DIR) nKeyOperatorStart = nKeyOperator nDataIdx = nDatasetOffset MOD nDataLen nDataCnt = nDataLen IF gbDebug THEN PRINT #9, "" PRINT #9, "========================================" PRINT #9, "" PRINT #9, "" PRINT #9, "Processing Run # "; num$ (nOPLIdx); "..." PRINT #9, " KeyOperator = "; num$ (nKeyOperator); " ("; gasOperators (nKeyOperator); ")" PRINT #9, " KeyOperand = "; num$ (nKeyOperand); " ("; gasOperands (nKeyOperand); ")" PRINT #9, " OpValue = "; num$ (nOpValue) nByte1 = (nOpValue AND CS_MASK_BYTE1) \ CS_2_POW_24 nByte2 = ((nOpValue AND CS_MASK_BYTE2) \ CS_2_POW_16) AND CS_MASK_BYTE nByte3 = ((nOpValue AND CS_MASK_BYTE3) \ CS_2_POW_8) AND CS_MASK_BYTE nByte4 = nOpValue AND CS_MASK_BYTE4 PRINT #9, " Bytes = "; num$ (nByte1); ", "; num$ (nByte2); ", "; num$ (nByte3); ", "; num$ (nByte4) PRINT #9, " Hex = "; toHex2$ (nByte1); " "; toHex2$ (nByte2); " "; toHex2$ (nByte3); " "; toHex2$ (nByte4) PRINT #9, " Binary = "; toBinary$ (nByte1, 8); " "; toBinary$ (nByte2, 8); " "; toBinary$ (nByte3, 8); " "; toBinary$ (nByte4, 8) PRINT #9, " DatasetOffset = "; num$ (nDatasetOffset) PRINT #9, " Direction = "; num$ (nDirection) PRINT #9, " DataIdx = "; num$ (nDataIdx) END IF nDatasetOffset = nDatasetOffset MOD nDataLen ' in case offset is larger than data length for later comparison DO ' process the dataset -- one full pass nCryptOperand = nKeyOperand IF nCryptOperand >= CS_OPSEL_UNSIGNED_LONG and nDataCnt < 4 THEN IF nDataCnt >= 2 THEN nCryptOperand = CS_OPSEL_UNSIGNED_WORD ELSE nCryptOperand = CS_OPSEL_UNSIGNED_BYTE END IF ELSE IF nCryptOperand >= CS_OPSEL_UNSIGNED_WORD and nDataCnt < 2 THEN _ nCryptOperand = CS_OPSEL_UNSIGNED_BYTE END IF IF gbDebug THEN PRINT #9, PRINT #9, "----------------------------------------" PRINT #9, "" PRINT #9, "" PRINT #9, "Orig Opand = "; num$ (nKeyOperand); " ("; gasOperands (nKeyOperand); ")" PRINT #9, "Opand = "; num$ (nCryptOperand); " ("; gasOperands (nCryptOperand); ") "; IF nKeyOperand <> nCryptOperand THEN _ PRINT #9, "~~~"; PRINT #9, "" PRINT #9, "DataIdx = "; num$ (nDataIdx) PRINT #9, "DataCnt = "; num$ (nDataCnt) nDataByte1 = aData (nDataIdx) nDataByte2 = aData ((nDataIdx + nDirection) MOD nDataLen) nDataByte3 = aData ((nDataIdx + nDirection + nDirection) MOD nDataLen) nDataByte4 = aData ((nDataIdx + nDirection + nDirection + nDirection) MOD nDataLen) PRINT #9, "Bytes = "; num$ (nDataByte1); ","; num$ (nDataByte2); ","; num$ (nDataByte3); ","; num$ (nDataByte4) PRINT #9, "Hex = "; toHex2$ (nDataByte1); " "; toHex2$ (nDataByte2); " "; toHex2$ (nDataByte3); " "; toHex2$ (nDataByte4) PRINT #9, "Binary = "; toBinary$ (nDataByte1, 8); " "; toBinary$ (nDataByte2, 8); " "; toBinary$ (nDataByte3, 8); " "; toBinary$ (nDataByte4, 8) nOperandValue2 = -1 nOperandValueUns2 = -1 nOperandData2 = -1 nOperandDataUns2 = -1 END IF SELECT CASE nCryptOperand ' get datasize-converted Operand and Data Values CASE CS_OPSEL_UNSIGNED_NYBBLE_HI ' Unsigned Nybble Hi (4 bits) ; H nDataSize = 1 nBitShiftMask = CS_MASK_BITSHIFT_NYBBLE nDataValueMask = CS_MASK_NYBBLE_LO nOperandValue = (nOpValue AND CS_MASK_NYBBLE_HI) \ ganBitsToShiftMultDiv (4) nOperandValueUns = nOperandValue nOperandData = (aData (nDataIdx) AND CS_MASK_NYBBLE_HI) \ ganBitsToShiftMultDiv (4) nOperandDataUns = nOperandData nOpDataValue = aData (nDataIdx) CASE CS_OPSEL_UNSIGNED_NYBBLE_LO ' Unsigned Nybble Lo (4 bits) ; L nDataSize = 1 nBitShiftMask = CS_MASK_BITSHIFT_NYBBLE nDataValueMask = CS_MASK_NYBBLE_LO nOperandValue = nOpValue AND CS_MASK_NYBBLE_LO nOperandValueUns = nOperandValue nOperandData = aData (nDataIdx) AND CS_MASK_NYBBLE_LO nOperandDataUns = nOperandData nOpDataValue = aData (nDataIdx) CASE CS_OPSEL_BOTH_UNYBBLES ' Both Unsigned Nybbles (4 bits) ; N nDataSize = 1 nBitShiftMask = CS_MASK_BITSHIFT_NYBBLE nDataValueMask = CS_MASK_NYBBLE_LO nOperandValue = (nOpValue AND CS_MASK_NYBBLE_HI) \ ganBitsToShiftMultDiv (4) nOperandValueUns = nOperandValue nOperandValue2 = nOpValue AND CS_MASK_NYBBLE_LO nOperandValueUns2 = nOperandValue2 nOperandData = (aData (nDataIdx) AND CS_MASK_NYBBLE_HI) \ ganBitsToShiftMultDiv (4) nOperandDataUns = nOperandData nOperandData2 = aData (nDataIdx) AND CS_MASK_NYBBLE_LO nOperandDataUns2 = nOperandData2 CASE CS_OPSEL_UNSIGNED_BYTE ' Unsigned Byte (8 bits) ; B nDataSize = 1 nBitShiftMask = CS_MASK_BITSHIFT_BYTE nDataValueMask = CS_MASK_BYTE nOperandValue = nOpValue AND CS_MASK_BYTE nOperandValueUns = nOperandValue nOperandData = aData (nDataIdx) nOperandDataUns = nOperandData CASE CS_OPSEL_UNSIGNED_WORD ' Unsigned Word (16 bits) ; U nDataSize = 2 nBitShiftMask = CS_MASK_BITSHIFT_WORD nDataValueMask = CS_MASK_WORD nOperandValue = nOpValue AND CS_MASK_WORD nOperandValueUns = nOperandValue nDataByte1 = aData (nDataIdx) nDataByte2 = aData ((nDataIdx + nDirection) MOD nDataLen) nOperandData = (nDataByte1 * CS_2_POW_8) + nDataByte2 ' MSB nOperandDataUns = nOperandData CASE CS_OPSEL_SIGNED_WORD ' Signed Word (16 bits) ; W nDataSize = 2 nBitShiftMask = CS_MASK_BITSHIFT_WORD nDataValueMask = CS_MASK_WORD nOperandValue = nOpValue AND CS_MASK_WORD nOperandValueUns = nOperandValue IF nOperandValue >= CS_2_POW_15 THEN _ nOperandValue = nOperandValue - CS_2_POW_16 ' convert to signed value nDataByte1 = aData (nDataIdx) nDataByte2 = aData ((nDataIdx + nDirection) MOD nDataLen) nOperandData = (nDataByte1 * CS_2_POW_8) + nDataByte2 ' MSB nOperandDataUns = nOperandData IF nOperandData >= CS_2_POW_15 THEN _ nOperandData = nOperandData - CS_2_POW_16 ' convert to signed value CASE CS_OPSEL_UNSIGNED_LONG ' Unsigned Long (32 bits) ; L nDataSize = 4 nBitShiftMask = CS_MASK_BITSHIFT_LONG nDataValueMask = CS_MASK_LONG nOperandValue = nOpValue nOperandValueUns = nOperandValue nDataByte1 = aData (nDataIdx) nDataByte2 = aData ((nDataIdx + nDirection) MOD nDataLen) nDataByte3 = aData ((nDataIdx + nDirection + nDirection) MOD nDataLen) nDataByte4 = aData ((nDataIdx + nDirection + nDirection + nDirection) MOD nDataLen) nOperandData = (nDataByte1 * CS_2_POW_24) + (nDataByte2 * CS_2_POW_16) + (nDataByte3 * CS_2_POW_8) + nDataByte4 ' MSB nOperandDataUns = nOperandData CASE CS_OPSEL_SIGNED_LONG ' Signed Long (32 bits) ; S nDataSize = 4 nBitShiftMask = CS_MASK_BITSHIFT_LONG nDataValueMask = CS_MASK_LONG nOperandValue = nOpValue nOperandValueUns = nOperandValue IF nOperandValue >= CS_2_POW_31 THEN _ nOperandValue = nOperandValue - CS_2_POW_32 ' convert to signed value nDataByte1 = aData (nDataIdx) nDataByte2 = aData ((nDataIdx + nDirection) MOD nDataLen) nDataByte3 = aData ((nDataIdx + nDirection + nDirection) MOD nDataLen) nDataByte4 = aData ((nDataIdx + nDirection + nDirection + nDirection) MOD nDataLen) nOperandData = (nDataByte1 * CS_2_POW_24) + (nDataByte2 * CS_2_POW_16) + (nDataByte3 * CS_2_POW_8) + nDataByte4 ' MSB nOperandDataUns = nOperandData IF nOperandData >= CS_2_POW_31 THEN _ nOperandData = nOperandData - CS_2_POW_32 ' convert to signed value END SELECT ' nCryptOperand -- get datasize-converted Operand and Data Values IF gbDebug THEN PRINT #9, "DataSize = "; num$ (nDataSize) PRINT #9, "BitShiftMask = "; num$ (nBitShiftMask) PRINT #9, "DataValueMask = 0x"; toHex8$ (nDataValueMask) PRINT #9, " OperandValue = "; num$ (nOperandValue) PRINT #9, " OperandValueUns = "; num$ (nOperandValueUns) IF nOperandValue2 = -1 THEN PRINT #9, " OperandValue2 = *" ELSE PRINT #9, " OperandValue2 = "; num$ (nOperandValue2) END IF IF nOperandValueUns2 = -1 THEN PRINT #9, " OperandValueUns2 = *" ELSE PRINT #9, " OperandValueUns2 = "; num$ (nOperandValueUns2) END IF PRINT #9, " OperandData = "; num$ (nOperandData) PRINT #9, " OperandDataUns = "; num$ (nOperandDataUns) IF nOperandData2 = -1 THEN PRINT #9, " OperandData2 = *" ELSE PRINT #9, " OperandData2 = "; num$ (nOperandData2) END IF IF nOperandDataUns2 = -1 THEN PRINT #9, " OperandDataUns2 = *" ELSE PRINT #9, " OperandDataUns2 = "; num$ (nOperandDataUns2) END IF END IF nCryptOperator = nKeyOperator IF bDecrypt THEN ' perform the opposite operation for decryption (otherwise leave as is for 'self-reversing' operators) SELECT CASE nKeyOperator CASE CS_OPER_ADD ' next key value (1, 2, 3, or 4 bytes after OpSel; key wrap-around) ; A nCryptOperator = CS_OPER_SUBTRACT CASE CS_OPER_COMPLEMENT ' ones' complement (bitwise NOT; bit invert) ; C CASE CS_OPER_SUBTRACT ' next key value (1, 2, 3, or 4 bytes after OpSel; key wrap-around) ; S nCryptOperator = CS_OPER_ADD CASE CS_OPER_NEGATE ' two's complement (arithmetic negative) ; N CASE CS_OPER_XOR ' next key value (1, 2, 3, or 4 bytes after OpSel; key wrap-around) ; X CASE CS_OPER_ROTATE_LEFT ' next key value after OpSel LSBs (2=1-3, 3=1-7, 4=1-15, 8=1-31; 0 = 1) ; L nCryptOperator = CS_OPER_ROTATE_RIGHT CASE CS_OPER_SWAP ' (Dits, Nybbles, Bytes, Words) ; W CASE CS_OPER_ROTATE_RIGHT ' next key value after OpSel LSBs (2=1-3, 3=1-7, 4=1-15, 8=1-31; 0 = 1) ; R nCryptOperator = CS_OPER_ROTATE_LEFT END SELECT ' nKeyOperator -- perform the opposite operation for decryption END IF IF gbDebug THEN PRINT #9, "Orig Oper = "; num$ (nKeyOperator); " ("; gasOperators (nKeyOperator); ")" PRINT #9, "Oper = "; num$ (nCryptOperator); " ("; gasOperators (nCryptOperator); ")" nResult2 = -1 nBitsToShift = -1 nDataMask = -1 nUpperValue = -1 nLowerValue = -1 END IF SELECT CASE nCryptOperator ' Operator execution CASE CS_OPER_ADD ' next key value (1, 2, 3, or 4 bytes after OpSel; key wrap-around) ; A nResult = nOperandData + nOperandValue IF nCryptOperand = CS_OPSEL_BOTH_UNYBBLES THEN _ nResult2 = nOperandData2 + nOperandValue2 CASE CS_OPER_COMPLEMENT ' ones" complement (bitwise NOT; bit invert) ; C nResult = NOT (nOperandDataUns) IF nCryptOperand = CS_OPSEL_BOTH_UNYBBLES THEN _ nResult2 = NOT (nOperandDataUns2) CASE CS_OPER_SUBTRACT ' next key value (1, 2, 3, or 4 bytes after OpSel; key wrap-around) ; S nResult = nOperandData - nOperandValue IF nCryptOperand = CS_OPSEL_BOTH_UNYBBLES THEN _ nResult2 = nOperandData2 - nOperandValue2 CASE CS_OPER_NEGATE ' two"s complement (arithmetic negative) ; N nResult = -nOperandData IF nCryptOperand = CS_OPSEL_BOTH_UNYBBLES THEN _ nResult2 = -nOperandData2 CASE CS_OPER_XOR ' next key value (1, 2, 3, or 4 bytes after OpSel; key wrap-around) ; X nResult = nOperandDataUns XOR nOperandValueUns IF nCryptOperand = CS_OPSEL_BOTH_UNYBBLES THEN _ nResult2 = nOperandDataUns2 XOR nOperandValueUns2 CASE CS_OPER_ROTATE_LEFT ' next key value after OpSel LSBs (2=1-3, 3=1-7, 4=1-15, 8=1-31; 0 = 1) ; L nBitsToShift = (nOperandValueUns AND nBitShiftMask) IF nBitsToShift = 0 THEN _ nBitsToShift = 1 ' // 0 = 1 nDataMask = nDataValueMask \ ganBitsToShiftMultDiv (nBitsToShift) nUpperValue = (nOperandDataUns AND nDataMask) * ganBitsToShiftMultDiv (nBitsToShift) nLowerValue = nOperandDataUns \ ganBitsToShiftMultDiv (nBitShiftMask - nBitsToShift + 1) nResult = nUpperValue OR nLowerValue IF nCryptOperand = CS_OPSEL_BOTH_UNYBBLES THEN nUpperValue = (nOperandDataUns2 AND nDataMask) * ganBitsToShiftMultDiv (nBitsToShift) nLowerValue = nOperandDataUns2 \ ganBitsToShiftMultDiv (nBitShiftMask - nBitsToShift + 1) nResult2 = nUpperValue OR nLowerValue END IF CASE CS_OPER_SWAP ' (Dits, Nybbles, Bytes, Words) ; W SELECT CASE nCryptOperand ' Operand-sized swapping CASE CS_OPSEL_UNSIGNED_NYBBLE_HI, _ CS_OPSEL_UNSIGNED_NYBBLE_LO, _ CS_OPSEL_BOTH_UNYBBLES ' Unsigned Nybble Hi (4 bits) ; H ' Unsigned Nybble Lo (4 bits) ; L ' Both Unsigned Nybbles (4 bits) ; N nDitHi = (nOperandDataUns AND CS_MASK_DIT_HI) \ ganBitsToShiftMultDiv (2) nDitLo = nOperandDataUns AND CS_MASK_DIT_LO nResult = (nDitLo * ganBitsToShiftMultDiv (2)) + nDitHi IF nCryptOperand = CS_OPSEL_BOTH_UNYBBLES THEN nDitHi = (nOperandDataUns2 AND CS_MASK_DIT_HI) \ ganBitsToShiftMultDiv (2) nDitLo = nOperandDataUns2 AND CS_MASK_DIT_LO nResult2 = (nDitLo * ganBitsToShiftMultDiv (2)) + nDitHi END IF CASE CS_OPSEL_UNSIGNED_BYTE ' Unsigned Byte (8 bits) ; B nNybbleHi = (nOperandDataUns AND CS_MASK_NYBBLE_HI) \ ganBitsToShiftMultDiv (4) nNybbleLo = nOperandDataUns AND CS_MASK_NYBBLE_LO nResult = (nNybbleLo * ganBitsToShiftMultDiv (4)) + nNybbleHi CASE CS_OPSEL_UNSIGNED_WORD, _ CS_OPSEL_SIGNED_WORD ' Unsigned Word (16 bits) ; U ' Signed Word (16 bits) ; W nByteHi = (nOperandDataUns AND CS_MASK_BYTE_HI) \ ganBitsToShiftMultDiv (8) nByteLo = nOperandDataUns AND CS_MASK_BYTE_LO nResult = (nByteLo * ganBitsToShiftMultDiv (8)) + nByteHi CASE CS_OPSEL_UNSIGNED_LONG, _ CS_OPSEL_SIGNED_LONG ' Unsigned Long (32 bits) ; L ' Signed Long (32 bits) ; S nWordHi = (nOperandDataUns AND CS_MASK_WORD_HI) \ ganBitsToShiftMultDiv (16) nWordLo = nOperandDataUns AND CS_MASK_WORD_LO nResult = (nWordLo * ganBitsToShiftMultDiv (16)) + nWordHi END SELECT ' nCryptOperand -- Operand-sized swapping CASE CS_OPER_ROTATE_RIGHT ' next key value after OpSel LSBs (2=1-3, 3=1-7, 4=1-15, 8=1-31; 0 = 1) ; R nBitsToShift = (nOperandValueUns AND nBitShiftMask) IF nBitsToShift = 0 THEN _ nBitsToShift = 1 ' // 0 = 1 nDataMask = nDataValueMask \ ganBitsToShiftMultDiv (nBitShiftMask - nBitsToShift + 1) nUpperValue = (nOperandDataUns AND nDataMask) * ganBitsToShiftMultDiv (nBitShiftMask - nBitsToShift + 1) nLowerValue = (nOperandDataUns \ ganBitsToShiftMultDiv (nBitsToShift)) AND (nDataValueMask \ ganBitsToShiftMultDiv (nBitsToShift)) nResult = nUpperValue OR nLowerValue IF nCryptOperand = CS_OPSEL_BOTH_UNYBBLES THEN nUpperValue = (nOperandDataUns2 AND nDataMask) * ganBitsToShiftMultDiv (nBitShiftMask - nBitsToShift + 1) nLowerValue = nOperandDataUns2 \ ganBitsToShiftMultDiv (nBitsToShift) nResult2 = nUpperValue OR nLowerValue END IF END SELECT ' nCryptOperator -- Operator execution SELECT CASE nCryptOperand ' store new result CASE CS_OPSEL_UNSIGNED_NYBBLE_HI ' Unsigned Nybble Hi (4 bits) ; H IF nResult < 0 THEN _ nResult = nResult + CS_2_POW_4 ' force value unsigned nResult = (nResult AND CS_MASK_NYBBLE_LO) * ganBitsToShiftMultDiv (4) aData (nDataIdx) = (nOpDataValue AND CS_MASK_NYBBLE_LO) + nResult CASE CS_OPSEL_UNSIGNED_NYBBLE_LO ' Unsigned Nybble Lo (4 bits) ; L IF nResult < 0 THEN _ nResult = nResult + CS_2_POW_4 ' force value unsigned nResult = nResult AND CS_MASK_NYBBLE_LO aData (nDataIdx) = (nOpDataValue AND CS_MASK_NYBBLE_HI) + nResult CASE CS_OPSEL_BOTH_UNYBBLES ' Both Unsigned Nybbles (4 bits) ; N IF nResult < 0 THEN _ nResult = nResult + CS_2_POW_4 ' force value unsigned nResult = (nResult AND CS_MASK_NYBBLE_LO) * ganBitsToShiftMultDiv (4) IF nResult2 < 0 THEN _ nResult2 = nResult2 + CS_2_POW_4 ' force value unsigned nResult2 = nResult2 AND CS_MASK_NYBBLE_LO aData (nDataIdx) = nResult + nResult2 CASE CS_OPSEL_UNSIGNED_BYTE ' Unsigned Byte (8 bits) ; B IF nResult < 0 THEN _ nResult = nResult + CS_2_POW_8 ' force value unsigned nResult = nResult AND CS_MASK_BYTE aData (nDataIdx) = nResult CASE CS_OPSEL_UNSIGNED_WORD, _ CS_OPSEL_SIGNED_WORD ' Unsigned Word (16 bits) ; U ' Signed Word (16 bits) ; W IF nResult < 0 THEN _ nResult = nResult + CS_2_POW_16 ' force value unsigned nResult = nResult AND CS_MASK_WORD aData (nDataIdx) = nResult \ ganBitsToShiftMultDiv (8) aData ((nDataIdx + nDirection) MOD nDataLen) = nResult AND CS_MASK_BYTE CASE CS_OPSEL_UNSIGNED_LONG, _ CS_OPSEL_SIGNED_LONG ' Unsigned Long (32 bits) ; L ' Signed Long (32 bits) ; S IF nResult < 0 THEN _ nResult = nResult + CS_2_POW_32 ' force value unsigned nResult = nResult AND CS_MASK_LONG nDataByte1 = (nResult AND CS_MASK_BYTE1) \ CS_2_POW_24 nDataByte2 = ((nResult AND CS_MASK_BYTE2) \ CS_2_POW_16) AND CS_MASK_BYTE nDataByte3 = ((nResult AND CS_MASK_BYTE3) \ CS_2_POW_8) AND CS_MASK_BYTE nDataByte4 = nResult AND CS_MASK_BYTE4 aData (nDataIdx) = nDataByte1 aData ((nDataIdx + nDirection) MOD nDataLen) = nDataByte2 aData ((nDataIdx + nDirection + nDirection) MOD nDataLen) = nDataByte3 aData ((nDataIdx + nDirection + nDirection + nDirection) MOD nDataLen) = nDataByte4 END SELECT ' nCryptOperand -- ' store new result IF gbDebug THEN PRINT #9, "** Result = "; num$ (nResult) IF nResult2 = -1 THEN PRINT #9, " Result2 = *" ELSE PRINT #9, " Result2 = "; num$ (nResult2) END IF nDataByte1 = aData (nDataIdx) nDataByte2 = aData ((nDataIdx + nDirection) MOD nDataLen) nDataByte3 = aData ((nDataIdx + nDirection + nDirection) MOD nDataLen) nDataByte4 = aData ((nDataIdx + nDirection + nDirection + nDirection) MOD nDataLen) PRINT #9, " Bytes = "; num$ (nDataByte1); ", "; num$ (nDataByte2); ", "; num$ (nDataByte3); ", "; num$ (nDataByte4) PRINT #9, " Hex = "; toHex2$ (nDataByte1); " "; toHex2$ (nDataByte2); " "; toHex2$ (nDataByte3); " "; toHex2$ (nDataByte4) PRINT #9, " Binary = "; toBinary$ (nDataByte1, 8); " "; toBinary$ (nDataByte2, 8); " "; toBinary$ (nDataByte3, 8); " "; toBinary$ (nDataByte4, 8) IF nBitsToShift = -1 THEN PRINT #9, " BitsToShift = *" ELSE PRINT #9, " BitsToShift = "; num$ (nBitsToShift) END IF IF nDataMask = -1 THEN PRINT #9, " DataMask = *" ELSE PRINT #9, " DataMask = "; toBinary$ (nDataMask, nBitShiftMask + 1) END IF IF nUpperValue = -1 THEN PRINT #9, " UpperValue = *" ELSE PRINT #9, " UpperValue = "; toBinary$ (nUpperValue, nBitShiftMask + 1) END IF IF nLowerValue = -1 THEN PRINT #9, " LowerValue = *" ELSE PRINT #9, " LowerValue = "; toBinary$ (nLowerValue, nBitShiftMask + 1) END IF END IF nDataIdx = (nDataIdx + (nDirection * nDataSize)) MOD nDataLen nDataCnt = nDataCnt - nDataSize nKeyOperator = (nKeyOperator + 1) MOD 8 nKeyOperand = (nKeyOperand + 1) MOD 8 IF nKeyOperator = nKeyOperatorStart THEN _ nKeyOperand = (nKeyOperand + 1) MOD 8 ' ensures all Operators with all Operand sizes LOOP WHILE nDataIdx <> nDatasetOffset ' process the dataset -- one full pass nOPLIdx = nOPLIdx + nOPLDir PRINT "*"; ' show progress LOOP WHILE nOPLIdx >= 0 AND nOPLIdx < nOpsProcListCnt ' process the Operations Processing List gnErr = 0 OPEN psOutput FOR OUTPUT AS #1 ' erase output file IF gnErr = 0 THEN CLOSE #1 gnErr = 0 OPEN psOutput FOR BINARY AS #1 ' write cryption to output file IF gnErr = 0 THEN gnErr = 0 PUT #1, , aData() IF gnErr = 0 THEN CLOSE #1 bProccessed = TRUE ELSE gsError = "Error saving cryption into output file, '" + psOutput + "': " + errorText$ (gnErr, TRUE) END IF ELSE gsError = "Error opening cryption output file for save, '" + psOutput + "': " + errorText$ (gnErr, TRUE) END IF ELSE gsError = "Error erasing cryption output file, '" + psOutput + "': " + errorText$ (gnErr, TRUE) END IF processFile% = bProccessed END FUNCTION ' processFile ' debugging helper functions FUNCTION toHex2$ ( _ pnNumber AS _UNSIGNED _INTEGER64 _ ) ' number to 2 hex digits padded with zeroes (8-bit byte) toHex2$ = LPAD$ (HEX$ (pnNumber), "0", 2) END FUNCTION ' toHex2$ FUNCTION toHex4$ ( _ pnNumber AS _UNSIGNED _INTEGER64 _ ) ' number to 4 hex digits padded with zeroes (16-bit word) toHex4$ = LPAD$ (HEX$ (pnNumber), "0", 4) END FUNCTION ' toHex4$ FUNCTION toHex8$ ( _ pnNumber AS _UNSIGNED _INTEGER64 _ ) ' number to 8 hex digits padded with zeroes (32-bit long) toHex8$ = LPAD$ (HEX$ (pnNumber), "0", 8) END FUNCTION ' toHex8$ FUNCTION toBinary$ ( _ pnNumber AS _UNSIGNED _INTEGER64, _ pnDigits AS INTEGER _ ) ' number to n-digit binary up to 64 bits (up to 64-bit quad word) DIM nBit AS _UNSIGNED _INTEGER64 DIM nCnt AS INTEGER DIM sBinary AS STRING DIM sBit AS STRING DIM nDigits AS INTEGER nDigits = pnDigits IF nDigits < 0 OR nDigits > 64 THEN _ nDigits = 64 nBit = 1 FOR nCnt = 0 TO nDigits - 1 IF (pnNumber AND nBit) = 0 THEN sBit = "0" ELSE sBit = "1" END IF sBinary = sBit + sBinary nBit = nBit * 2 NEXT nCnt toBinary$ = sBinary END FUNCTION ' toBinary$ FUNCTION num$ ( _ pnNumber AS _INTEGER64 _ ) ' non-leading SPACE (positive) number to string conversion num$ = LTRIM$ (STR$ (pnNumber)) END FUNCTION 'num$ ' ancillary helper functions FUNCTION RPAD$ ( _ psText AS STRING, _ psPadChar AS STRING, _ pnPadLength AS INTEGER _ ) ' Right pad DIM sPadded AS STRING IF LEN (psText) >= pnPadLength THEN RPAD$ = psText ELSE RPAD$ = LEFT$ (psText + STRING$ (pnPadLength, psPadChar), pnPadLength) END IF END FUNCTION ' RPAD$ --- NOTE: Does not truncate if longer than pad length FUNCTION LPAD$ ( _ psText AS STRING, _ psPadChar AS STRING, _ pnPadLength AS INTEGER _ ) ' Left pad IF LEN (psText) >= pnPadLength THEN LPAD$ = psText ELSE LPAD$ = RIGHT$ (STRING$ (pnPadLength, psPadChar) + psText, pnPadLength) END IF END FUNCTION ' LPAD$ --- NOTE: Does not truncate if longer than pad length FUNCTION TRIM$ ( _ psText AS STRING _ ) ' Left and Right trim of SPACE characters TRIM$ = LTRIM$ (RTRIM$ (psText)) END FUNCTION ' TRIM$ FUNCTION trimWhitespace$ ( _ psText AS STRING _ ) ' remove all instances of leading and trailing SPACE, CR, LF, and TAB DIM sText AS STRING DIM sChar AS STRING DIM blnLeading AS INTEGER DIM blnTrailing AS INTEGER sText = TRIM$ (psText) blnLeading = FALSE blnTrailing = FALSE DO sChar = LEFT$ (sText, 1) IF sChar = C_SPC OR sChar = C_TAB OR sChar = C_CR OR sChar = C_LF THEN _ blnLeading = TRUE IF blnLeading THEN _ sText = MID$ (sText, 2) sChar = RIGHT$ (sText, 1) IF sChar = C_SPC OR sChar = C_TAB OR sChar = C_CR OR sChar = C_LF THEN _ blnTrailing = TRUE IF blnTrailing THEN _ sText = LEFT$ (sText, LEN (sText) - 1) LOOP WHILE sText <> "" AND (blnLeading OR blnTrailing) trimWhitespace$ = sText END FUNCTION ' trimWhitespace$ FUNCTION strrev$ ( _ psText AS STRING _ ) ' reverse a string DIM sText AS STRING DIM nLen AS INTEGER DIM nChar AS INTEGER sText = "" nLen = LEN (psText) FOR nChar = nLen TO 1 STEP -1 sText = sText + MID$ (psText, nChar, 1) NEXT nChar strrev$ = sText END FUNCTION ' strrev$ FUNCTION strrpos% ( _ psText AS STRING, _ psSearch AS STRING, _ pnOffset AS INTEGER _ ) ' find the position of the last occurrence of a substring in a string, 0 = not found ' if search string is "" returns length of string + 1 DIM nFound AS INTEGER DIM sText AS STRING DIM sSearch AS STRING sText = psText IF pnOffset > 0 THEN _ sText = MID$ (sText, pnOffset) sText = strrev$ (sText) ' reverse the string to search backward sSearch = strrev$ (psSearch) ' reverse the search string accordingly nFound = INSTR (sText, sSearch) IF nFound > 0 THEN _ nFound = LEN (sText) - (nFound - 1) - (LEN (sSearch) - 1) strrpos% = nFound END FUNCTION ' strrpos% FUNCTION strripos% ( _ psText AS STRING, _ psSearch AS STRING, _ pnOffset AS INTEGER _ ) ' find the insensitive search position of the last occurrence of a substring in a string, 0 = not found ' if search string is "" returns length of string + 1 DIM nFound AS INTEGER DIM sText AS STRING DIM sSearch AS STRING sText = UCASE$ (psText) IF pnOffset > 0 THEN _ sText = MID$ (sText, pnOffset) sText = strrev$ (sText) ' reverse the string to search backward sSearch = strrev$ (UCASE$ (psSearch)) ' reverse the search string accordingly nFound = INSTR (sText, sSearch) IF nFound > 0 THEN _ nFound = LEN (sText) - (nFound - 1) - (LEN (sSearch) - 1) strripos% = nFound END FUNCTION ' strripos% SUB beepAlert PLAY "V25O2L8C" ' 25% Volume, Octave 2, 'C' 8th Note END SUB ' beepAlert FUNCTION errorText$ ( _ pnErrorNum AS INTEGER, _ pblnIncludeErrNum AS INTEGER _ ) DIM sErrorText AS STRING DIM sErrorDesc AS STRING SELECT CASE pnErrorNum CASE 1 sErrorText = "NEXT without FOR" sErrorDesc = "Usually an END IF block statement was omitted from an IF or SELECT CASE." CASE 2 sErrorText = "Syntax error" sErrorDesc = "Mistyped keyword statement syntax errors." CASE 3 sErrorText = "RETURN without GOSUB" sErrorDesc = "A RETURN statement without a GOSUB call. Place sub AFTER sub-procedure EXIT or program END!" CASE 4 sErrorText = "Out of DATA" sErrorDesc = "A READ has read past the end of DATA. Use RESTORE to reset to data start." CASE 5 sErrorText = "Illegal function call" sErrorDesc = "A parameter passed does not match the function type or exceeds certain function limitations. See Illegal Function." CASE 6 sErrorText = "Overflow" sErrorDesc = "A numerical value has exceeded the type limitations." CASE 7 sErrorText = "Out of memory" sErrorDesc = "A module has exceeded the 64K memory limitation of QB. Try breaking the code up to smaller modules." CASE 8 sErrorText = "Label not defined" sErrorDesc = "GOTO or GOSUB tries to branch to a label that doesn't exist." CASE 9 sErrorText = "Subscript out of range" sErrorDesc = "An array's upper or lower bounds have been exceeded." CASE 10 sErrorText = "Duplicate definition" sErrorDesc = "You can't define a variable twice with DIM, the first time a variable is used it is also defined." CASE 11 sErrorText = "Division by zero" sErrorDesc = "You cannot divide any value by zero! Even using MOD." CASE 12 sErrorText = "Illegal in direct mode" sErrorDesc = "A statement (like DIM) in the Immediate window wasn't allowed." CASE 13 sErrorText = "Type mismatch" sErrorDesc = "A SUB or FUNCTION parameter does not match the procedure Declaration." CASE 14 sErrorText = "Out of string space" sErrorDesc = "A module has exceeded the 32767 text character limit. Use SUB PRINT procedures." CASE 16 sErrorText = "String formula too complex" sErrorDesc = "A string formula was too long or a INPUT statement requested more than 15 strings" CASE 17 sErrorText = "Cannot continue" sErrorDesc = "The program while debugging has changed in a way that it cannot continue." CASE 18 sErrorText = "Function not defined" sErrorDesc = "The function used by the program must be defined. Did you include the .bi file while using a library?" CASE 19 sErrorText = "No RESUME" sErrorDesc = "The end of the program was reached while being in a error handling routine, add a RESUME at the end of the routine." CASE 20 sErrorText = "RESUME without error" sErrorDesc = "RESUME can only be used in an error handler using ON ERROR." CASE 24 sErrorText = "Device timeout" sErrorDesc = "Use DS0 to avoid modem timeouts." CASE 25 sErrorText = "Device fault" sErrorDesc = "Device not connected or does not exist." CASE 26 sErrorText = "FOR without NEXT" sErrorDesc = "Look for a missing END IF statement also." CASE 27 sErrorText = "Out of paper" sErrorDesc = "A PRINTer paper error when using LPRINT." CASE 29 sErrorText = "WHILE without WEND" sErrorDesc = "WEND must be used with WHILE" CASE 30 sErrorText = "WEND without WHILE" sErrorDesc = "Look for an END IF error also." CASE 33 sErrorText = "Duplicate label" sErrorDesc = "Line numbers or labels cannot be used twice in a procedure." CASE 35 sErrorText = "Subprogram not defined" sErrorDesc = "Often occurs when the Quickbasic Library is not used with CALL ABSOLUTE or INTERRUPT." CASE 37 sErrorText = "Argument-count mismatch" sErrorDesc = "The number of sub-procedure parameters do not match the call." CASE 38 sErrorText = "Array not defined" sErrorDesc = "Arrays using more than 10 elements must be DIMensioned." CASE 40 sErrorText = "Variable required" sErrorDesc = "A GET or PUT statement must specify a variable when operating with a file opened in binary mode." CASE 50 sErrorText = "FIELD overflow" sErrorDesc = "A FIELD statement tried to allocate more bytes than were specified for the record length of a random access file." CASE 51 sErrorText = "Internal error" sErrorDesc = "An internal malfunction occured in QuickBASIC or QB64." CASE 52 sErrorText = "Bad file name or number" sErrorDesc = "The filename must follow the rules for filenames in the OS and filenumbers must be between 1 and 255 and refer to a currently open file." CASE 53 sErrorText = "File not found" sErrorDesc = "File not in current directory or path given." CASE 54 sErrorText = "Bad file mode" sErrorDesc = "File access mode does not match file procedure." CASE 55 sErrorText = "File already open" sErrorDesc = "CLOSE a file to open it in a different mode." CASE 56 sErrorText = "FIELD statement active" sErrorDesc = "(no further information is available for Error #56)" CASE 57 sErrorText = "Device I/O error" sErrorDesc = "(no further information is available for Error #57)" CASE 58 sErrorText = "File already exists" sErrorDesc = "The filename specified in the NAME statement was identical to a file that already exists." CASE 59 sErrorText = "Bad record length" sErrorDesc = "Record length exceeds 32767 bytes or is 0" CASE 61 sErrorText = "Disk full" sErrorDesc = "The amount of data to write to the disk was more than the free space available, remove some files you don't need and try again." CASE 62 sErrorText = "Input past end of file" sErrorDesc = "Check for the end of file with EOF." CASE 63 sErrorText = "Bad record number" sErrorDesc = "GET read exceeds number of records in file." CASE 64 sErrorText = "Bad file name" sErrorDesc = "File name contains illegal characters or exceeds 12 characters." CASE 67 sErrorText = "Too many files" sErrorDesc = "Over 15 files are open." CASE 68 sErrorText = "Device unavailable" sErrorDesc = "Device is busy or not connected." CASE 69 sErrorText = "Communication-buffer overflow." sErrorDesc = "(no further information is available for Error #69)" CASE 70 sErrorText = "Permission denied" sErrorDesc = "A file or port is in use on a network, blocked, read only or locked." CASE 71 sErrorText = "Disk not ready" sErrorDesc = "Disk is busy or has no media." CASE 72 sErrorText = "Disk-media error" sErrorDesc = "Improper media format or bad data." CASE 73 sErrorText = "Feature unavailable" sErrorDesc = "Based on the DOS version available." CASE 74 sErrorText = "Rename across disks" sErrorDesc = "(no further information is available for Error #74)" CASE 75 sErrorText = "Path/File access error" sErrorDesc = "File or path cannot be accessed." CASE 76 sErrorText = "Path not found" sErrorDesc = "Path is not accessable." CASE 97 sErrorText = "(No error message -- Err #97 = User Defined Error)" sErrorDesc = "Can be used to trigger an error trap event with ERROR 97, nothing else will cause this error, so create your own errors for ON ERROR." CASE 258 sErrorText = "Invalid handle" sErrorDesc = "Zero or bad handle values cannot be used." CASE ELSE sErrorText = "Unknown Error #" + STR$ (pnErrorNum) sErrorDesc = "An unknown error has occurred." END SELECT IF (pblnIncludeErrNum) THEN _ sErrorText = "Err #" + LTRIM$ (STR$ (pnErrorNum)) + ": " + sErrorText errorText$ = sErrorText + " (" + sErrorDesc + ")" END FUNCTION ' errorText$ FUNCTION superInkey$ ' superInkey$ = INKEY$-like function that returns additional information, ' particularly for extended, 2-char keys created with SHIFT, CTRL and ALT ' and Function keys and other non-ASCII extended key values ' ' Expects: ' ' Global gtSuperInkey ' global variable defined as a typeSuperInkey TYPE ' ' Global C_SPC ' constant SPACE ' ' REQUIRES CONST FALSE = 0, TRUE = NOT FALSE in global program DIM sAlt AS STRING DIM sChar AS STRING gtSuperInkey.sChar = "" gtSuperInkey.sCharExt = "" gtSuperInkey.sExt = "" gtSuperInkey.sName = "" gtSuperInkey.sPrintable = "" gtSuperInkey.nASC = 0 gtSuperInkey.nExtASC = 0 gtSuperInkey.bKeyPress = FALSE gtSuperInkey.bNull = FALSE gtSuperInkey.bCtrl = FALSE gtSuperInkey.bAlt = FALSE gtSuperInkey.bShift = FALSE gtSuperInkey.bFunc = FALSE gtSuperInkey.bArrow = FALSE gtSuperInkey.bCursor = FALSE gtSuperInkey.bKeyPad = FALSE sAlt = "QWERTYUIOP[]??ASDFGHJKL;'`?\ZXCVBNM,./" ' extended 16 to 53 for ALT+ superInkey$ = "" sChar = INKEY$ gtSuperInkey.sChar = sChar IF sChar = "" THEN gtSuperInkey.bNull = TRUE EXIT FUNCTION END IF gtSuperInkey.bKeyPress = TRUE IF ASC (sChar) > 0 THEN ' normal key codes gtSuperInkey.nASC = ASC (sChar) gtSuperInkey.sPrintable = gtSuperInkey.sChar SELECT CASE gtSuperInkey.nASC CASE 7 ' Bell gtSuperInkey.sName = "Beep (Ctrl-G)" CASE 8 ' BS gtSuperInkey.sName = "Backspace (Ctrl-H)" CASE 9 ' TAB gtSuperInkey.sName = "Tab Key (TAB/Ctrl-I)" CASE 10 ' LF gtSuperInkey.sName = "Line Feed (Ctrl-J)" CASE 12 ' FF gtSuperInkey.sName = "Form Feed (Ctrl-L)" CASE 13 ' Enter/CR gtSuperInkey.sName = "Enter (Enter/Ctrl-M)" CASE 27 ' ESCape gtSuperInkey.sName = "Escape (ESC/Ctrl-[)" CASE 28 ' Move Cursor Right gtSuperInkey.sName = "Move Cursor Right" CASE 29 ' Move Cursor Left gtSuperInkey.sName = "Move Cursor Left" CASE 30 ' Move Cursor Up gtSuperInkey.sName = "Move Cursor Up" CASE 31 ' Move Cursor Down gtSuperInkey.sName = "Move Cursor Down" CASE 32 ' SPACE gtSuperInkey.sName = "SpaceBar" gtSuperInkey.sExt = "SPACE" ' because types have fixed-length strings, spaces need special notification CASE 33 TO 47 ' ! " # $ % & ' ( ) * + , - . / gtSuperInkey.sName = "Punctuation: " + gtSuperInkey.sChar CASE 48 TO 57 ' 0 - 9 gtSuperInkey.sName = "Numeral: " + gtSuperInkey.sChar CASE 58 TO 64 ' : ; < = > ? @ gtSuperInkey.sName = "Punctuation: " + gtSuperInkey.sChar CASE 65 TO 90 ' A - Z gtSuperInkey.sName = "Uppercase: " + gtSuperInkey.sChar CASE 91 TO 96 ' [ \ ] ^ _ ` gtSuperInkey.sName = "Punctuation: " + gtSuperInkey.sChar CASE 97 TO 122 ' a - z gtSuperInkey.sName = "Lowercase: " + gtSuperInkey.sChar CASE 123 TO 127 ' { | } ~ DEL gtSuperInkey.sName = "Punctuation: " + gtSuperInkey.sChar CASE ELSE gtSuperInkey.sName = "Unknown Other" IF gtSuperInkey.nASC < 32 THEN _ gtSuperInkey.sName = "Ctrl+" + CHR$ (gtSuperInkey.nASC + 64) END SELECT ' gtSuperInkey.nASC IF gtSuperInkey.nASC < 32 THEN _ gtSuperInkey.bCtrl = TRUE SELECT CASE gtSuperInkey.nASC ' check for unPRINT #9, able control combo characters CASE 10 TO 13 ' Linefeed, Vertical Tab, Form Feed, Carriage Return gtSuperInkey.sPrintable = C_SPC CASE 28 TO 31 ' Up, Down, Left, and Right Arrow (movement) gtSuperInkey.sPrintable = C_SPC END SELECT END IF ' Normal key code IF ASC (sChar) = 0 THEN ' two byte key codes gtSuperInkey.nExtASC = ASC (RIGHT$ (sChar, 1)) gtSuperInkey.sChar = "" gtSuperInkey.sCharExt = sChar sChar = "" ' return true "" gtSuperInkey.bNull = TRUE SELECT CASE gtSuperInkey.nExtASC CASE 0 TO 2 ' unknowns gtSuperInkey.sExt = "Unknown:" + STR$ (gtSuperInkey.nExtASC) CASE 3 ' Ctrl+@ gtSuperInkey.sExt = "Ctrl+@" gtSuperInkey.bCtrl = TRUE CASE 4 TO 15 ' unknowns gtSuperInkey.sExt = "Unknown:" + STR$ (gtSuperInkey.nExtASC) CASE 16 TO 53 ' ALT+ characters gtSuperInkey.sExt = "Alt+" + MID$ (sAlt, gtSuperInkey.nExtASC - 15, 1) gtSuperInkey.bAlt = TRUE CASE 54 ' 6 gtSuperInkey.sExt = "Unknown:" + STR$ (gtSuperInkey.nExtASC) + " = " + CHR$ (gtSuperInkey.nExtASC) CASE 55 ' 7 gtSuperInkey.sExt = "Alt+KeyPadAsterisk" gtSuperInkey.bAlt = TRUE gtSuperInkey.bKeyPad = TRUE CASE 56 TO 58 ' 8 | 9 | : gtSuperInkey.sExt = "Unknown:" + STR$ (gtSuperInkey.nExtASC) + " = " + CHR$ (gtSuperInkey.nExtASC) CASE 59 TO 68 ' ; | < | = | > | ? | @ | A - D gtSuperInkey.sExt = "F" + LTRIM$ (STR$ (gtSuperInkey.nExtASC - 58)) gtSuperInkey.bFunc = TRUE CASE 69 TO 70 ' E | F gtSuperInkey.sExt = "Unknown:" + STR$ (gtSuperInkey.nExtASC) + " = " + CHR$ (gtSuperInkey.nExtASC) CASE 71 ' G gtSuperInkey.sExt = "Home" gtSuperInkey.bCursor = TRUE CASE 72 ' H gtSuperInkey.sExt = "ArrowUp" gtSuperInkey.bArrow = TRUE gtSuperInkey.bCursor = TRUE CASE 73 ' I gtSuperInkey.sExt = "PageUp" gtSuperInkey.bCursor = TRUE CASE 74 ' J gtSuperInkey.sExt = "Alt+KeyPadMinus" gtSuperInkey.bAlt = TRUE gtSuperInkey.bKeyPad = TRUE CASE 75 ' K gtSuperInkey.sExt = "ArrowLeft" gtSuperInkey.bArrow = TRUE gtSuperInkey.bCursor = TRUE CASE 76 ' L gtSuperInkey.sExt = "KeyPad5" gtSuperInkey.bKeyPad = TRUE CASE 77 ' M gtSuperInkey.sExt = "ArrowRight" gtSuperInkey.bArrow = TRUE gtSuperInkey.bCursor = TRUE CASE 78 ' N gtSuperInkey.sExt = "Alt+KeyPadPlus" gtSuperInkey.bAlt = TRUE gtSuperInkey.bKeyPad = TRUE CASE 79 ' O gtSuperInkey.sExt = "End" gtSuperInkey.bCursor = TRUE CASE 80 ' P gtSuperInkey.sExt = "ArrowDown" gtSuperInkey.bArrow = TRUE gtSuperInkey.bCursor = TRUE CASE 81 ' Q gtSuperInkey.sExt = "PageDown" gtSuperInkey.bCursor = TRUE CASE 82 ' R gtSuperInkey.sExt = "Insert" CASE 83 ' S gtSuperInkey.sExt = "Delete" CASE 84 TO 93 ' T - Z | [ | \ | ] = Shift+F1 to Shift+F10 gtSuperInkey.sExt = "Shift+F" + LTRIM$ (STR$ (gtSuperInkey.nExtASC - 83)) gtSuperInkey.bShift = TRUE gtSuperInkey.bFunc = TRUE CASE 94 TO 103 ' ^ | _ | ` | a - g = Ctrl+F1 to Ctrl+F10 gtSuperInkey.sExt = "Ctrl+F" + LTRIM$ (STR$ (gtSuperInkey.nExtASC - 93)) gtSuperInkey.bCtrl = TRUE gtSuperInkey.bFunc = TRUE CASE 104 TO 113 ' h - q = Alt+F1 to Alt+F10 gtSuperInkey.sExt = "Alt+F" + LTRIM$ (STR$ (gtSuperInkey.nExtASC - 103)) gtSuperInkey.bAlt = TRUE gtSuperInkey.bFunc = TRUE CASE 114 ' r == Unknown KeyPad value gtSuperInkey.sExt = "Ctrl+KeyPad? (r)" gtSuperInkey.bCtrl = TRUE gtSuperInkey.bKeyPad = TRUE CASE 115 ' s gtSuperInkey.sExt = "Ctrl+ArrowLeft" gtSuperInkey.bCtrl = TRUE gtSuperInkey.bArrow = TRUE gtSuperInkey.bCursor = TRUE CASE 116 ' t gtSuperInkey.sExt = "Ctrl+ArrowRight" gtSuperInkey.bCtrl = TRUE gtSuperInkey.bArrow = TRUE gtSuperInkey.bCursor = TRUE CASE 117 ' u gtSuperInkey.sExt = "Ctrl+End" gtSuperInkey.bCtrl = TRUE gtSuperInkey.bCursor = TRUE CASE 118 ' v gtSuperInkey.sExt = "Ctrl+PageDown" gtSuperInkey.bCtrl = TRUE gtSuperInkey.bCursor = TRUE CASE 119 ' w gtSuperInkey.sExt = "Ctrl+Home" gtSuperInkey.bCtrl = TRUE gtSuperInkey.bCursor = TRUE CASE 120 TO 128 ' x - z | { | '|' | } | ~ | ¦ (DEL) | Ç = Alt+1 TO Alt+9 gtSuperInkey.sExt = "Alt+" + LTRIM$ (STR$ (gtSuperInkey.nExtASC - 119)) gtSuperInkey.bAlt = TRUE CASE 129 ' ü gtSuperInkey.sExt = "Alt+0" gtSuperInkey.bAlt = TRUE CASE 130 ' é gtSuperInkey.sExt = "Alt+-" gtSuperInkey.bAlt = TRUE CASE 131 ' â gtSuperInkey.sExt = "Alt+=" gtSuperInkey.bAlt = TRUE CASE 132 ' ä gtSuperInkey.sExt = "Ctrl+PageUp" gtSuperInkey.bCtrl = TRUE gtSuperInkey.bCursor = TRUE CASE 133 ' à gtSuperInkey.sExt = "F11" gtSuperInkey.bFunc = TRUE CASE 134 ' å gtSuperInkey.sExt = "F12" gtSuperInkey.bFunc = TRUE CASE 135 ' ç gtSuperInkey.sExt = "Shift+F11" gtSuperInkey.bShift = TRUE gtSuperInkey.bFunc = TRUE CASE 136 ' ê gtSuperInkey.sExt = "Shift+F12" gtSuperInkey.bShift = TRUE gtSuperInkey.bFunc = TRUE CASE 137 ' ë gtSuperInkey.sExt = "Ctrl+F11" gtSuperInkey.bCtrl = TRUE gtSuperInkey.bFunc = TRUE CASE 138 ' è gtSuperInkey.sExt = "Ctrl+F12" gtSuperInkey.bCtrl = TRUE gtSuperInkey.bFunc = TRUE CASE 139 ' ï gtSuperInkey.sExt = "Alt+F11" gtSuperInkey.bAlt = TRUE gtSuperInkey.bFunc = TRUE CASE 140 ' î gtSuperInkey.sExt = "Alt+F12" gtSuperInkey.bAlt = TRUE gtSuperInkey.bFunc = TRUE CASE 141 ' ì gtSuperInkey.sExt = "Ctrl+ArrowUp" gtSuperInkey.bCtrl = TRUE gtSuperInkey.bArrow = TRUE gtSuperInkey.bCursor = TRUE CASE 142 ' Ä gtSuperInkey.sExt = "Ctrl+KeyPadMinus" gtSuperInkey.bCtrl = TRUE gtSuperInkey.bKeyPad = TRUE CASE 143 ' Å gtSuperInkey.sExt = "Ctrl+KeyPad5" gtSuperInkey.bCtrl = TRUE gtSuperInkey.bKeyPad = TRUE CASE 144 ' É gtSuperInkey.sExt = "Ctrl+KeyPadPlus" gtSuperInkey.bCtrl = TRUE gtSuperInkey.bKeyPad = TRUE CASE 145 ' æ gtSuperInkey.sExt = "Ctrl+ArrowDown" gtSuperInkey.bCtrl = TRUE gtSuperInkey.bArrow = TRUE gtSuperInkey.bCursor = TRUE CASE 146 ' Æ gtSuperInkey.sExt = "Ctrl+Insert" gtSuperInkey.bCtrl = TRUE CASE 147 ' ô gtSuperInkey.sExt = "Ctrl+Delete" gtSuperInkey.bCtrl = TRUE CASE 148 ' ö gtSuperInkey.sExt = "Unknown:" + STR$ (gtSuperInkey.nExtASC) + " = " + CHR$ (gtSuperInkey.nExtASC) CASE 149 ' ò gtSuperInkey.sExt = "Ctrl+KeyPadSlash" gtSuperInkey.bCtrl = TRUE gtSuperInkey.bKeyPad = TRUE CASE 150 ' û gtSuperInkey.sExt = "Ctrl+KeyPadAsterisk" gtSuperInkey.bCtrl = TRUE gtSuperInkey.bKeyPad = TRUE CASE 151 ' ù gtSuperInkey.sExt = "Alt+Home" gtSuperInkey.bAlt = TRUE gtSuperInkey.bCursor = TRUE CASE 152 ' ÿ gtSuperInkey.sExt = "Alt+ArrowUp" gtSuperInkey.bAlt = TRUE gtSuperInkey.bArrow = TRUE gtSuperInkey.bCursor = TRUE CASE 153 ' Ö gtSuperInkey.sExt = "Alt+PageUp" gtSuperInkey.bAlt = TRUE gtSuperInkey.bCursor = TRUE CASE 154 ' Ü gtSuperInkey.sExt = "Unknown:" + STR$ (gtSuperInkey.nExtASC) + " = " + CHR$ (gtSuperInkey.nExtASC) CASE 155 ' ¢ gtSuperInkey.sExt = "Alt+ArrowLeft" gtSuperInkey.bAlt = TRUE gtSuperInkey.bArrow = TRUE gtSuperInkey.bCursor = TRUE CASE 156 ' £ gtSuperInkey.sExt = "Unknown:" + STR$ (gtSuperInkey.nExtASC) + " = " + CHR$ (gtSuperInkey.nExtASC) CASE 157 ' ¥ gtSuperInkey.sExt = "Alt+ArrowRight" gtSuperInkey.bAlt = TRUE gtSuperInkey.bArrow = TRUE gtSuperInkey.bCursor = TRUE CASE 158 ' P gtSuperInkey.sExt = "Unknown:" + STR$ (gtSuperInkey.nExtASC) + " = " + CHR$ (gtSuperInkey.nExtASC) CASE 159 ' ƒ gtSuperInkey.sExt = "Alt+End" gtSuperInkey.bAlt = TRUE gtSuperInkey.bCursor = TRUE CASE 160 ' á gtSuperInkey.sExt = "Alt+ArrowDown" gtSuperInkey.bAlt = TRUE gtSuperInkey.bArrow = TRUE gtSuperInkey.bCursor = TRUE CASE 161 ' í gtSuperInkey.sExt = "Alt+PageDown" gtSuperInkey.bAlt = TRUE gtSuperInkey.bCursor = TRUE CASE 162 ' ó gtSuperInkey.sExt = "Alt+Insert" gtSuperInkey.bAlt = TRUE CASE 163 ' ú gtSuperInkey.sExt = "Alt+Delete" gtSuperInkey.bAlt = TRUE CASE 164 ' ñ gtSuperInkey.sExt = "Alt+KeyPadSlash" gtSuperInkey.bAlt = TRUE gtSuperInkey.bKeyPad = TRUE CASE 165 ' Ñ gtSuperInkey.sExt = "Unknown:" + STR$ (gtSuperInkey.nExtASC) + " = " + CHR$ (gtSuperInkey.nExtASC) CASE 166 ' ª gtSuperInkey.sExt = "Alt+KeyPadEnter" gtSuperInkey.bAlt = TRUE gtSuperInkey.bKeyPad = TRUE CASE 167 TO 255 ' unknown character sequences gtSuperInkey.sExt = "Unknown:" + STR$ (gtSuperInkey.nExtASC) + " = " + CHR$ (gtSuperInkey.nExtASC) CASE ELSE gtSuperInkey.sExt = "Unknown Other:" + STR$ (gtSuperInkey.nExtASC) END SELECT ' gtSuperInkey.nExtASC gtSuperInkey.sName = gtSuperInkey.sExt END IF sChar = gtSuperInkey.sChar IF gtSuperInkey.bNull THEN _ sChar = "" superInkey$ = sChar END FUNCTION ' superInkey$ FUNCTION superEntry$ ( _ psDefault AS STRING, _ psLastEntry AS STRING, _ psDelimiters AS STRING, _ pnOptions AS INTEGER, _ pnMaxChars AS INTEGER _ ) ' superEntry$ = Returns text input via keyboard with extended functionality ' psDefault = Default value (initial value and accessed via ArrowDown cursor key) ' psLastEntry = Last Entry (accessed via ArrowUp cursor key) ' psDelimiters = Allowed delimiters to end input (defaults to CR/ENTER) ' pnOptions = Various entry options (power of 2 values -- see SUPER_ENTRY_* options) ' pnMaxChars = Maximum number of characters allowed for entry, zero = unlimited (see SUPER_ENTRY_MAXCR option) ' ' Supported key functions: ' Cursor/Movement: Home, End, Left, Right ' Editing: BACKSPACE, DELETE ' Ctrl+X: Clear entry ' Ctrl+C: Copy whole line to clipboard ' Ctrl+V: Paste clipboard to cursor position ' Ctrl+Z: One-level Undo/Redo toggle ' ' Preserves foreground color ' ' Expects: ' ' Global gtSuperInkey ' global variable defined as a typeSuperInkey TYPE ' ' Global C_CR ' constant Carriage Return (ENTER) ' Global C_BS ' constant Backspace ' Global C_CUR_UP ' constant Cursor Up character string code ' Global C_CUR_DN ' constant Cursor Down character string code ' Global C_CUR_LFT ' constant Cursor Left character string code ' Global C_CUR_RGT ' constant Cursor Right character string code ' CONST SUPER_ENTRY_NOOPT = 0 ' no options selected (powers of 2 that can be OR'ed or added together) ' CONST SUPER_ENTRY_UCASE = 1 ' convert all input alpha to uppercase ' CONST SUPER_ENTRY_SHADO = 2 ' treat default value like shadow text (darker text that disappears when you type) ' CONST SUPER_ENTRY_PASWD = 4 ' password entry mode = show entry chars as asterisks ("*") ' CONST SUPER_ENTRY_MAXCE = 8 ' auto-return when maximum number of characters entered ("full field entry") ' Delimiter is always set to special "MAX" when this occurs ' Other delimiters allowed for "early entry", or blank requires all chars ' ' Calls superInkey$() function ' REQUIRES beepAlert() SUB routine ' REQUIRES CONST FALSE = 0, TRUE = NOT FALSE in global program ' ' Use LOCATE , , 1 or variation to display the cursor for INKEY$ DIM sChar AS STRING ' the entry character from superInkey$ DIM nPosition AS INTEGER ' the current cursor entry position DIM sText AS STRING ' the resultant entered text DIM nStartColumn AS INTEGER ' the start column for first entry character DIM nMaxEntry AS INTEGER ' maximum characters allowed to be entered based on screen width DIM sUndoText AS STRING ' simple undo toggle text DIM sLastKeypress AS STRING ' last key pressed DIM sPaste AS STRING ' working value for paste routine DIM nChar AS INTEGER ' working value for paste routine DIM blnOptUpperCase AS INTEGER ' boolean TRUE/FALSE for uppercase only entry set via options DIM blnOptShadowText AS INTEGER ' boolean TRUE/FALSE for default shadow text set via options DIM blnOptPassword AS INTEGER ' boolean TRUE/FALSE for password * display entry set via options DIM blnOptMaxEntry AS INTEGER ' boolean TRUE/FALSE for maximum char entry auto-return set via options DIM nColor AS INTEGER ' default foreground color upon entry blnOptUpperCase = ((pnOptions AND SUPER_ENTRY_UCASE) <> 0) ' convert all alpha to uppercase blnOptShadowText = ((pnOptions AND SUPER_ENTRY_SHADO) <> 0) ' treat default value as shadow text (reset as mode turn off) blnOptPassword = ((pnOptions AND SUPER_ENTRY_PASWD) <> 0) ' password entry mode = show entry chars as asterisks ("*") blnOptMaxEntry = ((pnOptions AND SUPER_ENTRY_MAXCE) <> 0) ' for maximum char entry auto-return nStartColumn = POS (0) ' starting position of cursor after prompt nColor = _DEFAULTCOLOR ' save current foreground color nMaxEntry = _WIDTH (0) - nStartColumn - 1 ' maximum line entry length is based on window width IF pnMaxChars > 0 THEN ' use Max Chars if specified -- hereafter use the Max Entry value IF nMaxEntry > pnMaxChars THEN _ nMaxEntry = pnMaxChars ' set maximum entry to requested value if non-zero and less than max-max ELSE blnOptMaxEntry = FALSE ' turn off mode if no value set END IF IF psDelimiters = "" AND NOT (blnOptMaxEntry) THEN _ psDelimiters = C_CR ' default to CR/ENTER as delimiter if none specified, UNLESS Max Entry mode IF blnOptShadowText THEN ' show shadow text if requested, maxed to Max Entry length sText = "" ' unnecessary but to make a point COLOR 8 ' dark gray shadow text color IF blnOptPassword THEN PRINT LEFT$ (STRING$ (LEN (psDefault), "*"), nMaxEntry); ELSE PRINT LEFT$ (psDefault, nMaxEntry); END IF COLOR nColor ' restore foreground color ELSE sText = LEFT$ (psDefault, nMaxEntry) ' preset text to default entry, maxed to length IF blnOptPassword THEN PRINT STRING$ (LEN (sText), "*"); ELSE PRINT sText; END IF END IF nPosition = LEN (sText) ' cursor position (0 = start of entry, LEN() = end) DO ' main processing loop sChar = superInkey$ ' get a character or function key IF blnOptUpperCase THEN _ sChar = UCASE$ (sChar) SELECT CASE sChar CASE "" ' no keypress or extended keypress (F5, etc.) sChar = RTRIM$ (gtSuperInkey.sExt) ' get extended character value IF blnOptShadowText AND sChar <> "" THEN ' any keypress turns off shadow text mode LOCATE , nStartColumn PRINT SPACE$ (LEN (psDefault)); blnOptShadowText = FALSE ' turn off mode LOCATE , nStartColumn END IF SELECT CASE sChar CASE "ArrowUp" ' select LAST ENTRY parameter value IF sText <> psDefault AND sLastKeypress <> "ArrowUp" THEN _ sUndoText = sText ' preserve last undo for better undo LOCATE , nStartColumn IF sText <> "" THEN PRINT SPACE$ (LEN (sText)); LOCATE , nStartColumn END IF sText = LEFT$ (psLastEntry, nMaxEntry) IF blnOptPassword THEN PRINT STRING$ (LEN (sText), "*"); ELSE PRINT sText; END IF nPosition = LEN (sText) CASE "ArrowDown" ' select DEFAULT parameter value IF sText <> "" AND sLastKeypress <> "ArrowDown" THEN _ sUndoText = sText ' preserve last undo for better undo LOCATE , nStartColumn IF sText <> "" THEN PRINT SPACE$ (LEN (sText)); LOCATE , nStartColumn END IF sText = LEFT$ (psDefault, nMaxEntry) IF blnOptPassword THEN PRINT STRING$ (LEN (sText), "*"); ELSE PRINT sText; END IF nPosition = LEN (sText) CASE "ArrowLeft" ' cursor left IF nPosition > 0 THEN PRINT C_CUR_LFT; nPosition = nPosition - 1 END IF CASE "ArrowRight" ' cursor right IF nPosition < LEN (sText) THEN PRINT C_CUR_RGT; nPosition = nPosition + 1 END IF CASE "Home" ' go to beginning of line nPosition = 0 LOCATE , nStartColumn CASE "End" ' go to end of line nPosition = LEN (sText) LOCATE , nStartColumn + nPosition CASE "Delete" ' delete char under cursor IF sText <> "" AND sLastKeypress <> "Delete" THEN _ sUndoText = sText ' preserve last undo for better undo IF sText <> "" AND nPosition < LEN (sText) THEN LOCATE , nStartColumn IF nPosition = 0 THEN sText = MID$ (sText, 2) ELSE sText = LEFT$ (sText, nPosition) + MID$ (sText, nPosition + 2) END IF IF blnOptPassword THEN PRINT STRING$ (LEN (sText), "*"); " "; ELSE PRINT sText; " "; END IF LOCATE , nStartColumn + nPosition END IF END SELECT ' sChar (gtSuperInkey.sExt) -- extended character CASE C_BS ' Backspace - delete char to the left of the cursor IF sText <> "" AND sLastKeypress <> C_BS THEN _ sUndoText = sText ' preserve last undo for better undo IF blnOptShadowText THEN ' any keypress turns off shadow text mode LOCATE , nStartColumn PRINT SPACE$ (LEN (psDefault)); blnOptShadowText = FALSE ' turn off mode LOCATE , nStartColumn ELSE IF sText <> "" AND nPosition > 0 THEN LOCATE , nStartColumn sText = LEFT$ (sText, nPosition - 1) + MID$ (sText, nPosition + 1) nPosition = nPosition - 1 IF blnOptPassword THEN PRINT STRING$ (LEN (sText), "*"); " "; ELSE PRINT sText; " "; END IF LOCATE , nStartColumn + nPosition END IF END IF CASE CHR$ (3) ' Ctrl+C -- Copy to copy-paste buffer IF blnOptShadowText THEN _CLIPBOARD$ = psDefault ' doesn't clear shadow entry mode ELSE _CLIPBOARD$ = sText END IF CASE CHR$ (22) ' Ctrl+V -- Paste from copy-paste buffer IF sText <> "" AND sLastKeypress <> CHR$ (22) THEN _ sUndoText = sText ' preserve last undo for better undo IF blnOptShadowText THEN ' any keypress turns off shadow text mode LOCATE , nStartColumn PRINT SPACE$ (LEN (psDefault)); blnOptShadowText = FALSE ' turn off mode LOCATE , nStartColumn END IF IF LEN (sText + _CLIPBOARD$) > nMaxEntry AND NOT (blnOptMaxEntry) THEN ' large paste processing beepAlert LOCATE , nStartColumn IF sText <> "" THEN PRINT SPACE$ (LEN (sText)); LOCATE , nStartColumn END IF COLOR 12 ' bright red sPaste = "Accept large text paste (Y/N)?" IF LEN (sPaste) > nMaxEntry THEN _ sPaste = "Accept (Y/N)?" IF LEN (sPaste) > nMaxEntry THEN _ sPaste = "Accept?" IF LEN (sPaste) > nMaxEntry THEN _ sPaste = "(Y/N)?" IF LEN (sPaste) > nMaxEntry THEN _ sPaste = "?" PRINT sPaste; sChar = UCASE$ (INPUT$ (1)) COLOR nColor ' restore foreground color LOCATE , nStartColumn PRINT SPACE$ (LEN (sPaste)); IF sChar = "Y" THEN sText = _CLIPBOARD$ IF INSTR (psDelimiters, C_CR) > 0 THEN sChar = C_CR ' always use Enter/Carriage Return if available ELSE sChar = LEFT$ (psDelimiters, 1) ' otherwise use first delimiter as default END IF ELSE ' will truncate paste using regular processing below sChar = CHR$ (22) ' restore last keypress -- and allows fall into standard paste processing LOCATE , nStartColumn PRINT sText; " "; LOCATE , nStartColumn + nPosition ' restore entry status END IF END IF IF sChar = CHR$ (22) AND LEN (sText) < nMaxEntry THEN ' proceed if there is at least some space available sPaste = _CLIPBOARD$ nChar = 1 DO ' remove control characters from pasted text IF sPaste <> "" THEN IF ASC (MID$ (sPaste, nChar, 1)) < 32 THEN sPaste = LEFT$ (sPaste, nChar - 1) + MID$ (sPaste, nChar + 1) ELSE nChar = nChar + 1 ' reduction above doesn't increment END IF END IF LOOP WHILE nChar < LEN (sPaste) AND sPaste <> "" IF LEN (sPaste) + LEN (sText) > nMaxEntry THEN _ sPaste = LEFT$ (sPaste, nMaxEntry - LEN (sText)) ' correct paste value if too long sText = LEFT$ (sText, nPosition) + sPaste + MID$ (sText, nPosition + 1) nPosition = nPosition + LEN (sPaste) LOCATE , nStartColumn IF blnOptPassword THEN PRINT STRING$ (LEN (sText), "*"); ELSE PRINT sText; END IF LOCATE , nStartColumn + nPosition ELSE IF sChar = CHR$ (22) THEN _ beepAlert ' alert if not large paste buffer paste END IF CASE CHR$ (24) ' Ctrl+X (erase line) IF sText <> "" AND sLastKeypress <> CHR$ (24) THEN _ sUndoText = sText ' preserve last undo for better undo LOCATE , nStartColumn IF blnOptShadowText THEN ' any keypress turns off shadow text mode PRINT SPACE$ (LEN (psDefault)); blnOptShadowText = FALSE ' turn off mode ELSE PRINT SPACE$ (LEN (sText)); END IF LOCATE , nStartColumn sText = "" nPosition = 0 CASE CHR$ (26) ' Ctrl+Z -- Undo/Redo toggle LOCATE , nStartColumn PRINT SPACE$ (LEN (sText)); LOCATE , nStartColumn SWAP sText, sUndoText IF blnOptPassword THEN PRINT STRING$ (LEN (sText), "*"); ELSE PRINT sText; END IF nPosition = LEN (sText) CASE ELSE ' any other keypress IF gtSuperInkey.nAsc > 31 THEN ' if not an ignored control character (or potential delimiter) IF (sText <> "" AND sLastKeypress <> "KEYPRESS") OR _ (LEN (sText) - LEN (sUndoText) > 5) THEN _ sUndoText = sText ' preserve last undo for better undo (every N chars) IF blnOptShadowText THEN ' any keypress turns off shadow text mode LOCATE , nStartColumn PRINT SPACE$ (LEN (psDefault)); blnOptShadowText = FALSE ' turn off mode LOCATE , nStartColumn END IF IF LEN (sText) <= nMaxEntry THEN sText = LEFT$ (sText, nPosition) + sChar + MID$ (sText, nPosition + 1) nPosition = nPosition + 1 LOCATE , nStartColumn IF blnOptPassword THEN PRINT STRING$ (LEN (sText), "*"); ELSE PRINT sText; END IF LOCATE , nStartColumn + nPosition sChar = "KEYPRESS" ' to set sLastKeypress below ELSE beepAlert ' maximum chars entered, no more entry allowed END IF END IF ' if not a control char (or potential delimiter) IF blnOptMaxEntry AND blnOptShadowText AND sChar = C_CR THEN ' special selection of shadow text blnOptShadowText = FALSE ' turn off mode sText = LEFT$ (psDefault, nMaxEntry) LOCATE , nStartColumn PRINT sText; nPosition = LEN (sText) ' set status in case default value length is too short END IF END SELECT ' sChar _LIMIT 30 ' slow down loop processing IF sChar <> "" THEN _ sLastKeypress = sChar LOOP UNTIL (sChar <> "" AND INSTR (psDelimiters, sChar) > 0) OR _ (blnOptMaxEntry AND LEN (sText) = nMaxEntry) IF blnOptShadowText THEN ' if mode was never reset, clear display LOCATE , nStartColumn PRINT SPACE$ (LEN (psDefault)); LOCATE , nStartColumn END IF IF blnOptMaxEntry AND LEN (sText) = nMaxEntry THEN _ sChar = "MAX" ' special delimiter for max chars entered psDelimiters = sChar ' return the delimiter that ended input superEntry$ = sText END FUNCTION ' superEntry$ ' end of program