Second half of code.
;;;==========================================================
;;; Make password dialog box on the fly in temp folder
;;;==========================================================
(defun ABC_MakeTempDcl (/ file)
(setq file (open (strcat (getenv "TEMP") "\\" "~getpass.dcl") "w"))
(write-line "// GETPASS.DCL" file)
(write-line "//" file)
(write-line "passdlg : dialog {" file)
(write-line " label = \"Password to Authorize ABC Routines\";" file)
(write-line " : row {" file)
(write-line " : radio_column {" file)
(write-line " : radio_button {" file)
(write-line " key = \"network\";" file)
(write-line " label = \"Network Installation\";" file)
(write-line " }" file)
(write-line " : radio_button {" file)
(write-line " key = \"offsite\";" file)
(write-line " label = \"Offsite Installation\";" file)
(write-line " }" file)
(write-line " } //column" file)
(write-line " } //end :row" file)
(write-line " : edit_box {" file)
(write-line " label = \"Password:\";" file)
(write-line " edit_width = 20;" file)
(write-line " key = \"password\";" file)
(write-line " password_char = \"*\";" file)
(write-line " is_default = true;" file)
(write-line " }" file)
(write-line " ok_cancel;" file)
(write-line "}" file)
(close file)
)
;;;==========================================================
;;; Dialog to bring up options for authorization
;;; with password, intended for first time set up of
;;; AutoCAD only, dialog should be skipped after that
;;;==========================================================
(defun ABC_GETPASS (/ dcl_id pass auth return)
(ABC_MakeTempDcl)
(setq auth "network") ;set default
(setq dcl_id (load_dialog (strcat (getenv "TEMP") "\\" "~getpass.dcl")))
(if (new_dialog "passdlg" dcl_id)
(progn (set_tile "network" "1")
(action_tile "network" "(setq auth \"network\")")
(action_tile "offsite" "(setq auth \"offsite\")")
(action_tile "password" "(setq pass $value)")
(mode_tile "password" 2) ; set focus
(start_dialog)
(unload_dialog dcl_id)
) ;_ progn
(princ "Error: Unable to load GETPASS.DCL. ")
) ;_ if
;;(if (setq file (findfile "~getpass.dcl"))(vl-file-delete file))
;; Authorize ABC routines with encrypted registry code
(cond ((and (= "network" auth)(= "CAVEman" pass))
(ABC_Authorize "CAVEman" "Full Network Permissions")
(setq return T) ;return flag for success
)
;; for offsite, if password date range and current date match
;; authorize routines with encrypted code & password
((and (= "offsite" auth)(ABC_AuthCheckOffsite pass))
(ABC_Authorize "CAVEman" (strcat "Temporary Offsite Permissions:" pass))
(setq return T) ;return flag for success
)
) ;_ cond
return
) ;_ defun
;;;==========================================================
;;; Check for ABC Routines authorized with encrypted registry entry
;;; Decodes with local (MAC Address) code & also ABC cypher to ensure
;;; that registry entry is unique to each machine (can't be copied)
;;; Returns string type of authorization or nil for failure
;;;==========================================================
(defun ABC_AuthorizationCheck (/ auth dosv dauth return cpos ofpass)
(and (setq dosv (dos_version)) ;verify doslib version
(>= 6 (atoi dosv))
;; get encrypted authorizationcode
(setq auth (dos_regget "HKEY_LOCAL_MACHINE\\Software\\ABC" "AuthCode")) ;get auth code from registry
;; decrypt code
(setq dauth (ABC_DecryptStr_local (ABC_DecryptStr255 auth))) ;decrypt it
(or (if (= dauth "Full Network Permissions") ;if it is network
(setq return "Network") ;return network permission
) ;_ if
(and (setq cpos (vl-string-position 58 dauth)) ;or offsite - look for colon separating offsite password
(setq ofpass (substr dauth (+ 2 cpos))) ;with password after colon
(if (ABC_AuthCheckOffsite ofpass) ;verify with offsite list
(setq return "Offsite") ;return offsite permission
) ;_ if
) ;_ and
) ;_ or
) ;_ and
return
) ;_ defun
;;;==========================================================
;;; Verify offsite password with date list and current date
;;; returns T for good
;;; returns nil for invalid password
;;; alerts for for valid out of date password,and returns nil
;;;==========================================================
(defun ABC_AuthCheckOffsite (pass / pwdlst pdatelst stdate enddate cdate newestini inidate return)
;;; association list of offsite passwords with range of valid dates
(setq pwdlst ;ABC_OffsitePasswordList
(list (list "aardwolves" (list 20030701 20031231))
(list "test" (list 20030926 20030927))
(list "gelatinize" (list 20040101 20040631))
(list "lutestring" (list 20040701 20041231))
(list "rottweiler" (list 20050101 20050631))
(list "picaresque" (list 20050701 20051231))
(list "flugelhorn" (list 20060101 20060631))
(list "beleaguers" (list 20060701 20061231))
(list "zymologies" (list 20070101 20070631))
(list "nonathlete" (list 20070701 20071231))
(list "martensite" (list 20080101 20080631))
(list "firstlings" (list 20080701 20081231))
) ;_ list
) ;_ setq
(if (setq pdatelst (assoc pass pwdlst)) ;if password is in list
(progn
(setq stdate (caadr pdatelst) ;get start date
enddate (cadadr pdatelst) ;get end date
cdate (getvar "cdate") ;get current date
;; get newest ini file in the windows directory
newestini (car (dos_dir (strcat (dos_windir) "*.ini") 4))
;; get date of file
inidate (ABC_getfiledate (strcat (dos_windir) newestini))
)
(if (and (< stdate cdate enddate) ;if current date is in range
(< inidate (+ cdate 0.01)) ; and current date is older than newest ini file
; (adjusted an hour ahead to deal with daylight savings
)
(progn
(setq return T) ; set return flag ok
;; (> 3 (- 20030927 (getvar "cdate")))
(if (and (> 3 (- enddate cdate)) ;if expires in less than three days
(not (vl-bb-ref '*ABCExpireWarn*)) ;check session flag if user already warned
) ;_and
(progn
(alert (strcat "Note: ABC Routines about to expire!" ;warn
"\n\nContact ABC Architects for new password."
) ;_strcat
) ;_alert
(vl-bb-set '*ABCExpireWarn* T) ;set session flag that user has been warned
) ;_progn
) ;_if
) ;_progn
(progn
(alert "Password has expired - quitting") ; else warn expired
(dos_regset "HKEY_LOCAL_MACHINE\\Software\\ABC" "AuthCode" "") ;clear code
)
) ;_if
) ;_progn
) ;_if
return
) ;_defun
;;;==========================================================
;;; Authorizes ABC routines
;;; with encrypted registry entry
;;;==========================================================
(defun ABC_Authorize (password authd / auth)
(if (= "CAVEman" password)
(progn (setq auth (ABC_EncryptStr255 (ABC_EncryptStr_local authd))
) ;_ setq
(dos_regset "HKEY_LOCAL_MACHINE\\Software\\ABC" "AuthCode" auth)
) ;_ progn
) ;_ if
) ;_ defun
;;;==========================================================
;;; Actions to run when ABC_Cypher.lsp is loaded
;;;==========================================================
;;; Check if routines authorized
(if (not (ABC_AuthorizationCheck))
;; Not authorized, bring up dialog for password & authorization
;; if dialog unsuccessful, then abort
(if (not (ABC_GetPass))
(progn (alert "\nIncorrect password!\nQuitting ABC Routines.")
;; probably paranoid, but on failure,
;; clear all encryption routines from memory
(setq ABC_SubList nil
ABC_SubList nil
ABC_RepeatStringLen nil
ABC_IntShiftBaseUp nil
ABC_IntShiftBaseDown nil
ABC_EncryptStr_Local nil
ABC_DecryptStr_Local nil
ABC_EncryptStr255 nil
ABC_DecryptStr255 nil
*ABC-Cypher255* nil
*ABC-Cypher36* nil
ABC_MakeTempDcl nil
ABC_GETPASS nil
ABC_AuthorizationCheck nil
ABC_AuthorizeNetwork nil
ABC_Authorizeoffsite nil
ABC_AuthCheckOffsite nil
ABC_OffsitePasswordList nil
) ;_ setq
(exit)
) ;_ progn
) ;_ if
) ;_ if
;;;==========================================================
;;; define shortform authorization for other routines to check
;;; just returns "abracadabra" for authorized, else nil
;;; other checks for type of authorization must use ABC_AuthorizationCheck
;;;==========================================================
(defun ABC_Authorization (password)(if (= password "CAVEman") "abracadabra"))
(if ABCdebug (princ "\nFinished ABC_Cypher.lsp"))
(princ)
;;;==========================================================
;;;==========================================================
;;;==========================================================
;;;==========================================================
;;;==========================================================
;;; Development work and source info below
;|
(defun test ()
(setq t1 (ABC_EncryptStr255 "All good dogs go to heaven, 1908234, (*!@!@(*&"))
(setq t1dec (vl-string->list t1))
(setq t2 (ABC_DecryptStr255 t1))
(setq t2dec (vl-string->list t2))
)
(defun c:t1 ()
(setq t1 (getstring "\nText to encode: "))
(setenv "ABC\\Test" (ABC_EncryptStr255 t1))
(princ)
)
(defun c:t2 ()
(princ (ABC_DecryptStr255 (getenv "ABC\\Test")))
)
(defun c:t3 ()
(setq t1 (getstring "\nText to encode: "))
(setenv "ABC\\Test" (ABC_EncryptStr255 (ABC_EncryptStr255_mac t1)))
(princ)
)
(defun c:t4 ()
(princ (ABC_DecryptStr255_mac (ABC_DecryptStr255 (getenv "ABC\\Test"))))
)
;;; convert date to list of ascii characters
(setq t1 (vl-string->list (menucmd "M=$(edtime, $(getvar, date),YYMODD)")))
;(48 51 48 57 48 57)
;;; convert numbers to hex?
;(mapcar '(lambda(x) (atoi (std-num->hex x))) (vl-string->list (menucmd "M=$(edtime, $(getvar, date),YYMODD)")))
;(30 33 30 39 30 38)
;;; get semi unique computer id - network address number
;(dos_macaddress)
;"00:01:02:C7:70:28"
;;; convert to list &
;;; convert hex to decimal
(setq t2 (mapcar '(lambda(x) (std-hex->num x)) (dos_strtokens (dos_macaddress) ":" T)))
;(0 16 181 250 88 249)
;; test encrypt date (t1) with MACAddress (t2)
(setq t3 (mapcar '(lambda (x y) (ABC_IntShiftBaseUp x y 255)) t1 t2))
;(48 67 229 52 136 51)
;; test decryption of date (reverse)
(setq t4 (mapcar '(lambda (x y) (ABC_IntShiftBaseDown x y 255)) t3 t2))
;(48 51 48 57 48 57)
|;
;|
;;; From: rurban@sbox.tu-graz.ac.at (rurban@sbox.tu-graz.ac.at)
;;; Subject: Re: Need Encryption Algorythm in AutoLisp
;;; Newsgroups: autodesk.autocad.customization
;;; Date: 1998/08/23
;;;
;;; the trick is using a VERY long cypher which is not transported together with
;;; the encrypted string.
;;;
;;; how to splice a char of 255 states into a char of 36 states?
;;; this could be possible with some heavy compression techniques (huffmann or lzw
;;; for example) but if it works for every string is not guaranteed and cannot be
;;; generally guaranteed.
;;;
;;; 3) if we assume that the string to be encrypted is of the same order as
;;; the resulting string (36 valid chars) it is very easy and unbreakable by
;;; generating a long sequence of random characters and encryptr your string
;;; with the random cypher-string as generator. xor is enough. and use a simple
;;; alphabet to map the result onto the valid charset.
;;;
;;; Strings to be encrypted must be alpha-numberic, no spaces or symbols
;; generate the cypher, this should be quite long and not
;; transported together with with the code!
(defun init-cypher (len / s i)
(setq *cypher* nil)
(setq *encypher-pos* 0)
(setq *decypher-pos* 0)
(setq *cypher-len* len)
(repeat len
(setq *cypher* (cons (ABC_random 36) *cypher*)))
)
;;; map the decrypted char [0-9],[A-Z] to int 65-101,
;;; force uppercase,
;;; result is guaranteed to be in [65-101]
(defun enmap-char (c / i)
(setq i (ascii c))
(if (<= 97 i 122) (setq i (- i 32))) ; force upcase
(if (<= 48 i 57) (setq i (+ i 43))) ; 0-9 above Z
(+ 65 (rem (abs (- i 65)) 36)) ; force interval 65-101
)
;;; map the encrypted int 65-101 to [0-9],[A-Z]
;;; result is a one-char string in [0-9][A-Z]
(defun demap-char (i)
(chr (cond ((<= 65 i 90) i)
((> i 90) (- i 43)))
))
(defun encrypt-string (s / i l crypt)
(setq l (strlen s)
i 1
crypt ""
) ;_ setq
(while (<= i l)
(setq crypt (strcat crypt
(demap-char
(encypher-fun
(enmap-char (substr s i 1))
(nth *encypher-pos* *cypher*)
) ;_ encypher-fun
) ;_ demap-char
) ;_ strcat
i (1+ i)
*encypher-pos* (rem (1+ *encypher-pos*) *cypher-len*)
) ;_ setq
) ;_ while
crypt
) ;_ defun
(defun decrypt-string (s / i l crypt)
(setq l (strlen s)
i 1
crypt ""
) ;_ setq
(while (<= i l)
(setq crypt (strcat crypt
(demap-char
(decypher-fun
(enmap-char (substr s i 1))
(nth *decypher-pos* *cypher*)
) ;_ decypher-fun
) ;_ demap-char
) ;_ strcat
i (1+ i)
*decypher-pos* (rem (1+ *decypher-pos*) *cypher-len*)
) ;_ setq
) ;_ while
crypt
) ;_ defun
;; use simple shifting by the cypher:
; x: 65-101, y: 0-35 => 65-101
; (ENCYPHER-FUN 78 33) => 75
(defun encypher-fun (x y)
(+ 65 (rem (+ (- x 65) y) 36)))
; x: 65-101, y: 0-35 => 65-101
; (DECYPHER-FUN 75 33) => 78 ??
(defun decypher-fun (x y)
(while (< (- x y) 65)
(setq x (+ x 36)))
(- x y))
(defun cyphertest ()
(init-cypher 1000)
(setq s1 "einkleinenachtmusik123")
(setq s2 "undnocheine987")
(print s1)(princ " => ")
(princ (setq es1 (encrypt-string s1)))
(print s2)(princ " => ")
(princ (setq es2 (encrypt-string s2)))
(print (decrypt-string es1))
(print (decrypt-string es2))
(prin1)
)
|;
;|
"einkleinenachtmusik123" => N95PPUZGQUOBK9BQ1JTQOI
"undnocheine987" => 1VZTEZHNXPNZC6
"EINKLEINENACHTMUSIK123"
"UNDNOCHEINE987"
|;
