Menu
▾
▴
win32forth-cvs
|
From: Dirk B. <db...@us...> - 2006-09-24 08:42:09
|
Update of /cvsroot/win32forth/win32forth-stc/src In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv13537/src Modified Files: extend.f primutil.f Added Files: ANSFILE.F Log Message: AnsFile.f added Index: primutil.f =================================================================== RCS file: /cvsroot/win32forth/win32forth-stc/src/primutil.f,v retrieving revision 1.3 retrieving revision 1.4 diff -C2 -d -r1.3 -r1.4 *** primutil.f 23 Sep 2006 15:49:12 -0000 1.3 --- primutil.f 24 Sep 2006 08:42:06 -0000 1.4 *************** *** 200,207 **** r> to sys-warning? throw ; immediate ! \s \ needed by ansfile; uncomment \s to load ansfile (I tested it at home with my own \ primutil.f and hopefully merged everything correctly but can't test @ work so any \ other corrections will have to wait til mon 23/9/6 gah. \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ --- 200,208 ---- r> to sys-warning? throw ; immediate ! \ needed by ansfile; uncomment \s to load ansfile (I tested it at home with my own \ primutil.f and hopefully merged everything correctly but can't test @ work so any \ other corrections will have to wait til mon 23/9/6 gah. + \ It's seem's to work for me, so I have added ansfile.f to the CVS (Sonntag, September 24 2006 dbu) \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ --- NEW FILE: ANSFILE.F --- \ $Id: ANSFILE.F,v 1.1 2006/09/24 08:42:06 dbu_de Exp $ \ *P These words are extensions to the ANSI file words for finding files. \ The ANSI words are defined in the kernel. \ \ The words defined in this file follow the draft proposed AMERICAN \ NATIONAL Standard for Information System - Programing Language - Forth \ - June 30, 1993 \ \ ** If ior = 0, operation is O.K.; Otherwse, it is a failure. \ ansfile.f beta 2.0A 2002/08/31 arm windows ANS file words \ ansfile.f beta 2.9G 2002/09/24 arm release for testing \ ansfile.f beta 3.3D 2002/10/08 arm Consolidation \ made thread-safe Saturday, August 07 2004 - 0:15 gah cr .( Loading ANSI File Wordset...) only forth also definitions 5 PROC GetDiskFreeSpace 2 PROC FindFirstFile 2 PROC FindNextFile 1 PROC FindClose 3 PROC FileTimeToDosDateTime 4 PROC GetFileTime 2 PROC FileTimeToSystemTime cell newuser _hdl-search ( -- addr ) \ *G Variable holding handle. _hdl-search off cell newuser #files \ number of files found cell newuser total-file-bytes \ total bytes in files found 11 cells max-path + 14 + nostack1 newuser _win32-find-data \ struct FindFileFirst or \ FindNextFile Functions \ 0 , \ dwFile Attributees \ 0 , 0 , \ ftCreationTime - FILETIME - \ \ (struct) dwLowDateTime \ \ dwHighDateTime \ 0 , 0 , \ ftLastAccessTime - FILETIME \ 0 , 0 , \ ftLastWriteTime - FILETIME \ 0 , \ nFileSizeHigh \ 0 , \ nFileSizeLowh \ 0 , \ dwReserved0 \ 0 , \ dwReserved1 \ MAX-PATH allot \ cFileName[MAX_PATH] \ 14 allot \ cAlternateFileNane[14] 2 newuser ptr-DOS-date \ ptr to 16 bit DOS date 2 newuser ptr-DOS-time \ ptr to 16 bit DOS time 16 Constant sizeof(_systemTime) 0 newuser _systemtime \ *G Structure FileTimeToSystemTime \ ** function; this struc is same as time-buf in kernel.tom 2 newuser wYear 2 newuser wMonth 2 newuser wDayOfWeek 2 newuser wDay 2 newuser wHour 2 newuser wMinute 2 newuser wSecond 2 newuser wMilliseconds : get-fspace { zroot \ clus freclus b/sec s/clus -- as bs cs ds } \ *G Get a drive's free space, cluster and sector information \ ** "zroot" is the root directory spec zString for the desired drive in the \ ** format z" x:\", where x can be a, b, c, d or e etc... &of clus \ lpClusters - bs &of freclus \ lpFreeClusters - as &of b/sec \ loBytesPerSector - ds &of s/clus \ lpSectorsPerCluster - cs zroot \ lpszRootPathName call GetDiskFreeSpace if freclus clus \ as bs - s/clus b/sec \ as bs cs ds - else 0 0 0 0 \ 0 0 0 0 - for failure then ; : find-first-file ( addr1 len1 -- addr2 ior ) \ *G addr1 len1 is a string that specifies a valid directory or path \ ** and filename, which can contain wildcard characters (* and ?). \ ** This string must not exceed MAX_PATH characters. \ ** addr2 is the address of the _win32-find-data structure. \ ** ior is 0 for success in which case _hdl-search contains a valid handle. \ *P Find-First-File searches a directory for a file whose name matches the \ ** specified filename. Find-First-File examines subdirectory names as well as filenames. \ *P Find-First-File opens a search handle and returns information about the first \ ** file whose name matches the specified pattern. Once the search handle is established, you \ ** can use Find-Next-File to search for other files that match the same pattern. \ ** When the search handle is no longer needed, close it by using Find-Close. \ ** Find-First-File searches for files by name only; it cannot be used for attribute-based \ ** searches. max-path malloc dup>r ascii-z \ adrz - _win32-find-data \ lpffd - _WIN32_FIND_DATA swap \ lpszSourceFile call FindFirstFile \ a search handle(hdl if O.K. \ else INVALID_HANDLE_VALUE) _hdl-search ! \ store to the search handle _win32-find-data \ adrd - _hdl-search @ -1 = \ adrd ior - 0 = success r> release ; \ free buff : find-next-file ( -- addr ior ) \ *G Find-first-file word must be called \ ** before this word can be called due to the fact that _hdl-search is needed _win32-find-data \ lpffd - _WIN32_FIND_DATA _hdl-search @ \ hFindFile call FindNextFile \ ior - _win32-find-data \ ior adrd - swap 0= ; \ adrd ior - 0 = success : find-close ( -- ior ) \ *G Close the _hdl-search handle. _hdl-search @ call FindClose 0= ; \ ior - 0 = success internal : (DOSTime) ( n -- ) ptr-DOS-time ptr-DOS-date rot \ ptr's to 16 bit DOS time & date _win32-find-data swap cells+ call FileTimeToDosDateTime drop ; external : get-DOS-create-datetime ( -- ;convert 64 bit file time to MS_DOS ) \ date and time values \ need to call find-first-file or find-next-file word \ before using this word 1 (DOSTime) ; : get-DOS-access-datetime ( -- ;convert 64 bit file time to MS_DOS ) \ date and time values \ need to call find-first-file or find-next-file word \ before using this word 3 (DOSTime) ; : get-DOS-write-datetime ( -- ;convert 64 bit file time to MS_DOS ) \ date and time values \ need to call find-first-file or find-next-file word \ before using this word 5 (DOSTime) ; : get-file-size ( -- size ) \ need to call find-first-file or find-next-file word \ before using this word _win32-find-data 8 cells+ @ ; : get-file-name ( -- adr; address for file name ) \ need to call find-first-file or find-next-file word \ before using this word _win32-find-data 11 cells+ ; : dir-attribute? ( - flag ) \ *G Returns true when a file is a directory. \n \ ** Need to call find-first-file or find-next-file word before using this word. \n \ ** Can be used in combination with ForAllFileNames _win32-find-data @ FILE_ATTRIBUTE_DIRECTORY and ; 2 cells newuser file-time-buf \ *G 2Variable to hold the FILETIME structure, which is a little endian (i.e. reversed order) \ ** 64-bit value representing the number of 100-nanosecond intervals since January 1, 1601. : get-file-modified ( fileid -- system-time ) >r file-time-buf 2 cells erase \ pre-clear buffer file-time-buf \ address of where to put the file's \ last written time and date 0 \ last access time not needed 0 \ creation time not needed r> call GetFileTime drop _systemtime \ where to put results file-time-buf \ file time/date to convert call FileTimeToSystemTime drop _systemtime ; : filetime-to-systemtime ( cell# -- ; convert file time to system time ) \ need to call find-first-file or find-next-file word \ before using this word \ cell# is offset in number of cells to _win32-find-data \ 1 for creation time; 3 for access time; and 5 for write time \ normaly 5 should be used >r \ cell# -> rstack _systemtime \ struct FileTimeToSystemTime \ function _win32-find-data r> cells+ \ struct FILETIME for \ ftWriteTime call FileTimeToSystemTime drop ; ' zcount alias asciiz->asc-len ( adrz -- sadr slen ) : dir->file-name ( -- adr count ) \ *G Returns the adres and count of a file in a directory. \n \ ** Need to call find-first-file or find-next-file word before using this word. \n \ ** Can be used in combination with ForAllFileNames get-file-name zcount ; : ForAllFileNames { cfa } ( adr slen cfa -- ) \ *G Executes the CFA for each found file in a directory. \n \ ** A file specification adr slen may contain wildcards \n \ ** NOTE: Directory names are also considered to be a file-name. \n \ ** Directory names can be detected by dir-attribute? 0 #files ! \ reset # of files in dir find-first-file nip \ adrd ior - find first file 0 <> if exit then \ if file is not found, exit dir->file-name get-file-name 0> if cfa execute 1 #files +! else 2drop then begin find-next-file nip 0= \ ior - find next file while get-file-name 0> if 1 #files +! dir->file-name cfa execute then repeat find-close drop ; : ForAllFiles ( cfa -- ) \ *G Executes the CFA on ALL found files in a directory. \n \ ** NOTE: Directory names are also considered to be a file-name. \n \ ** Directory names can be detected by dir-attribute? \n s" *.*" rot ForAllFileNames ; IN-SYSTEM : .dir->file-name ( -- ;print file name in the dir ) _win32-find-data 11 cells+ \ adrz zcount \ adrz scan-len slen dup>r type \ adrz len ;print file name 12 r> - 0max spaces ; deprecated : .dir->file-size ( -- ) \ *G Print the size or directory indication of a file \n \ ** Need to call find-first-file or find-next-file word before using this word. \n \ ** Can be used in combination with ForAllFileNames dir-attribute? if ." dir " else get-file-size dup 12 u,.r space \ print nFileSizeLow total-file-bytes +! then ; : _print-dir-files ( adr slen -- ) 0 total-file-bytes ! 0 #files ! \ reset # of files in dir find-first-file nip \ adrd ior - find first file 0 <> if exit then \ if file is not found, exit cr .dir->file-size \ print the size of file .dir->file-name \ print the filename found 1 #files +! \ update file number BEGIN find-next-file nip 0= \ ior - find next file WHILE 1 #files +! \ update file number 25 ?cr .dir->file-size \ print the size of file .dir->file-name \ and the name of file start/stop REPEAT ; deprecated : .file-size-name ( adr len - ) \ *G Print the size or directory indication and the name of file. \ ** It also formats the line. \n \ ** Need to call find-first-file or find-next-file word before using this word. \n \ ** Can be used in combination with ForAllFileNames 25 ?cr .dir->file-size dup>r type 12 r> - 0max spaces start/stop ; : print-dir-files ( adr slen -- ) \ W32F Files Extra \ *G Print all the files and sub-directories in a directory that match a specific \ ** pattern. cr ." Directory of: " 2dup type cr 0 total-file-bytes ! \ reset total-file-bytes 0 #files ! \ reset # of files in dir ['] .file-size-name ['] ForAllFileNames catch IF 3drop \ discard abort results THEN cr #files @ . ." Files displayed, using " total-file-bytes @ 1 u,.r ." bytes of disk." ; : dir ( "name" -- ) \ W32F Files Extra \ *G Print all the files and sub-directories in a directory that match a specific \ ** pattern. \n \ ** If "name" is missing or ends in \ search for all files that match *.* \n \ ** If "name" contains a relative path then it's relative to the current directory. \n \ ** If "name" ends in : assume a drive use "name"\*.* for the search pattern. \n \ *P The pattern can contain the standard Windows wildcards. /parse-word dup c@ 0= \ if not spec given, use *.* IF s" *.*" pocket place THEN dup count + 1- c@ ':' = \ if just a drive, add \ IF s" \" pocket +place THEN dup count + 1- c@ '\' = \ if it ends in a \, add *.* IF s" *.*" pocket +place THEN count print-dir-files ; : do-rename-afile { RenamePart1$ RenamePart2$ \ RenameTemp$ -- } \ rename one file MAXSTRING LocalAlloc: RenameTemp$ _win32-find-data 11 CELLS+ \ adrz zcount \ adrz -- adr len 2dup 2dup RenamePart1$ count caps-search IF 2dup 2>r nip - RenameTemp$ place \ leading part RenamePart2$ count RenameTemp$ +place 2r> RenamePart1$ c@ /string RenameTemp$ +place RenameTemp$ count rename-file ( adr1 len adr2 len -- ior=0=OK ) 0= IF 1 #files +! \ update file number THEN ELSE 4drop 2drop THEN ; : rename ( -<name1 part1 part2>- ) \ rename file or files { \ RenameFrom$ RenamePart1$ RenamePart2$ -- } MAXSTRING LocalAlloc: RenameFrom$ MAXSTRING LocalAlloc: RenamePart1$ MAXSTRING LocalAlloc: RenamePart2$ /parse-s$ count RenameFrom$ place /parse-s$ count RenamePart1$ place /parse-s$ count RenamePart2$ place RenameFrom$ c@ 0> RenamePart1$ c@ 0> and RenamePart2$ c@ 0> and 0= IF beep cr ." Usage:" cr ." RENAME <filespec> <oldsubstring> <newsubstring>" EXIT \ leave if no names specified THEN cr ." Rename Files: " RenameFrom$ count type ." from: " RenamePart1$ count type ." To: " RenamePart2$ count type 0 #files ! \ reset # of files in dir RenameFrom$ count find-first-file nip 0= \ adrd ior - find first file IF RenamePart1$ RenamePart2$ do-rename-afile BEGIN find-next-file nip 0= \ ior - find next file WHILE RenamePart1$ RenamePart2$ do-rename-afile REPEAT find-close drop cr #files @ . ." Files renamed" ELSE cr ." No matching files Found" \ if file is not found, exit THEN ; IN-APPLICATION module \ *Z Index: extend.f =================================================================== RCS file: /cvsroot/win32forth/win32forth-stc/src/extend.f,v retrieving revision 1.4 retrieving revision 1.5 diff -C2 -d -r1.4 -r1.5 *** extend.f 23 Sep 2006 10:18:34 -0000 1.4 --- extend.f 24 Sep 2006 08:42:03 -0000 1.5 *************** *** 27,30 **** --- 27,31 ---- FLOAD src\console\keyboard.f \ function and special key constants FLOAD src\console\lineedit.f \ a line editor utility + FLOAD src\ansfile.f \ ansi file words .olly *************** *** 33,37 **** \s - \ FLOAD src\lineedit.f \ a line editor utility \ FLOAD src\primhash.f \ primitive hash functions for OOP later *** to be done *** --- 34,37 ---- *************** *** 55,60 **** \ FLOAD src\scrnctrl.f \ screen control words FLOAD src\registry.f \ Win32 Registry support - FLOAD src\ansfile.f \ ansi file words - FLOAD src\keyboard.f \ function and special key constants FLOAD src\mapfile.f \ Windows32 file into memory mapping words sys-FLOAD src\environ.f \ environment? support --- 55,58 ---- |
×
Want the latest updates on software, tech news, and AI?
Get latest updates about software, tech news, and AI from SourceForge directly in your inbox once a month.
Thanks for helping keep SourceForge clean.
X