mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-06-03 07:39:21 +02:00
* working w32 rtl
This commit is contained in:
peter
parent
504b4faf62
commit
cb3365a5ac
@ -105,14 +105,16 @@ unit base;
|
||||
CALTYPE = cardinal;
|
||||
CALID = cardinal;
|
||||
CCHAR = char;
|
||||
WCHAR = word;
|
||||
COLORREF = cardinal;
|
||||
DWORD = cardinal;
|
||||
THandle = cardinal;
|
||||
|
||||
DWORDLONG = double;
|
||||
PDWORDLONG = ^DWORDLONG;
|
||||
FLOAT = single;
|
||||
|
||||
HANDLE = pointer;
|
||||
HANDLE = THandle;
|
||||
HACCEL = HANDLE;
|
||||
HBITMAP = HANDLE;
|
||||
HBRUSH = HANDLE;
|
||||
@ -514,12 +516,7 @@ end.
|
||||
|
||||
{
|
||||
$Log$
|
||||
Revision 1.3 1998-05-06 12:36:50 michael
|
||||
+ Removed log from before restored version.
|
||||
Revision 1.4 1998-06-10 10:39:11 peter
|
||||
* working w32 rtl
|
||||
|
||||
Revision 1.2 1998/03/27 00:50:22 peter
|
||||
* small fixes so it compiles
|
||||
|
||||
Revision 1.1.1.1 1998/03/25 11:18:46 root
|
||||
* Restored version
|
||||
}
|
||||
|
||||
@ -37,43 +37,43 @@
|
||||
|
||||
Unimplemented:
|
||||
/* EnumResLangProc */
|
||||
#define RT_ACCELERATOR (MAKEINTRESOURCE(9))
|
||||
#define RT_BITMAP (MAKEINTRESOURCE(2))
|
||||
#define RT_DIALOG (MAKEINTRESOURCE(5))
|
||||
#define RT_FONT (MAKEINTRESOURCE(8))
|
||||
#define RT_FONTDIR (MAKEINTRESOURCE(7))
|
||||
#define RT_MENU (MAKEINTRESOURCE(4))
|
||||
#define RT_RCDATA (MAKEINTRESOURCE(10))
|
||||
#define RT_STRING (MAKEINTRESOURCE(6))
|
||||
#define RT_MESSAGETABLE (MAKEINTRESOURCE(11))
|
||||
#define RT_CURSOR (MAKEINTRESOURCE(1))
|
||||
#define RT_GROUP_CURSOR (MAKEINTRESOURCE(12))
|
||||
#define RT_ICON (MAKEINTRESOURCE(3))
|
||||
#define RT_GROUP_ICON (MAKEINTRESOURCE(13))
|
||||
#define RT_VERSION (MAKEINTRESOURCE(16))
|
||||
#define RT_ACCELERATOR (MAKEINTRESOURCE(9))
|
||||
#define RT_BITMAP (MAKEINTRESOURCE(2))
|
||||
#define RT_DIALOG (MAKEINTRESOURCE(5))
|
||||
#define RT_FONT (MAKEINTRESOURCE(8))
|
||||
#define RT_FONTDIR (MAKEINTRESOURCE(7))
|
||||
#define RT_MENU (MAKEINTRESOURCE(4))
|
||||
#define RT_RCDATA (MAKEINTRESOURCE(10))
|
||||
#define RT_STRING (MAKEINTRESOURCE(6))
|
||||
#define RT_MESSAGETABLE (MAKEINTRESOURCE(11))
|
||||
#define RT_CURSOR (MAKEINTRESOURCE(1))
|
||||
#define RT_GROUP_CURSOR (MAKEINTRESOURCE(12))
|
||||
#define RT_ICON (MAKEINTRESOURCE(3))
|
||||
#define RT_GROUP_ICON (MAKEINTRESOURCE(13))
|
||||
#define RT_VERSION (MAKEINTRESOURCE(16))
|
||||
|
||||
/* GetIconInfo */
|
||||
#define IDC_ARROW (MAKEINTRESOURCE(32512))
|
||||
#define IDC_IBEAM (MAKEINTRESOURCE(32513))
|
||||
#define IDC_WAIT (MAKEINTRESOURCE(32514))
|
||||
#define IDC_CROSS (MAKEINTRESOURCE(32515))
|
||||
#define IDC_UPARROW (MAKEINTRESOURCE(32516))
|
||||
#define IDC_SIZENWSE (MAKEINTRESOURCE(32642))
|
||||
#define IDC_SIZENESW (MAKEINTRESOURCE(32643))
|
||||
#define IDC_SIZEWE (MAKEINTRESOURCE(32644))
|
||||
#define IDC_SIZENS (MAKEINTRESOURCE(32645))
|
||||
#define IDC_SIZEALL (MAKEINTRESOURCE(32646))
|
||||
#define IDC_NO (MAKEINTRESOURCE(32648))
|
||||
#define IDC_APPSTARTING (MAKEINTRESOURCE(32650))
|
||||
#define IDC_HELP (MAKEINTRESOURCE(32651))
|
||||
#define IDI_APPLICATION (MAKEINTRESOURCE(32512))
|
||||
#define IDI_HAND (MAKEINTRESOURCE(32513))
|
||||
#define IDI_QUESTION (MAKEINTRESOURCE(32514))
|
||||
#define IDI_EXCLAMATION (MAKEINTRESOURCE(32515))
|
||||
#define IDI_ASTERISK (MAKEINTRESOURCE(32516))
|
||||
#define IDI_WINLOGO (MAKEINTRESOURCE(32517))
|
||||
#define IDC_ARROW (MAKEINTRESOURCE(32512))
|
||||
#define IDC_IBEAM (MAKEINTRESOURCE(32513))
|
||||
#define IDC_WAIT (MAKEINTRESOURCE(32514))
|
||||
#define IDC_CROSS (MAKEINTRESOURCE(32515))
|
||||
#define IDC_UPARROW (MAKEINTRESOURCE(32516))
|
||||
#define IDC_SIZENWSE (MAKEINTRESOURCE(32642))
|
||||
#define IDC_SIZENESW (MAKEINTRESOURCE(32643))
|
||||
#define IDC_SIZEWE (MAKEINTRESOURCE(32644))
|
||||
#define IDC_SIZENS (MAKEINTRESOURCE(32645))
|
||||
#define IDC_SIZEALL (MAKEINTRESOURCE(32646))
|
||||
#define IDC_NO (MAKEINTRESOURCE(32648))
|
||||
#define IDC_APPSTARTING (MAKEINTRESOURCE(32650))
|
||||
#define IDC_HELP (MAKEINTRESOURCE(32651))
|
||||
#define IDI_APPLICATION (MAKEINTRESOURCE(32512))
|
||||
#define IDI_HAND (MAKEINTRESOURCE(32513))
|
||||
#define IDI_QUESTION (MAKEINTRESOURCE(32514))
|
||||
#define IDI_EXCLAMATION (MAKEINTRESOURCE(32515))
|
||||
#define IDI_ASTERISK (MAKEINTRESOURCE(32516))
|
||||
#define IDI_WINLOGO (MAKEINTRESOURCE(32517))
|
||||
|
||||
#define VS_FILE_INFO (MAKEINTRESOURCE(16))
|
||||
#define VS_FILE_INFO (MAKEINTRESOURCE(16))
|
||||
#ifdef UNICODE
|
||||
#define LPSTR_TEXTCALLBACK LPSTR_TEXTCALLBACKW
|
||||
#else
|
||||
@ -81,10 +81,10 @@
|
||||
#endif /* UNICODE */
|
||||
|
||||
/* TV_INSERTSTRUCT structure */
|
||||
#define TVI_ROOT ((HTREEITEM)0xFFFF0000)
|
||||
#define TVI_FIRST ((HTREEITEM)0xFFFF0001)
|
||||
#define TVI_LAST ((HTREEITEM)0xFFFF0002)
|
||||
#define TVI_SORT ((HTREEITEM)0xFFFF0003)
|
||||
#define TVI_ROOT ((HTREEITEM)0xFFFF0000)
|
||||
#define TVI_FIRST ((HTREEITEM)0xFFFF0001)
|
||||
#define TVI_LAST ((HTREEITEM)0xFFFF0002)
|
||||
#define TVI_SORT ((HTREEITEM)0xFFFF0003)
|
||||
|
||||
#ifdef UNICODE
|
||||
#define COLOROKSTRING COLOROKSTRINGW
|
||||
@ -105,7 +105,7 @@
|
||||
#endif
|
||||
|
||||
/* MapWindowPoints */
|
||||
#define HWND_DESKTOP ((HWND)0)
|
||||
#define HWND_DESKTOP ((HWND)0)
|
||||
|
||||
#ifdef UNICODE
|
||||
#define ANIMATE_CLASS ANIMATE_CLASSW
|
||||
@ -329,8 +329,8 @@ unit defines;
|
||||
BST_PUSHED = 4;
|
||||
MF_BYCOMMAND = 0;
|
||||
MF_BYPOSITION = $400;
|
||||
MF_CHECKED = $8;
|
||||
MF_UNCHECKED = 0;
|
||||
// MF_CHECKED = $8;
|
||||
// MF_UNCHECKED = 0;
|
||||
MF_HILITE = $80;
|
||||
{ ChildWindowFromPointEx }
|
||||
MF_UNHILITE = 0;
|
||||
@ -456,9 +456,6 @@ unit defines;
|
||||
SEC_IMAGE = 16777216;
|
||||
SEC_NOCACHE = 268435456;
|
||||
SEC_RESERVE = 67108864;
|
||||
MEM_COMMIT = 4096;
|
||||
MEM_RESERVE = 8192;
|
||||
MEM_TOP_DOWN = 1048576;
|
||||
PAGE_EXECUTE = 16;
|
||||
PAGE_EXECUTE_READ = 32;
|
||||
PAGE_EXECUTE_READWRITE = 64;
|
||||
@ -468,6 +465,7 @@ unit defines;
|
||||
MEM_COMMIT = 4096;
|
||||
MEM_FREE = 65536;
|
||||
MEM_RESERVE = 8192;
|
||||
MEM_TOP_DOWN = 1048576;
|
||||
MEM_IMAGE = 16777216;
|
||||
MEM_MAPPED = 262144;
|
||||
MEM_PRIVATE = 131072;
|
||||
@ -546,7 +544,7 @@ unit defines;
|
||||
LR_DEFAULTCOLOR = 0;
|
||||
LR_LOADREALSIZE = 128;
|
||||
{ CreateMailslot, GetMailslotInfo }
|
||||
LR_MONOCHROME = 1;
|
||||
// LR_MONOCHROME = 1;
|
||||
MAILSLOT_WAIT_FOREVER = $ffffffff;
|
||||
{ CreateMappedBitmap }
|
||||
MAILSLOT_NO_MESSAGE = $ffffffff;
|
||||
@ -616,16 +614,16 @@ unit defines;
|
||||
DELETE = $10000;
|
||||
READ_CONTROL = $20000;
|
||||
GENERIC_EXECUTE = $20000000;
|
||||
SERVICE_WIN32_OWN_PROCESS = 16;
|
||||
SERVICE_WIN32_SHARE_PROCESS = 32;
|
||||
SERVICE_KERNEL_DRIVER = 1;
|
||||
SERVICE_FILE_SYSTEM_DRIVER = 2;
|
||||
SERVICE_INTERACTIVE_PROCESS = 256;
|
||||
SERVICE_BOOT_START = 0;
|
||||
SERVICE_SYSTEM_START = 1;
|
||||
SERVICE_AUTO_START = 2;
|
||||
SERVICE_DEMAND_START = 3;
|
||||
SERVICE_DISABLED = 4;
|
||||
// SERVICE_WIN32_OWN_PROCESS = 16;
|
||||
// SERVICE_WIN32_SHARE_PROCESS = 32;
|
||||
// SERVICE_KERNEL_DRIVER = 1;
|
||||
// SERVICE_FILE_SYSTEM_DRIVER = 2;
|
||||
// SERVICE_INTERACTIVE_PROCESS = 256;
|
||||
// SERVICE_BOOT_START = 0;
|
||||
// SERVICE_SYSTEM_START = 1;
|
||||
// SERVICE_AUTO_START = 2;
|
||||
// SERVICE_DEMAND_START = 3;
|
||||
// SERVICE_DISABLED = 4;
|
||||
SERVICE_ERROR_IGNORE = 0;
|
||||
SERVICE_ERROR_NORMAL = 1;
|
||||
SERVICE_ERROR_SEVERE = 2;
|
||||
@ -835,7 +833,7 @@ unit defines;
|
||||
WH_MSGFILTER = -1;
|
||||
WH_SHELL = 10;
|
||||
WH_SYSMSGFILTER = 6;
|
||||
WH_MSGFILTER = -1;
|
||||
// WH_MSGFILTER = -1;
|
||||
{ DefineDosDevice }
|
||||
WH_FOREGROUNDIDLE = 11;
|
||||
DDD_RAW_TARGET_PATH = 1;
|
||||
@ -866,10 +864,10 @@ unit defines;
|
||||
DCTT_SUBDEV = $4;
|
||||
DC_VERSION = 10;
|
||||
DC_BINADJUST = 19;
|
||||
DC_EMF_COMPLIANT = 20;
|
||||
// DC_EMF_COMPLIANT = 20;
|
||||
{ DeviceIoControl }
|
||||
{ DlgDirList }
|
||||
DC_DATATYPE_PRODUCED = 21;
|
||||
// DC_DATATYPE_PRODUCED = 21;
|
||||
DDL_ARCHIVE = 32;
|
||||
DDL_DIRECTORY = 16;
|
||||
DDL_DRIVES = 16384;
|
||||
@ -1317,8 +1315,8 @@ unit defines;
|
||||
CP_MACCP = 2;
|
||||
{ GetDateFormat }
|
||||
CP_OEMCP = 1;
|
||||
DATE_SHORTDATE = 1;
|
||||
DATE_LONGDATE = 2;
|
||||
// DATE_SHORTDATE = 1;
|
||||
// DATE_LONGDATE = 2;
|
||||
{ GetDCEx }
|
||||
DATE_USE_ALT_CALENDAR = 4;
|
||||
DCX_WINDOW = $1;
|
||||
@ -1361,12 +1359,12 @@ unit defines;
|
||||
SIZEPALETTE = 104;
|
||||
NUMRESERVED = 106;
|
||||
COLORRES = 108;
|
||||
PHYSICALWIDTH = 110;
|
||||
PHYSICALHEIGHT = 111;
|
||||
PHYSICALOFFSETX = 112;
|
||||
PHYSICALOFFSETY = 113;
|
||||
SCALINGFACTORX = 114;
|
||||
SCALINGFACTORY = 115;
|
||||
// PHYSICALWIDTH = 110;
|
||||
// PHYSICALHEIGHT = 111;
|
||||
// PHYSICALOFFSETX = 112;
|
||||
// PHYSICALOFFSETY = 113;
|
||||
// SCALINGFACTORX = 114;
|
||||
// SCALINGFACTORY = 115;
|
||||
VREFRESH = 116;
|
||||
DESKTOPHORZRES = 118;
|
||||
DESKTOPVERTRES = 117;
|
||||
@ -1496,13 +1494,13 @@ unit defines;
|
||||
PM_REMOVE = 1;
|
||||
{ GetNamedPipeHandleState }
|
||||
PM_NOYIELD = 2;
|
||||
PIPE_NOWAIT = 1;
|
||||
// PIPE_NOWAIT = 1;
|
||||
{ GetNamedPipeInfo }
|
||||
PIPE_READMODE_MESSAGE = 2;
|
||||
// PIPE_READMODE_MESSAGE = 2;
|
||||
PIPE_CLIENT_END = 0;
|
||||
PIPE_SERVER_END = 1;
|
||||
{ GetNextWindow, GetWindow }
|
||||
PIPE_TYPE_MESSAGE = 4;
|
||||
// PIPE_TYPE_MESSAGE = 4;
|
||||
GW_HWNDNEXT = 2;
|
||||
GW_HWNDPREV = 3;
|
||||
GW_CHILD = 5;
|
||||
@ -1683,9 +1681,9 @@ unit defines;
|
||||
SM_CXSMSIZE = 52;
|
||||
SM_CYSMSIZE = 53;
|
||||
SM_CXVSCROLL = 2;
|
||||
SM_CYHSCROLL = 3;
|
||||
SM_CXHSCROLL = 21;
|
||||
SM_CYVSCROLL = 20;
|
||||
// SM_CYHSCROLL = 3;
|
||||
// SM_CXHSCROLL = 21;
|
||||
// SM_CYVSCROLL = 20;
|
||||
SM_CYVTHUMB = 9;
|
||||
SM_CYCAPTION = 4;
|
||||
SM_CYKANJIWINDOW = 18;
|
||||
@ -1822,12 +1820,12 @@ unit defines;
|
||||
CLR_NONE = $ffffffff;
|
||||
{ ImageList_LoadImage }
|
||||
CLR_DEFAULT = $ff000000;
|
||||
LR_DEFAULTCOLOR = 0;
|
||||
// LR_DEFAULTCOLOR = 0;
|
||||
LR_LOADFROMFILE = 16;
|
||||
LR_LOADMAP3DCOLORS = 4096;
|
||||
LR_LOADTRANSPARENT = 32;
|
||||
{ ImmConfigureIME }
|
||||
LR_MONOCHROME = 1;
|
||||
// LR_MONOCHROME = 1;
|
||||
IME_CONFIG_GENERAL = 1;
|
||||
IME_CONFIG_REGISTERWORD = 2;
|
||||
{ ImmGetConversionList }
|
||||
@ -2944,11 +2942,11 @@ unit defines;
|
||||
DM_COLLATE = $8000;
|
||||
DM_FORMNAME = $10000;
|
||||
DM_LOGPIXELS = $20000;
|
||||
DM_BITSPERPEL = $40000;
|
||||
DM_PELSWIDTH = $80000;
|
||||
DM_PELSHEIGHT = $100000;
|
||||
DM_DISPLAYFLAGS = $200000;
|
||||
DM_DISPLAYFREQUENCY = $400000;
|
||||
// DM_BITSPERPEL = $40000;
|
||||
// DM_PELSWIDTH = $80000;
|
||||
// DM_PELSHEIGHT = $100000;
|
||||
// DM_DISPLAYFLAGS = $200000;
|
||||
// DM_DISPLAYFREQUENCY = $400000;
|
||||
DM_ICMMETHOD = $800000;
|
||||
DM_ICMINTENT = $1000000;
|
||||
DM_MEDIATYPE = $2000000;
|
||||
@ -3125,15 +3123,15 @@ unit defines;
|
||||
{ EM_FINDWORDBREAK message }
|
||||
SFF_PLAINRTF = 16384;
|
||||
WB_CLASSIFY = 3;
|
||||
WB_ISDELIMITER = 2;
|
||||
WB_LEFT = 0;
|
||||
// WB_ISDELIMITER = 2;
|
||||
// WB_LEFT = 0;
|
||||
WB_LEFTBREAK = 6;
|
||||
WB_PREVBREAK = 6;
|
||||
WB_MOVEWORDLEFT = 4;
|
||||
WB_MOVEWORDPREV = 4;
|
||||
WB_MOVEWORDRIGHT = 5;
|
||||
WB_MOVEWORDNEXT = 5;
|
||||
WB_RIGHT = 1;
|
||||
// WB_RIGHT = 1;
|
||||
WB_RIGHTBREAK = 7;
|
||||
{ EM_GETPUNCTUATION message }
|
||||
WB_NEXTBREAK = 7;
|
||||
@ -3301,7 +3299,7 @@ unit defines;
|
||||
TTDT_RESHOW = 1;
|
||||
SBARS_SIZEGRIP = 256;
|
||||
{ DL_DRAGGING message }
|
||||
SBARS_SIZEGRIP = 256;
|
||||
// SBARS_SIZEGRIP = 256;
|
||||
DL_MOVECURSOR = 3;
|
||||
DL_COPYCURSOR = 2;
|
||||
{ Up-down control styles }
|
||||
@ -3726,7 +3724,7 @@ unit defines;
|
||||
SE_GROUP_OWNER = $8;
|
||||
{ SECURITY_DESCRIPTOR_CONTROL }
|
||||
SE_GROUP_LOGON_ID = $c0000000;
|
||||
SECURITY_DESCRIPTOR_REVISION = 1;
|
||||
// SECURITY_DESCRIPTOR_REVISION = 1;
|
||||
SECURITY_DESCRIPTOR_MIN_LENGTH = 20;
|
||||
SE_OWNER_DEFAULTED = 1;
|
||||
SE_GROUP_DEFAULTED = 2;
|
||||
@ -4348,50 +4346,50 @@ unit defines;
|
||||
PFD_SWAP_EXCHANGE = $200;
|
||||
|
||||
{ Common control window classes }
|
||||
ANIMATE_CLASSW = 'SysAnimate32';
|
||||
HOTKEY_CLASSW = 'msctls_hotkey32';
|
||||
PROGRESS_CLASSW = 'msctls_progress32';
|
||||
STATUSCLASSNAMEW = 'msctls_statusbar32';
|
||||
ANIMATE_CLASSW = 'SysAnimate32';
|
||||
HOTKEY_CLASSW = 'msctls_hotkey32';
|
||||
PROGRESS_CLASSW = 'msctls_progress32';
|
||||
STATUSCLASSNAMEW = 'msctls_statusbar32';
|
||||
TOOLBARCLASSNAMEW = 'ToolbarWindow32';
|
||||
TOOLTIPS_CLASSW = 'tooltips_class32';
|
||||
TRACKBAR_CLASSW = 'msctls_trackbar32';
|
||||
UPDOWN_CLASSW = 'msctls_updown32';
|
||||
WC_HEADERW = 'SysHeader32';
|
||||
WC_LISTVIEWW = 'SysListView32';
|
||||
WC_TABCONTROLW = 'SysTabControl32';
|
||||
WC_TREEVIEWW = 'SysTreeView32';
|
||||
TOOLTIPS_CLASSW = 'tooltips_class32';
|
||||
TRACKBAR_CLASSW = 'msctls_trackbar32';
|
||||
UPDOWN_CLASSW = 'msctls_updown32';
|
||||
WC_HEADERW = 'SysHeader32';
|
||||
WC_LISTVIEWW = 'SysListView32';
|
||||
WC_TABCONTROLW = 'SysTabControl32';
|
||||
WC_TREEVIEWW = 'SysTreeView32';
|
||||
|
||||
ANIMATE_CLASSA = 'SysAnimate32';
|
||||
HOTKEY_CLASSA = 'msctls_hotkey32';
|
||||
PROGRESS_CLASSA = 'msctls_progress32';
|
||||
STATUSCLASSNAMEA = 'msctls_statusbar32';
|
||||
ANIMATE_CLASSA = 'SysAnimate32';
|
||||
HOTKEY_CLASSA = 'msctls_hotkey32';
|
||||
PROGRESS_CLASSA = 'msctls_progress32';
|
||||
STATUSCLASSNAMEA = 'msctls_statusbar32';
|
||||
TOOLBARCLASSNAMEA = 'ToolbarWindow32';
|
||||
TOOLTIPS_CLASSA = 'tooltips_class32';
|
||||
TRACKBAR_CLASSA = 'msctls_trackbar32';
|
||||
UPDOWN_CLASSA = 'msctls_updown32';
|
||||
WC_HEADERA = 'SysHeader32';
|
||||
WC_LISTVIEWA = 'SysListView32';
|
||||
WC_TABCONTROLA = 'SysTabControl32';
|
||||
WC_TREEVIEWA = 'SysTreeView32';
|
||||
TOOLTIPS_CLASSA = 'tooltips_class32';
|
||||
TRACKBAR_CLASSA = 'msctls_trackbar32';
|
||||
UPDOWN_CLASSA = 'msctls_updown32';
|
||||
WC_HEADERA = 'SysHeader32';
|
||||
WC_LISTVIEWA = 'SysListView32';
|
||||
WC_TABCONTROLA = 'SysTabControl32';
|
||||
WC_TREEVIEWA = 'SysTreeView32';
|
||||
|
||||
{ Common dialog messages }
|
||||
COLOROKSTRINGW = 'commdlg_ColorOK';
|
||||
FILEOKSTRINGW = 'commdlg_FileNameOK';
|
||||
FINDMSGSTRINGW = 'commdlg_FindReplace';
|
||||
HELPMSGSTRINGW = 'commdlg_help';
|
||||
LBSELCHSTRINGW = 'commdlg_LBSelChangedNotify';
|
||||
SETRGBSTRINGW = 'commdlg_SetRGBColor';
|
||||
SHAREVISTRINGW = 'commdlg_ShareViolation';
|
||||
COLOROKSTRINGA = 'commdlg_ColorOK';
|
||||
FILEOKSTRINGA = 'commdlg_FileNameOK';
|
||||
FINDMSGSTRINGA = 'commdlg_FindReplace';
|
||||
HELPMSGSTRINGA = 'commdlg_help';
|
||||
LBSELCHSTRINGA = 'commdlg_LBSelChangedNotify';
|
||||
SETRGBSTRINGA = 'commdlg_SetRGBColor';
|
||||
SHAREVISTRINGA = 'commdlg_ShareViolation';
|
||||
COLOROKSTRINGW = 'commdlg_ColorOK';
|
||||
FILEOKSTRINGW = 'commdlg_FileNameOK';
|
||||
FINDMSGSTRINGW = 'commdlg_FindReplace';
|
||||
HELPMSGSTRINGW = 'commdlg_help';
|
||||
LBSELCHSTRINGW = 'commdlg_LBSelChangedNotify';
|
||||
SETRGBSTRINGW = 'commdlg_SetRGBColor';
|
||||
SHAREVISTRINGW = 'commdlg_ShareViolation';
|
||||
COLOROKSTRINGA = 'commdlg_ColorOK';
|
||||
FILEOKSTRINGA = 'commdlg_FileNameOK';
|
||||
FINDMSGSTRINGA = 'commdlg_FindReplace';
|
||||
HELPMSGSTRINGA = 'commdlg_help';
|
||||
LBSELCHSTRINGA = 'commdlg_LBSelChangedNotify';
|
||||
SETRGBSTRINGA = 'commdlg_SetRGBColor';
|
||||
SHAREVISTRINGA = 'commdlg_ShareViolation';
|
||||
|
||||
UNICODE_NULL : WCHAR = 0;
|
||||
INVALID_HANDLE_VALUE : HANDLE = -1;
|
||||
INVALID_HANDLE_VALUE : THANDLE = -1;
|
||||
{ PostMessage }
|
||||
HWND_BROADCAST : HWND = $FFFF;
|
||||
{ RegCreateKey }
|
||||
@ -4404,13 +4402,13 @@ unit defines;
|
||||
|
||||
HWND_BOTTOM : HWND = 1;
|
||||
HWND_NOTOPMOST : HWND = -2;
|
||||
HWND_TOP : HWND = 0;
|
||||
HWND_TOP : HWND = 0;
|
||||
HWND_TOPMOST : HWND = -1;
|
||||
|
||||
HINST_COMMCTRL : HINSTANCE = -1;
|
||||
|
||||
LPSTR_TEXTCALLBACKW : LPWSTR = -1;
|
||||
LPSTR_TEXTCALLBACKA : LPSTR = -1;
|
||||
LPSTR_TEXTCALLBACKW : LPWSTR = nil;
|
||||
LPSTR_TEXTCALLBACKA : LPSTR = nil;
|
||||
|
||||
implementation
|
||||
|
||||
@ -4418,9 +4416,7 @@ end.
|
||||
|
||||
{
|
||||
$Log$
|
||||
Revision 1.2 1998-05-06 12:36:50 michael
|
||||
+ Removed log from before restored version.
|
||||
Revision 1.3 1998-06-10 10:39:12 peter
|
||||
* working w32 rtl
|
||||
|
||||
Revision 1.1.1.1 1998/03/25 11:18:46 root
|
||||
* Restored version
|
||||
}
|
||||
|
||||
393
rtl/win32/dos.pp
393
rtl/win32/dos.pp
@ -19,7 +19,12 @@ unit dos;
|
||||
|
||||
interface
|
||||
|
||||
{ Include Win32 Consts,Types }
|
||||
{$I win32.inc}
|
||||
|
||||
Const
|
||||
Max_Path = 255;
|
||||
|
||||
{Bitmasks for CPU Flags}
|
||||
fcarry = $0001;
|
||||
fparity = $0004;
|
||||
@ -70,13 +75,30 @@ Type
|
||||
Sec : word;
|
||||
End;
|
||||
|
||||
searchrec = packed record
|
||||
time : longint;
|
||||
size : longint;
|
||||
attr : longint;
|
||||
name : string;
|
||||
PWin32FindData = ^TWin32FindData;
|
||||
TWin32FindData = packed record
|
||||
dwFileAttributes: Cardinal;
|
||||
ftCreationTime: TFileTime;
|
||||
ftLastAccessTime: TFileTime;
|
||||
ftLastWriteTime: TFileTime;
|
||||
nFileSizeHigh: Cardinal;
|
||||
nFileSizeLow: Cardinal;
|
||||
dwReserved0: Cardinal;
|
||||
dwReserved1: Cardinal;
|
||||
cFileName: array[0..MAX_PATH - 1] of Char;
|
||||
cAlternateFileName: array[0..13] of Char;
|
||||
end;
|
||||
|
||||
Searchrec = Packed Record
|
||||
FindHandle : THandle;
|
||||
W32FindData : TWin32FindData;
|
||||
time : longint;
|
||||
size : longint;
|
||||
attr : longint;
|
||||
name : string;
|
||||
end;
|
||||
|
||||
|
||||
registers = packed record
|
||||
case i : integer of
|
||||
0 : (ax,f1,bx,f2,cx,f3,dx,f4,bp,f5,si,f51,di,f6,ds,f7,es,f8,flags,fs,gs : word);
|
||||
@ -140,7 +162,61 @@ Procedure Keep(exitcode: word);
|
||||
implementation
|
||||
uses strings;
|
||||
|
||||
{$I win32.inc}
|
||||
{******************************************************************************
|
||||
--- Conversion ---
|
||||
******************************************************************************}
|
||||
|
||||
function GetLastError : DWORD;
|
||||
external 'kernel32' name 'GetLastError';
|
||||
function FileTimeToDosDateTime(const ft :TFileTime;var data,time : word) : boolean;
|
||||
external 'kernel32' name 'FileTimeToDosDateTime';
|
||||
function DosDateTimeToFileTime(date,time : word;var ft :TFileTime) : boolean;
|
||||
external 'kernel32' name 'DosDateTimeToFileTime';
|
||||
function FileTimeToLocalFileTime(const ft : TFileTime;var lft : TFileTime) : boolean;
|
||||
external 'kernel32' name 'FileTimeToLocalFileTime';
|
||||
function LocalFileTimeToFileTime(const lft : TFileTime;var ft : TFileTime) : boolean;
|
||||
external 'kernel32' name 'LocalFileTimeToFileTime';
|
||||
|
||||
type
|
||||
Longrec=packed record
|
||||
lo,hi : word;
|
||||
end;
|
||||
|
||||
function Last2DosError(d:dword):integer;
|
||||
begin
|
||||
Last2DosError:=d;
|
||||
end;
|
||||
|
||||
|
||||
Function DosToWinAttr (Const Attr : Longint) : longint;
|
||||
begin
|
||||
DosToWinAttr:=Attr;
|
||||
end;
|
||||
|
||||
|
||||
Function WinToDosAttr (Const Attr : Longint) : longint;
|
||||
begin
|
||||
WinToDosAttr:=Attr;
|
||||
end;
|
||||
|
||||
|
||||
Function DosToWinTime (DTime:longint;Var Wtime : TFileTime):boolean;
|
||||
var
|
||||
lft : TFileTime;
|
||||
begin
|
||||
DosToWinTime:=DosDateTimeToFileTime(longrec(dtime).hi,longrec(dtime).lo,lft) and
|
||||
LocalFileTimeToFileTime(lft,Wtime);
|
||||
end;
|
||||
|
||||
|
||||
Function WinToDosTime (Const Wtime : TFileTime;var DTime:longint):boolean;
|
||||
var
|
||||
lft : TFileTime;
|
||||
begin
|
||||
WinToDosTime:=FileTimeToLocalFileTime(WTime,lft) and
|
||||
FileTimeToDosDateTime(lft,longrec(dtime).hi,longrec(dtime).lo);
|
||||
end;
|
||||
|
||||
|
||||
{******************************************************************************
|
||||
--- Dos Interrupt ---
|
||||
@ -153,7 +229,7 @@ end;
|
||||
|
||||
procedure msdos(var regs : registers);
|
||||
begin
|
||||
intr($21,regs);
|
||||
{ !!!!!!!! }
|
||||
end;
|
||||
|
||||
|
||||
@ -161,6 +237,13 @@ end;
|
||||
--- Info / Date / Time ---
|
||||
******************************************************************************}
|
||||
|
||||
function GetVersion : longint;
|
||||
external 'kernel32' name 'GetVersion';
|
||||
procedure GetLocalTime(var t : TSystemTime);
|
||||
external 'kernel32' name 'GetLocalTime';
|
||||
function SetLocalTime(const t : TSystemTime) : boolean;
|
||||
external 'kernel32' name 'SetLocalTime';
|
||||
|
||||
function dosversion : word;
|
||||
begin
|
||||
dosversion:=GetVersion;
|
||||
@ -169,7 +252,7 @@ end;
|
||||
|
||||
procedure getdate(var year,month,mday,wday : word);
|
||||
var
|
||||
t : SYSTEMTIME;
|
||||
t : TSystemTime;
|
||||
begin
|
||||
GetLocalTime(t);
|
||||
year:=t.wYear;
|
||||
@ -181,7 +264,7 @@ end;
|
||||
|
||||
procedure setdate(year,month,day : word);
|
||||
var
|
||||
t : SYSTEMTIME;
|
||||
t : TSystemTime;
|
||||
begin
|
||||
{ we need the time set privilege }
|
||||
{ so this function crash currently }
|
||||
@ -197,7 +280,7 @@ end;
|
||||
|
||||
procedure gettime(var hour,minute,second,sec100 : word);
|
||||
var
|
||||
t : SYSTEMTIME;
|
||||
t : TSystemTime;
|
||||
begin
|
||||
GetLocalTime(t);
|
||||
hour:=t.wHour;
|
||||
@ -209,7 +292,7 @@ end;
|
||||
|
||||
procedure settime(hour,minute,second,sec100 : word);
|
||||
var
|
||||
t : SYSTEMTIME;
|
||||
t : TSystemTime;
|
||||
begin
|
||||
{ we need the time set privilege }
|
||||
{ so this function crash currently }
|
||||
@ -247,12 +330,53 @@ End;
|
||||
--- Exec ---
|
||||
******************************************************************************}
|
||||
|
||||
function CreateProcess(lpApplicationName: PChar; lpCommandLine: PChar;
|
||||
lpProcessAttributes, lpThreadAttributes: PSecurityAttributes;
|
||||
bInheritHandles: BOOL; dwCreationFlags: DWORD; lpEnvironment: Pointer;
|
||||
lpCurrentDirectory: PChar; const lpStartupInfo: TStartupInfo;
|
||||
var lpProcessInformation: TProcessInformation): boolean;
|
||||
external 'kernel32' name 'CreateProcessA';
|
||||
function getExitCodeProcess(h:THandle;var code:longint):boolean;
|
||||
external 'kernel32' name 'GetExitCodeProcess';
|
||||
function WaitForSingleObject(hHandle: THandle; dwMilliseconds: DWORD): DWORD;
|
||||
external 'kernel32' name 'WaitForSingleObject';
|
||||
function CloseHandle(h : THandle) : longint;
|
||||
external 'kernel32' name 'CloseHandle';
|
||||
|
||||
var
|
||||
lastdosexitcode : word;
|
||||
|
||||
procedure exec(const path : pathstr;const comline : comstr);
|
||||
var
|
||||
SI: TStartupInfo;
|
||||
PI: TProcessInformation;
|
||||
Proc : THandle;
|
||||
l : Longint;
|
||||
AppPath,
|
||||
AppParam : array[0..255] of char;
|
||||
begin
|
||||
{ !!!!!!!! }
|
||||
FillChar(SI, SizeOf(SI), 0);
|
||||
SI.cb:=SizeOf(SI);
|
||||
SI.wShowWindow:=1;
|
||||
Move(Path[1],AppPath,length(Path));
|
||||
AppPath[Length(Path)]:=#0;
|
||||
AppParam[0]:='-';
|
||||
AppParam[1]:=' ';
|
||||
Move(ComLine[1],AppParam[2],length(Comline));
|
||||
AppParam[Length(ComLine)+2]:=#0;
|
||||
if not CreateProcess(PChar(@AppPath), PChar(@AppParam), Nil, Nil, False,$20, Nil, Nil, SI, PI) then
|
||||
begin
|
||||
DosError:=Last2DosError(GetLastError);
|
||||
exit;
|
||||
end;
|
||||
Proc:=PI.hProcess;
|
||||
CloseHandle(PI.hThread);
|
||||
if WaitForSingleObject(Proc, Infinite) <> $ffffffff then
|
||||
GetExitCodeProcess(Proc,l)
|
||||
else
|
||||
l:=-1;
|
||||
CloseHandle(Proc);
|
||||
LastDosExitCode:=l;
|
||||
end;
|
||||
|
||||
|
||||
@ -290,17 +414,57 @@ end;
|
||||
--- Disk ---
|
||||
******************************************************************************}
|
||||
|
||||
function GetDiskFreeSpace(drive:pchar;var sector_cluster,bytes_sector,
|
||||
freeclusters,totalclusters:longint):boolean;
|
||||
external 'kernel32' name 'GetDiskFreeSpaceA';
|
||||
|
||||
function diskfree(drive : byte) : longint;
|
||||
var
|
||||
disk : array[1..4] of char;
|
||||
secs,bytes,
|
||||
free,total : longint;
|
||||
begin
|
||||
{ !!!!!!!!! }
|
||||
diskfree:=-1;
|
||||
if drive=0 then
|
||||
begin
|
||||
disk[1]:='\';
|
||||
disk[2]:=#0;
|
||||
end
|
||||
else
|
||||
begin
|
||||
disk[1]:=chr(drive+64);
|
||||
disk[2]:=':';
|
||||
disk[3]:='\';
|
||||
disk[4]:=#0;
|
||||
end;
|
||||
if GetDiskFreeSpace(@disk,secs,bytes,free,total) then
|
||||
diskfree:=free*secs*bytes
|
||||
else
|
||||
diskfree:=-1;
|
||||
end;
|
||||
|
||||
|
||||
function disksize(drive : byte) : longint;
|
||||
var
|
||||
disk : array[1..4] of char;
|
||||
secs,bytes,
|
||||
free,total : longint;
|
||||
begin
|
||||
{ !!!!!!!!! }
|
||||
disksize:=-1;
|
||||
if drive=0 then
|
||||
begin
|
||||
disk[1]:='\';
|
||||
disk[2]:=#0;
|
||||
end
|
||||
else
|
||||
begin
|
||||
disk[1]:=chr(drive+64);
|
||||
disk[2]:=':';
|
||||
disk[3]:='\';
|
||||
disk[4]:=#0;
|
||||
end;
|
||||
if GetDiskFreeSpace(@disk,secs,bytes,free,total) then
|
||||
disksize:=total*secs*bytes
|
||||
else
|
||||
disksize:=-1;
|
||||
end;
|
||||
|
||||
|
||||
@ -308,77 +472,104 @@ end;
|
||||
--- Findfirst FindNext ---
|
||||
******************************************************************************}
|
||||
|
||||
procedure searchrec2dossearchrec(var f : searchrec);
|
||||
var
|
||||
l,i : longint;
|
||||
begin
|
||||
l:=length(f.name);
|
||||
for i:=1 to 12 do
|
||||
f.name[i-1]:=f.name[i];
|
||||
f.name[l]:=#0;
|
||||
end;
|
||||
|
||||
procedure dossearchrec2searchrec(var f : searchrec);
|
||||
var
|
||||
l,i : longint;
|
||||
begin
|
||||
l:=12;
|
||||
for i:=0 to 12 do
|
||||
if f.name[i]=#0 then
|
||||
begin
|
||||
l:=i;
|
||||
break;
|
||||
end;
|
||||
for i:=11 downto 0 do
|
||||
f.name[i+1]:=f.name[i];
|
||||
f.name[0]:=chr(l);
|
||||
end;
|
||||
|
||||
procedure findfirst(const path : pathstr;attr : word;var f : searchRec);
|
||||
|
||||
procedure _findfirst(path : pchar;attr : word;var f : searchrec);
|
||||
begin
|
||||
{!!!!!!!!!!!!!!}
|
||||
end;
|
||||
|
||||
var
|
||||
path0 : array[0..80] of char;
|
||||
begin
|
||||
{ no error }
|
||||
doserror:=0;
|
||||
strpcopy(path0,path);
|
||||
_findfirst(path0,attr,f);
|
||||
dossearchrec2searchrec(f);
|
||||
end;
|
||||
|
||||
procedure findnext(var f : searchRec);
|
||||
|
||||
procedure _findnext(var f : searchrec);
|
||||
begin
|
||||
{!!!!!!!!!!!!!!}
|
||||
end;
|
||||
|
||||
begin
|
||||
{ no error }
|
||||
doserror:=0;
|
||||
searchrec2dossearchrec(f);
|
||||
_findnext(f);
|
||||
dossearchrec2searchrec(f);
|
||||
end;
|
||||
|
||||
procedure swapvectors;
|
||||
{ Needed kernel calls }
|
||||
|
||||
function FindFirstFile (lpFileName: PChar; var lpFindFileData: TWIN32FindData): THandle;
|
||||
external 'kernel32' name 'FindFirstFileA';
|
||||
function FindNextFile (hFindFile: THandle; var lpFindFileData: TWIN32FindData): Boolean;
|
||||
external 'kernel32' name 'FindNextFileA';
|
||||
function FindCloseFile (hFindFile: THandle): Boolean;
|
||||
external 'kernel32' name 'FindClose';
|
||||
|
||||
Procedure StringToPchar (Var S : String);
|
||||
Var L : Longint;
|
||||
begin
|
||||
L:=ord(S[0]);
|
||||
Move (S[1],S[0],L);
|
||||
S[L]:=#0;
|
||||
end;
|
||||
|
||||
|
||||
procedure FindMatch(var f:searchrec);
|
||||
Var
|
||||
TheAttr : Longint;
|
||||
begin
|
||||
TheAttr:=DosToWinAttr(F.Attr);
|
||||
{ Find file with correct attribute }
|
||||
While (F.W32FindData.dwFileAttributes and TheAttr)=0 do
|
||||
begin
|
||||
if not FindNextFile (F.FindHandle,F.W32FindData) then
|
||||
begin
|
||||
DosError:=Last2DosError(GetLastError);
|
||||
exit;
|
||||
end;
|
||||
end;
|
||||
{ Convert some attributes back }
|
||||
f.size:=F.W32FindData.NFileSizeLow;
|
||||
f.attr:=WinToDosAttr(F.W32FindData.dwFileAttributes);
|
||||
WinToDosTime(F.W32FindData.ftLastWriteTime,f.Time);
|
||||
f.Name:=StrPas(@F.W32FindData.cFileName);
|
||||
end;
|
||||
|
||||
|
||||
Procedure FindClose(Var f: SearchRec);
|
||||
begin
|
||||
end;
|
||||
procedure findfirst(const path : pathstr;attr : word;var f : searchRec);
|
||||
begin
|
||||
{ no error }
|
||||
doserror:=0;
|
||||
F.Name:=Path;
|
||||
F.Attr:=attr;
|
||||
StringToPchar(f.name);
|
||||
{ FindFirstFile is a Win32 Call. }
|
||||
F.FindHandle:=FindFirstFile (pchar(@f.Name),F.W32FindData);
|
||||
If longint(F.FindHandle)=Invalid_Handle_value then
|
||||
begin
|
||||
DosError:=Last2DosError(GetLastError);
|
||||
exit;
|
||||
end;
|
||||
{ Find file with correct attribute }
|
||||
FindMatch(f);
|
||||
end;
|
||||
|
||||
|
||||
procedure findnext(var f : searchRec);
|
||||
begin
|
||||
{ no error }
|
||||
doserror:=0;
|
||||
if not FindNextFile (F.FindHandle,F.W32FindData) then
|
||||
begin
|
||||
DosError:=Last2DosError(GetLastError);
|
||||
exit;
|
||||
end;
|
||||
{ Find file with correct attribute }
|
||||
FindMatch(f);
|
||||
end;
|
||||
|
||||
|
||||
procedure swapvectors;
|
||||
begin
|
||||
end;
|
||||
|
||||
|
||||
Procedure FindClose(Var f: SearchRec);
|
||||
begin
|
||||
If longint(F.FindHandle)<>Invalid_Handle_value then
|
||||
FindCloseFile(F.FindHandle);
|
||||
end;
|
||||
|
||||
|
||||
{******************************************************************************
|
||||
--- File ---
|
||||
******************************************************************************}
|
||||
|
||||
function GetFileTime(h : longint;creation,lastaccess,lastwrite : PFileTime) : boolean;
|
||||
external 'kernel32' name 'GetFileTime';
|
||||
function SetFileTime(h : longint;creation,lastaccess,lastwrite : PFileTime) : boolean;
|
||||
external 'kernel32' name 'SetFileTime';
|
||||
function SetFileAttributes(lpFileName : pchar;dwFileAttributes : longint) : boolean;
|
||||
external 'kernel32' name 'SetFileAttributesA';
|
||||
function GetFileAttributes(lpFileName : pchar) : longint;
|
||||
external 'kernel32' name 'GetFileAttributesA';
|
||||
|
||||
procedure fsplit(path : pathstr;var dir : dirstr;var name : namestr;var ext : extstr);
|
||||
var
|
||||
p1,i : longint;
|
||||
@ -431,13 +622,13 @@ begin
|
||||
pa[i]:='\';
|
||||
if (length(pa)>1) and (pa[1] in ['A'..'Z']) and (pa[2]=':') then
|
||||
begin
|
||||
{ we must get the right directory }
|
||||
getdir(ord(pa[1])-ord('A')+1,s);
|
||||
if (ord(pa[0])>2) and (pa[3]<>'\') then
|
||||
if pa[1]=s[1] then
|
||||
pa:=s+'\'+copy (pa,3,length(pa))
|
||||
else
|
||||
pa:=pa[1]+':\'+copy (pa,3,length(pa))
|
||||
{ we must get the right directory }
|
||||
getdir(ord(pa[1])-ord('A')+1,s);
|
||||
if (ord(pa[0])>2) and (pa[3]<>'\') then
|
||||
if pa[1]=s[1] then
|
||||
pa:=s+'\'+copy (pa,3,length(pa))
|
||||
else
|
||||
pa:=pa[1]+':\'+copy (pa,3,length(pa))
|
||||
end
|
||||
else
|
||||
if pa[1]='\' then
|
||||
@ -509,25 +700,23 @@ end;
|
||||
|
||||
|
||||
procedure getftime(var f;var time : longint);
|
||||
type
|
||||
lr = record
|
||||
lo,hi : word;
|
||||
end;
|
||||
var
|
||||
ft,lft : FILETIME;
|
||||
ft : TFileTime;
|
||||
begin
|
||||
if GetFileTime(filerec(f).handle,nil,nil,@ft) and
|
||||
FileTimeToLocalFileTime(ft,lft) and
|
||||
FileTimeToDosDateTime(lft,lr(time).hi,lr(time).lo) then
|
||||
exit
|
||||
else
|
||||
time:=0;
|
||||
if GetFileTime(filerec(f).Handle,nil,nil,@ft) and
|
||||
WinToDosTime(ft,time) then
|
||||
exit
|
||||
else
|
||||
time:=0;
|
||||
end;
|
||||
|
||||
|
||||
procedure setftime(var f;time : longint);
|
||||
var
|
||||
ft : TFileTime;
|
||||
begin
|
||||
{ !!!!!!!!!!!!! }
|
||||
if DosToWinTime(time,ft) then
|
||||
SetFileTime(filerec(f).Handle,nil,nil,@ft);
|
||||
end;
|
||||
|
||||
|
||||
@ -559,6 +748,11 @@ end;
|
||||
terminated by a #0
|
||||
}
|
||||
|
||||
function GetEnvironmentStrings : pchar;
|
||||
external 'kernel32' name 'GetEnvironmentStringsA';
|
||||
function FreeEnvironmentStrings(p : pchar) : boolean;
|
||||
external 'kernel32' name 'FreeEnvironmentStringsA';
|
||||
|
||||
function envcount : longint;
|
||||
var
|
||||
hp,p : pchar;
|
||||
@ -649,7 +843,10 @@ End;
|
||||
end.
|
||||
{
|
||||
$Log$
|
||||
Revision 1.6 1998-06-08 23:07:45 peter
|
||||
Revision 1.7 1998-06-10 10:39:13 peter
|
||||
* working w32 rtl
|
||||
|
||||
Revision 1.6 1998/06/08 23:07:45 peter
|
||||
* dos interface is now 100% compatible
|
||||
* fixed call PASCALMAIN which must be direct asm
|
||||
|
||||
|
||||
@ -3,7 +3,7 @@
|
||||
# This file is part of the Free Pascal run time library.
|
||||
# Copyright (c) 1996-98 by Michael van Canneyt
|
||||
#
|
||||
# Makefile for the Free Pascal Go32v1 Runtime Library
|
||||
# Makefile for the Free Pascal Win32 Runtime Library
|
||||
#
|
||||
# See the file COPYING.FPC, included in this distribution,
|
||||
# for details about the copyright.
|
||||
@ -21,24 +21,14 @@
|
||||
# with the main makefile.
|
||||
#####################################################################
|
||||
|
||||
# set the directory where to install the units.
|
||||
ifndef UNITINSTALLDIR
|
||||
UNITINSTALLDIR=c:\lib\ppc\win32
|
||||
endif
|
||||
|
||||
# set the directory where to install libraries
|
||||
ifndef LIBINSTALLDIR
|
||||
LIBINSTALLDIR=c:\lib
|
||||
endif
|
||||
|
||||
# What is the Operating System
|
||||
ifndef OS_SRC
|
||||
OS_SRC=GO32V2
|
||||
# What is the Operating System ?
|
||||
ifndef OS_SOURCE
|
||||
OS_SOURCE=win32
|
||||
endif
|
||||
|
||||
# What is the target operating system ?
|
||||
ifndef OS_TARGET
|
||||
OS_TARGET=WIN32
|
||||
OS_TARGET=win32
|
||||
endif
|
||||
|
||||
# What is the target processor :
|
||||
@ -48,7 +38,6 @@ CPU=i386
|
||||
endif
|
||||
|
||||
# What compiler to use ?
|
||||
# I think ppc386 is better (it's mostly in path) (FK)
|
||||
ifndef PP
|
||||
PP=ppc386
|
||||
endif
|
||||
@ -59,11 +48,24 @@ ifndef OPT
|
||||
OPT=
|
||||
endif
|
||||
|
||||
# Where is the ppumove program ?
|
||||
# Where is the PPUMOVE program ?
|
||||
ifndef PPUMOVE
|
||||
PPUMOVE=ppumove
|
||||
endif
|
||||
|
||||
# Set this to 'shared' or 'static'
|
||||
LIBTYPE=shared
|
||||
|
||||
# AOUT should be defined in main makefile.
|
||||
# But you can set it here too.
|
||||
# AOUT = -DAOUT
|
||||
|
||||
# Do you want to link to the C library ?
|
||||
# Standard it is NO. You can set it to YES to link in th C library.
|
||||
ifndef LINK_TO_C
|
||||
LINK_TO_C=NO
|
||||
endif
|
||||
|
||||
#####################################################################
|
||||
# End of configurable section.
|
||||
# Do not edit after this line.
|
||||
@ -88,13 +90,13 @@ OBJPASDIR=../objpas
|
||||
include $(CFG)/makefile.cfg
|
||||
|
||||
# Get the system independent include file names.
|
||||
# This will set the following variables :
|
||||
# This will set the following variables :
|
||||
# SYSINCNAMES
|
||||
include $(INC)/makefile.inc
|
||||
SYSINCDEPS=$(addprefix $(INC)/,$(SYSINCNAMES))
|
||||
|
||||
# Get the processor dependent include file names.
|
||||
# This will set the following variables :
|
||||
# This will set the following variables :
|
||||
# CPUINCNAMES
|
||||
include $(PROCINC)/makefile.cpu
|
||||
SYSCPUDEPS=$(addprefix $(PROCINC)/,$(CPUINCNAMES))
|
||||
@ -106,27 +108,15 @@ SYSDEPS=$(SYSINCDEPS) $(SYSCPUDEPS)
|
||||
# System dependent
|
||||
#####################################################################
|
||||
|
||||
# Determine needed extensions
|
||||
PPUEXT=.ppw
|
||||
PPLEXT=.ppl
|
||||
OEXT=.obj
|
||||
ASMEXT=.s
|
||||
LIBEXT=.a
|
||||
|
||||
# Define Windows Units
|
||||
# Define Linux Units
|
||||
SYSTEMPPU=syswin32$(PPUEXT)
|
||||
OBJECTS=strings objpas \
|
||||
base \
|
||||
dos \
|
||||
# crt objects printer \
|
||||
cpu mmx getopts \
|
||||
|
||||
# No loaders needed
|
||||
LOADERS=
|
||||
|
||||
base messages defines
|
||||
|
||||
# Add Prefix and Suffixes
|
||||
OBJLOADERS=$(addsuffix $(OEXT), $(LOADERS))
|
||||
PPUOBJECTS=$(addsuffix $(PPUEXT), $(OBJECTS))
|
||||
|
||||
.PHONY : all install clean \
|
||||
@ -140,26 +130,22 @@ install : all
|
||||
$(INSTALL) *$(PPUEXT) *$(OEXT) $(UNITINSTALLDIR)
|
||||
|
||||
clean :
|
||||
-$(DEL) *$(OEXT) *$(ASMEXT) *$(PPUEXT) *.PPS log
|
||||
-$(DEL) *$(OEXT) *$(ASMEXT) *$(PPUEXT) log
|
||||
|
||||
#####################################################################
|
||||
# Files
|
||||
#####################################################################
|
||||
|
||||
#
|
||||
# Loaders
|
||||
#
|
||||
|
||||
#
|
||||
# Base Units (System, strings, os-dependent-base-unit)
|
||||
#
|
||||
|
||||
$(SYSTEMPPU) : syswin32.pp $(SYSDEPS) win32.inc
|
||||
$(SYSTEMPPU) : syswin32.pp win32.inc $(SYSDEPS)
|
||||
$(PP) $(OPT) -Us -Sg syswin32.pp $(REDIR)
|
||||
|
||||
strings$(PPUEXT) : $(PROCINC)/strings.pp $(SYSTEMPPU)
|
||||
$(COPY) $(PROCINC)/strings.pp .
|
||||
$(PP) $(OPT) strings.pp $(REDIR)
|
||||
$(PP) $(OPT) strings $(REDIR)
|
||||
$(DEL) strings.pp
|
||||
|
||||
#
|
||||
@ -178,77 +164,50 @@ objpas$(PPUEXT) : $(OBJPASDIR)/objpas.pp $(SYSTEMPPU)
|
||||
base$(PPUEXT) : base.pp $(SYSTEMPPU)
|
||||
$(PP) $(OPT) base.pp $(REDIR)
|
||||
|
||||
messages$(PPUEXT) : messages.pp $(SYSTEMPPU)
|
||||
$(PP) $(OPT) messages.pp $(REDIR)
|
||||
|
||||
defines$(PPUEXT) : defines.pp $(SYSTEMPPU)
|
||||
$(PP) $(OPT) defines.pp $(REDIR)
|
||||
|
||||
#
|
||||
# TP7 Compatible RTL Units
|
||||
#
|
||||
|
||||
dos$(PPUEXT) : dos.pp $(INC)/filerec.inc $(INC)/textrec.inc \
|
||||
strings$(PPUEXT) $(SYSTEMPPU) win32.inc
|
||||
dos$(PPUEXT) : $(DOSDEPS) $(INC)/filerec.inc $(INC)/textrec.inc $(SYSTEMPPU)
|
||||
$(PP) $(OPT) dos $(REDIR)
|
||||
|
||||
#crt$(PPUEXT) : crt.pp $(INC)/textrec.inc go32$(PPUEXT) $(SYSTEMPPU)
|
||||
# $(PP) $(OPT) crt $(REDIR)
|
||||
|
||||
#objects$(PPUEXT) : objects.pp $(SYSTEMPPU)
|
||||
# $(PP) $(OPT) objects.pp $(REDIR)
|
||||
|
||||
#printer$(PPUEXT) : printer.pp $(SYSTEMPPU)
|
||||
# $(PP) $(OPT) printer.pp $(REDIR)
|
||||
#objects$(PPUEXT) : $(INC)/objects.pp objinc.inc $(SYSTEMPPU)
|
||||
# $(COPY) $(INC)/objects.pp .
|
||||
# $(PP) $(OPT) objects $(REDIR)
|
||||
# $(DEL) objects.pp
|
||||
|
||||
#
|
||||
# Other RTL Units
|
||||
#
|
||||
|
||||
cpu$(PPUEXT) : $(PROCINC)/cpu.pp $(SYSTEMPPU)
|
||||
$(COPY) $(PROCINC)/cpu.pp .
|
||||
$(PP) $(OPT) cpu.pp $(REDIR)
|
||||
$(DEL) cpu.pp
|
||||
|
||||
mmx$(PPUEXT) : $(PROCINC)/mmx.pp cpu$(PPUEXT) $(SYSTEMPPU)
|
||||
$(COPY) $(PROCINC)/mmx.pp .
|
||||
$(PP) $(OPT) mmx.pp $(REDIR)
|
||||
$(DEL) mmx.pp
|
||||
|
||||
getopts$(PPUEXT) : $(PROCINC)/getopts.pp $(SYSTEMPPU)
|
||||
$(COPY) $(PROCINC)/getopts.pp .
|
||||
$(PP) $(OPT) getopts.pp $(REDIR)
|
||||
$(DEL) getopts.pp
|
||||
|
||||
|
||||
#####################################################################
|
||||
# Libs
|
||||
#####################################################################
|
||||
|
||||
libs: all
|
||||
libs : all libfpc$(LIBEXT)
|
||||
|
||||
libfpc.so:
|
||||
$(PPUMOVE) -o fpc *.ppu
|
||||
|
||||
libfpc.a:
|
||||
$(PPUMOVE) -s -o fpc *.ppu
|
||||
|
||||
libinstall : libs
|
||||
$(INSTALLEXE) libfpc$(LIBEXT) $(LIBINSTALLDIR)
|
||||
$(INSTALL) *$(PPLEXT) $(UNITINSTALLDIR)
|
||||
ldconfig
|
||||
|
||||
libsclean : clean
|
||||
-$(DEL) *.$(LIBEXT) *$(PPLEXT)
|
||||
-$(DEL) *.a *.so *$(PPLEXT)
|
||||
|
||||
#####################################################################
|
||||
# Diffs
|
||||
# Default targets
|
||||
#####################################################################
|
||||
|
||||
%.dif : %.pp
|
||||
-$(DIFF) $(DIFFOPTS) $*.pp $(REFPATH)/dos/go32v1/$*.pp > $*.dif
|
||||
|
||||
%.dif : %.inc
|
||||
-$(DIFF) $(DIFFOPTS) $*.inc $(REFPATH)/dos/go32v1/$*.inc > $*.dif
|
||||
|
||||
%.dif : %.as
|
||||
-$(DIFF) $(DIFFOPTS) $*.as $(REFPATH)/dos/go32v1/$*.as > $*.dif
|
||||
|
||||
diffclean:
|
||||
-$(DEL) *.dif
|
||||
|
||||
makefile.dif : makefile
|
||||
-$(DIFF) $(DIFFOPTS) makefile $(REFPATH)/dos/go32v1/makefile > makefile.dif
|
||||
|
||||
diffs: syswin32.dif os.dif makefile.dif dos.dif base.dif struct.dif \
|
||||
winheap.dif messages.dif
|
||||
|
||||
#####################################################################
|
||||
# Distribution
|
||||
#####################################################################
|
||||
|
||||
distclean : clean libsclean diffclean
|
||||
|
||||
include $(CFG)/makefile.def
|
||||
|
||||
@ -244,7 +244,7 @@ unit messages;
|
||||
HDM_GETITEM = HDM_GETITEMA;
|
||||
HDM_INSERTITEM = HDM_INSERTITEMA;
|
||||
HDM_SETITEM = HDM_SETITEMA;
|
||||
{$endifUNICODE}
|
||||
{$endif UNICODE}
|
||||
HDM_GETITEMCOUNT = 4608;
|
||||
HDM_HITTEST = 4614;
|
||||
{ Header control notifications }
|
||||
@ -371,6 +371,8 @@ unit messages;
|
||||
LVM_INSERTCOLUMNA = 4123;
|
||||
LVM_INSERTITEMA = 4103;
|
||||
LVM_SETCOLUMNA = 4122;
|
||||
LVM_SETITEMA = 4102;
|
||||
LVM_SETITEMTEXTA = 4242;
|
||||
{$ifdef UNICODE}
|
||||
LVM_SETITEMA = 4102;
|
||||
LVM_SETITEMTEXTA = 4142;
|
||||
@ -1048,9 +1050,7 @@ end.
|
||||
|
||||
{
|
||||
$Log$
|
||||
Revision 1.2 1998-05-06 12:36:50 michael
|
||||
+ Removed log from before restored version.
|
||||
Revision 1.3 1998-06-10 10:39:15 peter
|
||||
* working w32 rtl
|
||||
|
||||
Revision 1.1.1.1 1998/03/25 11:18:46 root
|
||||
* Restored version
|
||||
}
|
||||
|
||||
@ -13,16 +13,14 @@
|
||||
**********************************************************************}
|
||||
|
||||
{$define win32}
|
||||
{$undef go32v1}
|
||||
{$undef go32v2}
|
||||
{$undef os2}
|
||||
{$undef linux}
|
||||
{$undef dos}
|
||||
|
||||
{
|
||||
$Log$
|
||||
Revision 1.2 1998-05-06 12:37:22 michael
|
||||
+ Removed log from before restored version.
|
||||
Revision 1.3 1998-06-10 10:39:16 peter
|
||||
* working w32 rtl
|
||||
|
||||
Revision 1.1.1.1 1998/03/25 11:18:47 root
|
||||
* Restored version
|
||||
}
|
||||
|
||||
@ -1,11 +1,11 @@
|
||||
{
|
||||
$Id$
|
||||
This file is part of the Free Pascal run time library.
|
||||
FPC Pascal system unit for the Win32 API.
|
||||
|
||||
Copyright (c) 1993-98 by Florian Klaempfl and Pavel Ozerski
|
||||
member of the Free Pascal development team.
|
||||
|
||||
FPC Pascal system unit for the Win32 API.
|
||||
|
||||
See the file COPYING.FPC, included in this distribution,
|
||||
for details about the copyright.
|
||||
|
||||
@ -14,245 +14,309 @@
|
||||
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
|
||||
|
||||
**********************************************************************}
|
||||
{$S-}
|
||||
unit syswin32;
|
||||
|
||||
{$I os.inc}
|
||||
|
||||
interface
|
||||
interface
|
||||
|
||||
{$I systemh.inc}
|
||||
{ include system-independent routine headers }
|
||||
|
||||
var
|
||||
hprevinst,hinstance,cmdshow : longint;
|
||||
heaperror : pointer;
|
||||
{$I systemh.inc}
|
||||
|
||||
{ $I heaph.inc}
|
||||
const
|
||||
{ Default filehandles }
|
||||
UnusedHandle : longint = -1;
|
||||
StdInputHandle : longint = 0;
|
||||
StdOutputHandle : longint = 0;
|
||||
StdErrorHandle : longint = 0;
|
||||
|
||||
const
|
||||
UnusedHandle : longint = -1;
|
||||
StdInputHandle : longint = 0;
|
||||
StdOutputHandle : longint = 0;
|
||||
StdErrorHandle : longint = 0;
|
||||
type
|
||||
TStartupInfo=packed record
|
||||
cb : longint;
|
||||
lpReserved : Pointer;
|
||||
lpDesktop : Pointer;
|
||||
lpTitle : Pointer;
|
||||
dwX : longint;
|
||||
dwY : longint;
|
||||
dwXSize : longint;
|
||||
dwYSize : longint;
|
||||
dwXCountChars : longint;
|
||||
dwYCountChars : longint;
|
||||
dwFillAttribute : longint;
|
||||
dwFlags : longint;
|
||||
wShowWindow : Word;
|
||||
cbReserved2 : Word;
|
||||
lpReserved2 : Pointer;
|
||||
hStdInput : longint;
|
||||
hStdOutput : longint;
|
||||
hStdError : longint;
|
||||
end;
|
||||
|
||||
implementation
|
||||
var
|
||||
startupinfo : tstartupinfo;
|
||||
hprevinst,
|
||||
hinstance,
|
||||
cmdshow : longint;
|
||||
heaperror : pointer;
|
||||
|
||||
{ some declarations for Win32 API calls }
|
||||
{$I Win32.inc}
|
||||
{$I system.inc}
|
||||
implementation
|
||||
|
||||
{ include system independent routines }
|
||||
|
||||
{$I system.inc}
|
||||
|
||||
{ some declarations for Win32 API calls }
|
||||
{$I win32.inc}
|
||||
|
||||
type
|
||||
plongint = ^longint;
|
||||
|
||||
{ misc. functions }
|
||||
function GetLastError : DWORD;
|
||||
external 'kernel32' name 'GetLastError';
|
||||
function MessageBox(w1:longint;l1,l2:pointer;w2:longint):longint;
|
||||
external 'user32' name 'MessageBoxA';
|
||||
|
||||
{ command line/enviroment functions }
|
||||
function GetCommandLine : LPTSTR;
|
||||
external 'kernel32' name 'GetCommandLineA';
|
||||
{ time and date functions }
|
||||
function GetTickCount : longint;
|
||||
external 'kernel32' name 'GetTickCount';
|
||||
{ process functions }
|
||||
procedure ExitProcess(uExitCode : UINT);
|
||||
external 'kernel32' name 'ExitProcess';
|
||||
|
||||
type
|
||||
plongint = ^longint;
|
||||
|
||||
{$ifdef dummy}
|
||||
{$S-}
|
||||
procedure st1(stack_size : longint);[public,alias: 'STACKCHECK'];
|
||||
|
||||
begin
|
||||
{ called when trying to get local stack }
|
||||
{ if the compiler directive $S is set }
|
||||
{ this function must preserve esi !!!! }
|
||||
{ because esi is set by the calling }
|
||||
{ proc for methods }
|
||||
{ it must preserve all registers !! }
|
||||
|
||||
asm
|
||||
pushl %eax
|
||||
pushl %ebx
|
||||
movl stack_size,%ebx
|
||||
movl %esp,%eax
|
||||
subl %ebx,%eax
|
||||
procedure int_stackcheck(stack_size:longint);[public,alias: 'STACKCHECK'];
|
||||
{
|
||||
called when trying to get local stack if the compiler directive $S
|
||||
is set this function must preserve esi !!!! because esi is set by
|
||||
the calling proc for methods it must preserve all registers !!
|
||||
}
|
||||
begin
|
||||
asm
|
||||
pushl %eax
|
||||
pushl %ebx
|
||||
movl stack_size,%ebx
|
||||
movl %esp,%eax
|
||||
subl %ebx,%eax
|
||||
{$ifdef SYSTEMDEBUG}
|
||||
movl U_SYSTEM_LOWESTSTACK,%ebx
|
||||
cmpl %eax,%ebx
|
||||
jb _is_not_lowest
|
||||
movl %eax,U_SYSTEM_LOWESTSTACK
|
||||
_is_not_lowest:
|
||||
movl U_SYSTEM_LOWESTSTACK,%ebx
|
||||
cmpl %eax,%ebx
|
||||
jb _is_not_lowest
|
||||
movl %eax,U_SYSTEM_LOWESTSTACK
|
||||
_is_not_lowest:
|
||||
{$endif SYSTEMDEBUG}
|
||||
movl __stkbottom,%ebx
|
||||
cmpl %eax,%ebx
|
||||
jae __short_on_stack
|
||||
popl %ebx
|
||||
popl %eax
|
||||
leave
|
||||
ret $4
|
||||
__short_on_stack:
|
||||
{ can be usefull for error recovery !! }
|
||||
popl %ebx
|
||||
popl %eax
|
||||
end['EAX','EBX'];
|
||||
RunError(202);
|
||||
{ this needs a local variable }
|
||||
{ so the function called itself !! }
|
||||
{ Writeln('low in stack ');
|
||||
RunError(202); }
|
||||
end;
|
||||
movl __stkbottom,%ebx
|
||||
cmpl %eax,%ebx
|
||||
jae __short_on_stack
|
||||
popl %ebx
|
||||
popl %eax
|
||||
leave
|
||||
ret $4
|
||||
__short_on_stack:
|
||||
{ can be usefull for error recovery !! }
|
||||
popl %ebx
|
||||
popl %eax
|
||||
end['EAX','EBX'];
|
||||
RunError(202);
|
||||
end;
|
||||
{$endif dummy}
|
||||
|
||||
procedure halt(errnum : byte);
|
||||
|
||||
begin
|
||||
do_exit;
|
||||
flush(stderr);
|
||||
ExitProcess(errnum);
|
||||
end;
|
||||
procedure halt(errnum : byte);
|
||||
begin
|
||||
do_exit;
|
||||
flush(stderr);
|
||||
ExitProcess(errnum);
|
||||
end;
|
||||
|
||||
function paramcount : longint;
|
||||
|
||||
var
|
||||
count : longint;
|
||||
cmdline : pchar;
|
||||
quote : set of char;
|
||||
|
||||
begin
|
||||
cmdline:=GetCommandLine;
|
||||
count:=0;
|
||||
while true do
|
||||
begin
|
||||
{ skip leading spaces }
|
||||
while cmdline^ in [' ',#9] do
|
||||
cmdline:=cmdline+1;
|
||||
if cmdline^='"' then
|
||||
begin
|
||||
quote:=['"'];
|
||||
cmdline:=cmdline+1;
|
||||
end
|
||||
else
|
||||
quote:=[' ',#9];
|
||||
if cmdline^=#0 then
|
||||
break;
|
||||
inc(count);
|
||||
while (cmdline^<>#0) and not(cmdline^ in quote) do
|
||||
cmdline:=cmdline+1;
|
||||
{ skip quote }
|
||||
if cmdline^ in quote then
|
||||
cmdline:=cmdline+1;
|
||||
end;
|
||||
paramcount:=count-1;
|
||||
end;
|
||||
|
||||
function paramstr(l : longint) : string;
|
||||
|
||||
var
|
||||
s : string;
|
||||
count : longint;
|
||||
cmdline : pchar;
|
||||
quote : set of char;
|
||||
|
||||
begin
|
||||
s:='';
|
||||
if (l>=0) and (l<=paramcount) then
|
||||
begin
|
||||
cmdline:=GetCommandLine;
|
||||
count:=0;
|
||||
while true do
|
||||
begin
|
||||
{ skip leading spaces }
|
||||
while cmdline^ in [' ',#9] do
|
||||
cmdline:=cmdline+1;
|
||||
if cmdline^='"' then
|
||||
begin
|
||||
quote:=['"'];
|
||||
cmdline:=cmdline+1;
|
||||
end
|
||||
else
|
||||
quote:=[' ',#9];
|
||||
if cmdline^=#0 then
|
||||
break;
|
||||
if count=l then
|
||||
begin
|
||||
while (cmdline^<>#0) and not(cmdline^ in quote) do
|
||||
begin
|
||||
s:=s+cmdline^;
|
||||
cmdline:=cmdline+1;
|
||||
end;
|
||||
break;
|
||||
end
|
||||
else
|
||||
begin
|
||||
while (cmdline^<>#0) and not(cmdline^ in quote) do
|
||||
cmdline:=cmdline+1;
|
||||
end;
|
||||
{ skip quote }
|
||||
if cmdline^ in quote then
|
||||
cmdline:=cmdline+1;
|
||||
inc(count);
|
||||
end;
|
||||
|
||||
end;
|
||||
paramstr:=s;
|
||||
end;
|
||||
|
||||
procedure randomize;
|
||||
|
||||
begin
|
||||
randseed:=GetTickCount;
|
||||
end;
|
||||
|
||||
{$i winheap.inc}
|
||||
{ $I heap.inc}
|
||||
|
||||
{****************************************************************************
|
||||
Low Level File Routines
|
||||
****************************************************************************}
|
||||
|
||||
procedure AllowSlash(p:pchar);
|
||||
|
||||
var
|
||||
i : longint;
|
||||
|
||||
begin
|
||||
{ allow slash as backslash }
|
||||
for i:=0 to strlen(p) do
|
||||
if p[i]='/' then p[i]:='\';
|
||||
end;
|
||||
|
||||
procedure do_close(h : longint);
|
||||
|
||||
begin
|
||||
closehandle(h);
|
||||
end;
|
||||
|
||||
procedure do_erase(p : pchar);
|
||||
|
||||
begin
|
||||
AllowSlash(p);
|
||||
if DeleteFile(p)=0 then
|
||||
inoutres:=GetLastError;
|
||||
end;
|
||||
|
||||
procedure do_rename(p1,p2 : pchar);
|
||||
|
||||
function paramcount : longint;
|
||||
var
|
||||
count : longint;
|
||||
cmdline : pchar;
|
||||
quote : set of char;
|
||||
begin
|
||||
cmdline:=GetCommandLine;
|
||||
count:=0;
|
||||
while true do
|
||||
begin
|
||||
{ skip leading spaces }
|
||||
while cmdline^ in [' ',#9] do
|
||||
cmdline:=cmdline+1;
|
||||
if cmdline^='"' then
|
||||
begin
|
||||
AllowSlash(p1);
|
||||
AllowSlash(p2);
|
||||
if MoveFile(p1,p2)=0 then
|
||||
inoutres:=GetLastError;
|
||||
end;
|
||||
quote:=['"'];
|
||||
cmdline:=cmdline+1;
|
||||
end
|
||||
else
|
||||
quote:=[' ',#9];
|
||||
if cmdline^=#0 then
|
||||
break;
|
||||
inc(count);
|
||||
while (cmdline^<>#0) and not(cmdline^ in quote) do
|
||||
cmdline:=cmdline+1;
|
||||
{ skip quote }
|
||||
if cmdline^ in quote then
|
||||
cmdline:=cmdline+1;
|
||||
end;
|
||||
paramcount:=count-1;
|
||||
end;
|
||||
|
||||
function do_write(h,addr,len : longint) : longint;
|
||||
|
||||
var
|
||||
size:longint;
|
||||
function paramstr(l : longint) : string;
|
||||
var
|
||||
s : string;
|
||||
count : longint;
|
||||
cmdline : pchar;
|
||||
quote : set of char;
|
||||
begin
|
||||
s:='';
|
||||
if (l>=0) and (l<=paramcount) then
|
||||
begin
|
||||
cmdline:=GetCommandLine;
|
||||
count:=0;
|
||||
while true do
|
||||
begin
|
||||
{ skip leading spaces }
|
||||
while cmdline^ in [' ',#9] do
|
||||
cmdline:=cmdline+1;
|
||||
if cmdline^='"' then
|
||||
begin
|
||||
quote:=['"'];
|
||||
cmdline:=cmdline+1;
|
||||
end
|
||||
else
|
||||
quote:=[' ',#9];
|
||||
if cmdline^=#0 then
|
||||
break;
|
||||
if count=l then
|
||||
begin
|
||||
while (cmdline^<>#0) and not(cmdline^ in quote) do
|
||||
begin
|
||||
s:=s+cmdline^;
|
||||
cmdline:=cmdline+1;
|
||||
end;
|
||||
break;
|
||||
end
|
||||
else
|
||||
begin
|
||||
while (cmdline^<>#0) and not(cmdline^ in quote) do
|
||||
cmdline:=cmdline+1;
|
||||
end;
|
||||
{ skip quote }
|
||||
if cmdline^ in quote then
|
||||
cmdline:=cmdline+1;
|
||||
inc(count);
|
||||
end;
|
||||
|
||||
end;
|
||||
paramstr:=s;
|
||||
end;
|
||||
|
||||
|
||||
procedure randomize;
|
||||
begin
|
||||
randseed:=GetTickCount;
|
||||
end;
|
||||
|
||||
|
||||
{*****************************************************************************
|
||||
Heap Management
|
||||
*****************************************************************************}
|
||||
|
||||
{ Include Windows Heap manager }
|
||||
{$I winheap.inc}
|
||||
|
||||
{*****************************************************************************
|
||||
Low Level File Routines
|
||||
*****************************************************************************}
|
||||
|
||||
function WriteFile(fh:longint;buf:pointer;len:longint;var loaded:longint;
|
||||
overlap:pointer):longint;
|
||||
external 'kernel32' name 'WriteFile';
|
||||
function ReadFile(fh:longint;buf:pointer;len:longint;var loaded:longint;
|
||||
overlap:pointer):longint;
|
||||
external 'kernel32' name 'ReadFile';
|
||||
function CloseHandle(h : longint) : longint;
|
||||
external 'kernel32' name 'CloseHandle';
|
||||
function DeleteFile(p : pchar) : longint;
|
||||
external 'kernel32' name 'DeleteFileA';
|
||||
function MoveFile(old,_new : pchar) : longint;
|
||||
external 'kernel32' name 'MoveFileA';
|
||||
function SetFilePointer(l1,l2 : longint;l3 : pointer;l4 : longint) : longint;
|
||||
external 'kernel32' name 'SetFilePointer';
|
||||
function GetFileSize(h:longint;p:pointer) : longint;
|
||||
external 'kernel32' name 'GetFileSize';
|
||||
function CreateFile(name : pointer;access,sharing : longint;
|
||||
security : pointer;how,attr,template : longint) : longint;
|
||||
external 'kernel32' name 'CreateFileA';
|
||||
function SetEndOfFile(h : longint) : boolean;
|
||||
external 'kernel32' name 'SetEndOfFile';
|
||||
|
||||
|
||||
procedure AllowSlash(p:pchar);
|
||||
var
|
||||
i : longint;
|
||||
begin
|
||||
{ allow slash as backslash }
|
||||
for i:=0 to strlen(p) do
|
||||
if p[i]='/' then p[i]:='\';
|
||||
end;
|
||||
|
||||
|
||||
procedure do_close(h : longint);
|
||||
begin
|
||||
closehandle(h);
|
||||
end;
|
||||
|
||||
|
||||
procedure do_erase(p : pchar);
|
||||
begin
|
||||
AllowSlash(p);
|
||||
if DeleteFile(p)=0 then
|
||||
inoutres:=GetLastError;
|
||||
end;
|
||||
|
||||
|
||||
procedure do_rename(p1,p2 : pchar);
|
||||
begin
|
||||
AllowSlash(p1);
|
||||
AllowSlash(p2);
|
||||
if MoveFile(p1,p2)=0 then
|
||||
inoutres:=GetLastError;
|
||||
end;
|
||||
|
||||
|
||||
function do_write(h,addr,len : longint) : longint;
|
||||
var
|
||||
size:longint;
|
||||
begin
|
||||
if writefile(h,pointer(addr),len,size,nil)=0 then
|
||||
inoutres:=GetLastError;
|
||||
do_write:=size;
|
||||
end;
|
||||
|
||||
begin
|
||||
if writefile(h,pointer(addr),len,size,nil)=0 then
|
||||
inoutres:=GetLastError;
|
||||
do_write:=size;
|
||||
end;
|
||||
|
||||
function do_read(h,addr,len : longint) : longint;
|
||||
var
|
||||
var
|
||||
result:longint;
|
||||
begin
|
||||
begin
|
||||
if readfile(h,pointer(addr),len,result,nil)=0 then
|
||||
inoutres:=GetLastError;
|
||||
do_read:=result;
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
function do_filepos(handle : longint) : longint;
|
||||
var
|
||||
var
|
||||
l:longint;
|
||||
begin
|
||||
begin
|
||||
l:=SetFilePointer(handle,0,nil,FILE_CURRENT);
|
||||
if l=-1 then
|
||||
begin
|
||||
@ -260,7 +324,8 @@ function do_filepos(handle : longint) : longint;
|
||||
inoutres:=GetLastError;
|
||||
end;
|
||||
do_filepos:=l;
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
procedure do_seek(handle,pos : longint);
|
||||
begin
|
||||
@ -268,8 +333,8 @@ begin
|
||||
inoutres:=GetLastError;
|
||||
end;
|
||||
|
||||
function do_seekend(handle:longint):longint;
|
||||
|
||||
function do_seekend(handle:longint):longint;
|
||||
begin
|
||||
do_seekend:=SetFilePointer(handle,0,nil,FILE_END);
|
||||
if do_seekend=-1 then
|
||||
@ -282,14 +347,14 @@ end;
|
||||
|
||||
function do_filesize(handle : longint) : longint;
|
||||
var
|
||||
aktfilepos : longint;
|
||||
aktfilepos : longint;
|
||||
begin
|
||||
aktfilepos:=do_filepos(handle);
|
||||
do_filesize:=do_seekend(handle);
|
||||
do_seek(handle,aktfilepos);
|
||||
aktfilepos:=do_filepos(handle);
|
||||
do_filesize:=do_seekend(handle);
|
||||
do_seek(handle,aktfilepos);
|
||||
end;
|
||||
|
||||
{ truncate at a given position }
|
||||
|
||||
procedure do_truncate (handle,pos:longint);
|
||||
begin
|
||||
do_seek(handle,pos);
|
||||
@ -297,94 +362,85 @@ begin
|
||||
inoutres:=GetLastError;
|
||||
end;
|
||||
|
||||
|
||||
procedure do_open(var f;p : pchar;flags:longint);
|
||||
|
||||
{
|
||||
filerec and textrec have both handle and mode as the first items so
|
||||
they could use the same routine for opening/creating.
|
||||
when (flags and $10) the file will be append
|
||||
when (flags and $100) the file will be truncate/rewritten
|
||||
when (flags and $1000) there is no check for close (needed for textfiles)
|
||||
}
|
||||
{
|
||||
filerec and textrec have both handle and mode as the first items so
|
||||
they could use the same routine for opening/creating.
|
||||
when (flags and $10) the file will be append
|
||||
when (flags and $100) the file will be truncate/rewritten
|
||||
when (flags and $1000) there is no check for close (needed for textfiles)
|
||||
}
|
||||
|
||||
var
|
||||
oflags,cd : longint;
|
||||
|
||||
begin
|
||||
AllowSlash(p);
|
||||
{ close first if opened }
|
||||
if ((flags and $1000)=0) then
|
||||
begin
|
||||
case filerec(f).mode of
|
||||
fminput,fmoutput,fminout:
|
||||
Do_Close(filerec(f).handle);
|
||||
fmclosed:
|
||||
;
|
||||
else
|
||||
begin
|
||||
{not assigned}
|
||||
inoutres:=102;
|
||||
exit;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
{ reset file handle }
|
||||
filerec(f).handle:=UnusedHandle;
|
||||
{ convert filemode to filerec modes }
|
||||
case (flags and 3) of
|
||||
0:
|
||||
begin
|
||||
filerec(f).mode:=fminput;
|
||||
oflags:=GENERIC_READ;
|
||||
end;
|
||||
1:
|
||||
begin
|
||||
filerec(f).mode:=fmoutput;
|
||||
oflags:=GENERIC_WRITE;
|
||||
end;
|
||||
2:
|
||||
begin
|
||||
filerec(f).mode:=fminout;
|
||||
oflags:=GENERIC_WRITE or GENERIC_READ;
|
||||
end;
|
||||
end;
|
||||
{ standard is opening and existing file }
|
||||
cd:=OPEN_EXISTING;
|
||||
|
||||
{ create it ? }
|
||||
if (flags and $100)<>0 then
|
||||
cd:=CREATE_ALWAYS
|
||||
|
||||
{ or append ? }
|
||||
else if (flags and $10)<>0 then
|
||||
cd:=OPEN_ALWAYS;
|
||||
|
||||
{ empty name is special }
|
||||
if p[0]=#0 then
|
||||
begin
|
||||
case filerec(f).mode of
|
||||
fminput:
|
||||
filerec(f).handle:=StdInputHandle;
|
||||
fmappend,
|
||||
fmoutput:
|
||||
begin
|
||||
filerec(f).handle:=StdOutputHandle;
|
||||
filerec(f).mode:=fmoutput; {fool fmappend}
|
||||
end;
|
||||
end;
|
||||
var
|
||||
oflags,cd : longint;
|
||||
begin
|
||||
AllowSlash(p);
|
||||
{ close first if opened }
|
||||
if ((flags and $1000)=0) then
|
||||
begin
|
||||
case filerec(f).mode of
|
||||
fminput,fmoutput,fminout : Do_Close(filerec(f).handle);
|
||||
fmclosed : ;
|
||||
else
|
||||
begin
|
||||
{not assigned}
|
||||
inoutres:=102;
|
||||
exit;
|
||||
end;
|
||||
end;
|
||||
filerec(f).handle:=CreateFile(p,oflags,0,nil,cd,FILE_ATTRIBUTE_NORMAL,0);
|
||||
|
||||
{ append mode }
|
||||
if (flags and $10)<>0 then
|
||||
begin
|
||||
do_seekend(filerec(f).handle);
|
||||
filerec(f).mode:=fmoutput; {fool fmappend}
|
||||
end;
|
||||
if filerec(f).handle=0 then
|
||||
inoutres:=GetLastError;
|
||||
end;
|
||||
{ reset file handle }
|
||||
filerec(f).handle:=UnusedHandle;
|
||||
{ convert filemode to filerec modes }
|
||||
case (flags and 3) of
|
||||
0 : begin
|
||||
filerec(f).mode:=fminput;
|
||||
oflags:=GENERIC_READ;
|
||||
end;
|
||||
1 : begin
|
||||
filerec(f).mode:=fmoutput;
|
||||
oflags:=GENERIC_WRITE;
|
||||
end;
|
||||
2 : begin
|
||||
filerec(f).mode:=fminout;
|
||||
oflags:=GENERIC_WRITE or GENERIC_READ;
|
||||
end;
|
||||
end;
|
||||
{ standard is opening and existing file }
|
||||
cd:=OPEN_EXISTING;
|
||||
{ create it ? }
|
||||
if (flags and $100)<>0 then
|
||||
cd:=CREATE_ALWAYS
|
||||
{ or append ? }
|
||||
else
|
||||
if (flags and $10)<>0 then
|
||||
cd:=OPEN_ALWAYS;
|
||||
{ empty name is special }
|
||||
if p[0]=#0 then
|
||||
begin
|
||||
case filerec(f).mode of
|
||||
fminput : filerec(f).handle:=StdInputHandle;
|
||||
fmappend,
|
||||
fmoutput : begin
|
||||
filerec(f).handle:=StdOutputHandle;
|
||||
filerec(f).mode:=fmoutput; {fool fmappend}
|
||||
end;
|
||||
end;
|
||||
exit;
|
||||
end;
|
||||
filerec(f).handle:=CreateFile(p,oflags,0,nil,cd,FILE_ATTRIBUTE_NORMAL,0);
|
||||
{ append mode }
|
||||
if (flags and $10)<>0 then
|
||||
begin
|
||||
do_seekend(filerec(f).handle);
|
||||
filerec(f).mode:=fmoutput; {fool fmappend}
|
||||
end;
|
||||
{ get errors }
|
||||
if filerec(f).handle=0 then
|
||||
inoutres:=GetLastError;
|
||||
end;
|
||||
|
||||
{*****************************************************************************
|
||||
UnTyped File Handling
|
||||
@ -410,6 +466,15 @@ procedure do_open(var f;p : pchar;flags:longint);
|
||||
Directory Handling
|
||||
*****************************************************************************}
|
||||
|
||||
function CreateDirectory(name : pointer;sec : pointer) : longint;
|
||||
external 'kernel32' name 'CreateDirectoryA';
|
||||
function RemoveDirectory(name:pointer):longint;
|
||||
external 'kernel32' name 'RemoveDirectoryA';
|
||||
function SetCurrentDirectory(name : pointer) : longint;
|
||||
external 'kernel32' name 'SetCurrentDirectoryA';
|
||||
function GetCurrentDirectory(bufsize : longint;name : pchar) : longint;
|
||||
external 'kernel32' name 'GetCurrentDirectoryA';
|
||||
|
||||
type
|
||||
TDirFnType=function(name:pointer):word;
|
||||
|
||||
@ -468,6 +533,19 @@ procedure getdir(drivenr:byte;var dir:string);
|
||||
SystemUnit Initialization
|
||||
*****************************************************************************}
|
||||
|
||||
{ Startup }
|
||||
procedure GetStartupInfo(p : pointer);
|
||||
external 'kernel32' name 'GetStartupInfoA';
|
||||
function GetStdHandle(nStdHandle:DWORD):THANDLE;
|
||||
external 'kernel32' name 'GetStdHandle';
|
||||
|
||||
{ module functions }
|
||||
function GetModuleFileName(l1:longint;p:pointer;l2:longint):longint;
|
||||
external 'kernel32' name 'GetModuleFileNameA';
|
||||
function GetModuleHandle(p : pointer) : longint;
|
||||
external 'kernel32' name 'GetModuleHandleA';
|
||||
|
||||
|
||||
{$ASMMODE DIRECT}
|
||||
|
||||
procedure Entry;[public,alias: '_mainCRTStartup'];
|
||||
@ -493,32 +571,9 @@ begin
|
||||
TextRec(f).Closefunc:=@fileclosefunc;
|
||||
end;
|
||||
|
||||
{$PACKRECORDS 1}
|
||||
|
||||
var
|
||||
s : string;
|
||||
StartupInfo : record
|
||||
cb : longint;
|
||||
lpReserved : Pointer;
|
||||
lpDesktop : Pointer;
|
||||
lpTitle : Pointer;
|
||||
dwX : longint;
|
||||
dwY : longint;
|
||||
dwXSize : longint;
|
||||
dwYSize : longint;
|
||||
dwXCountChars : longint;
|
||||
dwYCountChars : longint;
|
||||
dwFillAttribute : longint;
|
||||
dwFlags : longint;
|
||||
wShowWindow : Word;
|
||||
cbReserved2 : Word;
|
||||
lpReserved2 : Pointer;
|
||||
hStdInput : longint;
|
||||
hStdOutput : longint;
|
||||
hStdError : longint;
|
||||
end;
|
||||
|
||||
{$PACKRECORDS NORMAL}
|
||||
|
||||
s : string;
|
||||
begin
|
||||
{ get some helpful informations }
|
||||
GetStartupInfo(@startupinfo);
|
||||
@ -546,7 +601,10 @@ end.
|
||||
|
||||
{
|
||||
$Log$
|
||||
Revision 1.8 1998-06-08 23:07:47 peter
|
||||
Revision 1.9 1998-06-10 10:39:17 peter
|
||||
* working w32 rtl
|
||||
|
||||
Revision 1.8 1998/06/08 23:07:47 peter
|
||||
* dos interface is now 100% compatible
|
||||
* fixed call PASCALMAIN which must be direct asm
|
||||
|
||||
@ -564,10 +622,4 @@ end.
|
||||
|
||||
Revision 1.3 1998/04/26 21:49:57 florian
|
||||
+ more stuff added (??dir procedures etc.)
|
||||
|
||||
Revision 1.2 1998/03/27 00:50:22 peter
|
||||
* small fixes so it compiles
|
||||
|
||||
Revision 1.1.1.1 1998/03/25 11:18:47 root
|
||||
* Restored version
|
||||
}
|
||||
|
||||
@ -1,11 +1,9 @@
|
||||
{
|
||||
$Id$
|
||||
This file contains the Win32-API import declarations
|
||||
for the system unit and the DOS unit
|
||||
|
||||
This file is part of the Free Pascal run time library.
|
||||
Copyright (c) 1997,98 by Florian Klaempfl,
|
||||
member of the Free Pascal development team.
|
||||
Copyright (c) 1998 by the Free Pascal development team.
|
||||
|
||||
Win32 Types and Constants
|
||||
|
||||
See the file COPYING.FPC, included in this distribution,
|
||||
for details about the copyright.
|
||||
@ -16,204 +14,97 @@
|
||||
|
||||
**********************************************************************}
|
||||
|
||||
const
|
||||
{ constants for GetStdHandle }
|
||||
STD_INPUT_HANDLE = $fffffff6;
|
||||
STD_OUTPUT_HANDLE = $fffffff5;
|
||||
STD_ERROR_HANDLE = $fffffff4;
|
||||
INVALID_HANDLE_VALUE = $ffffffff;
|
||||
const
|
||||
{ constants for GetStdHandle }
|
||||
STD_INPUT_HANDLE = $fffffff6;
|
||||
STD_OUTPUT_HANDLE = $fffffff5;
|
||||
STD_ERROR_HANDLE = $fffffff4;
|
||||
INVALID_HANDLE_VALUE = $ffffffff;
|
||||
|
||||
{ flags for CreateFile }
|
||||
GENERIC_READ=$80000000;
|
||||
GENERIC_WRITE=$40000000;
|
||||
CREATE_NEW = 1;
|
||||
CREATE_ALWAYS = 2;
|
||||
OPEN_EXISTING = 3;
|
||||
OPEN_ALWAYS = 4;
|
||||
TRUNCATE_EXISTING = 5;
|
||||
IGNORE = 0; { Ignore signal }
|
||||
INFINITE = $FFFFFFFF; { Infinite timeout }
|
||||
|
||||
FILE_ATTRIBUTE_ARCHIVE = 32;
|
||||
FILE_ATTRIBUTE_COMPRESSED = 2048;
|
||||
FILE_ATTRIBUTE_NORMAL = 128;
|
||||
FILE_ATTRIBUTE_DIRECTORY = 16;
|
||||
FILE_ATTRIBUTE_HIDDEN = 2;
|
||||
FILE_ATTRIBUTE_READONLY = 1;
|
||||
FILE_ATTRIBUTE_SYSTEM = 4;
|
||||
FILE_ATTRIBUTE_TEMPORARY = 256;
|
||||
{ flags for CreateFile }
|
||||
GENERIC_READ=$80000000;
|
||||
GENERIC_WRITE=$40000000;
|
||||
CREATE_NEW = 1;
|
||||
CREATE_ALWAYS = 2;
|
||||
OPEN_EXISTING = 3;
|
||||
OPEN_ALWAYS = 4;
|
||||
TRUNCATE_EXISTING = 5;
|
||||
|
||||
{ flags for SetFilePos }
|
||||
FILE_BEGIN = 0;
|
||||
FILE_CURRENT = 1;
|
||||
FILE_END = 2;
|
||||
FILE_ATTRIBUTE_ARCHIVE = 32;
|
||||
FILE_ATTRIBUTE_COMPRESSED = 2048;
|
||||
FILE_ATTRIBUTE_NORMAL = 128;
|
||||
FILE_ATTRIBUTE_DIRECTORY = 16;
|
||||
FILE_ATTRIBUTE_HIDDEN = 2;
|
||||
FILE_ATTRIBUTE_READONLY = 1;
|
||||
FILE_ATTRIBUTE_SYSTEM = 4;
|
||||
FILE_ATTRIBUTE_TEMPORARY = 256;
|
||||
|
||||
type
|
||||
UINT = longint;
|
||||
LPDWORD = ^DWORD;
|
||||
BOOL = longint;
|
||||
{ flags for SetFilePos }
|
||||
FILE_BEGIN = 0;
|
||||
FILE_CURRENT = 1;
|
||||
FILE_END = 2;
|
||||
|
||||
type
|
||||
UINT = longint;
|
||||
BOOL = longint;
|
||||
WCHAR = word;
|
||||
{$ifdef UNICODE}
|
||||
LPTCH = ^word;
|
||||
LPTSTR = ^word;
|
||||
LPCTSTR = ^word;
|
||||
LPTCH = ^word;
|
||||
LPTSTR = ^word;
|
||||
LPCTSTR = ^word;
|
||||
{$else UNICODE}
|
||||
LPTCH = ^char;
|
||||
LPTSTR = ^char;
|
||||
LPCTSTR = ^char;
|
||||
LPTCH = ^char;
|
||||
LPTSTR = ^char;
|
||||
LPCTSTR = ^char;
|
||||
{$endif UNICODE}
|
||||
PVOID = pointer;
|
||||
LPVOID = pointer;
|
||||
LPCVOID = pointer;
|
||||
HANDLE = pointer;
|
||||
HLOCAL = HANDLE;
|
||||
PSTR = pchar;
|
||||
PVOID = pointer;
|
||||
LPVOID = pointer;
|
||||
LPCVOID = pointer;
|
||||
LPDWORD = ^DWORD;
|
||||
THandle = longint;
|
||||
HLocal = THandle;
|
||||
PStr = pchar;
|
||||
LPStr = pchar;
|
||||
|
||||
OVERLAPPED = record
|
||||
Internal : DWORD;
|
||||
InternalHigh : DWORD;
|
||||
Offset : DWORD;
|
||||
OffsetHigh : DWORD;
|
||||
hEvent : HANDLE;
|
||||
end;
|
||||
PSecurityAttributes = ^TSecurityAttributes;
|
||||
TSecurityAttributes = record
|
||||
nLength : DWORD;
|
||||
lpSecurityDescriptor : Pointer;
|
||||
bInheritHandle : Boolean;
|
||||
end;
|
||||
|
||||
LPOVERLAPPED = ^OVERLAPPED;
|
||||
PProcessInformation = ^TProcessInformation;
|
||||
TProcessInformation = record
|
||||
hProcess: THandle;
|
||||
hThread: THandle;
|
||||
dwProcessId: DWORD;
|
||||
dwThreadId: DWORD;
|
||||
end;
|
||||
|
||||
SYSTEMTIME = record
|
||||
wYear,wMonth,wDayOfWeek,wDay,
|
||||
wHour,wMinute,wSecond,WMilliseconds : word;
|
||||
end;
|
||||
PFileTime = ^TFileTime;
|
||||
TFileTime = record
|
||||
dwLowDateTime,
|
||||
dwHighDateTime : DWORD;
|
||||
end;
|
||||
|
||||
FILETIME = record
|
||||
dwLowDateTime : longint;
|
||||
dwHighDateTime : longint;
|
||||
end;
|
||||
|
||||
PFILETIME = ^FILETIME;
|
||||
|
||||
{ command line/enviroment functions }
|
||||
function GetCommandLine : LPTSTR;
|
||||
external 'kernel32' name 'GetCommandLineA';
|
||||
function GetEnvironmentStrings : pchar;
|
||||
external 'kernel32' name 'GetEnvironmentStringsA';
|
||||
function FreeEnvironmentStrings(p : pchar) : boolean;
|
||||
external 'kernel32' name 'FreeEnvironmentStringsA';
|
||||
|
||||
{ string functions
|
||||
function lstrlen(lpString:LPCTSTR):longint;external;
|
||||
function lstrcat(lpString1:LPTSTR; lpString2:LPCTSTR):LPTSTR;external;
|
||||
function lstrcpy(lpString1:LPTSTR; lpString2:LPCTSTR):LPTSTR;external;
|
||||
}
|
||||
|
||||
{ process functions }
|
||||
procedure ExitProcess(uExitCode : UINT);
|
||||
external 'kernel32' name 'ExitProcess';
|
||||
|
||||
{ file functions }
|
||||
function GetStdHandle(nStdHandle:DWORD):HANDLE;
|
||||
external 'kernel32' name 'GetStdHandle';
|
||||
function WriteFile(fh:longint;buf:pointer;len:longint;var loaded:longint;
|
||||
overlap:pointer):longint;
|
||||
external 'kernel32' name 'WriteFile';
|
||||
function ReadFile(fh:longint;buf:pointer;len:longint;var loaded:longint;
|
||||
overlap:pointer):longint;
|
||||
external 'kernel32' name 'ReadFile';
|
||||
function CloseHandle(h : longint) : longint;
|
||||
external 'kernel32' name 'CloseHandle';
|
||||
function DeleteFile(p : pchar) : longint;
|
||||
external 'kernel32' name 'DeleteFileA';
|
||||
function MoveFile(old,_new : pchar) : longint;
|
||||
external 'kernel32' name 'MoveFileA';
|
||||
function SetFilePointer(l1,l2 : longint;l3 : pointer;l4 : longint) : longint;
|
||||
external 'kernel32' name 'SetFilePointer';
|
||||
function GetFileSize(h:longint;p:pointer) : longint;
|
||||
external 'kernel32' name 'GetFileSize';
|
||||
function CreateFile(name : pointer;access,sharing : longint;
|
||||
security : pointer;how,attr,template : longint) : longint;
|
||||
external 'kernel32' name 'CreateFileA';
|
||||
function CreateDirectory(name : pointer;sec : pointer) : longint;
|
||||
external 'kernel32' name 'CreateDirectoryA';
|
||||
function RemoveDirectory(name:pointer):longint;
|
||||
external 'kernel32' name 'RemoveDirectoryA';
|
||||
function SetCurrentDirectory(name : pointer) : longint;
|
||||
external 'kernel32' name 'SetCurrentDirectoryA';
|
||||
function GetCurrentDirectory(bufsize : longint;name : pchar) : longint;
|
||||
external 'kernel32' name 'GetCurrentDirectoryA';
|
||||
function SetFileAttributes(lpFileName : pchar;dwFileAttributes : longint) : boolean;
|
||||
external 'kernel32' name 'SetFileAttributesA';
|
||||
function GetFileAttributes(lpFileName : pchar) : longint;
|
||||
external 'kernel32' name 'GetFileAttributesA';
|
||||
function GetFileTime(h : longint;creation,lastaccess,lastwrite : PFILETIME) : boolean;
|
||||
external 'kernel32' name 'GetFileTime';
|
||||
function SetFileTime(h : longint;creation,lastaccess,lastwrite : PFILETIME) : boolean;
|
||||
external 'kernel32' name 'SetFileTime';
|
||||
function SetEndOfFile(h : longint) : boolean;
|
||||
external 'kernel32' name 'SetEndOfFile';
|
||||
|
||||
{ module functions }
|
||||
function GetModuleFileName(l1:longint;p:pointer;l2:longint):longint;
|
||||
external 'kernel32' name 'GetModuleFileNameA';
|
||||
procedure GetStartupInfo(p : pointer);
|
||||
external 'kernel32' name 'GetStartupInfoA';
|
||||
function GetModuleHandle(p : pointer) : longint;
|
||||
external 'kernel32' name 'GetModuleHandleA';
|
||||
|
||||
{ memory functions }
|
||||
function GlobalAlloc(mode,size:longint):longint;
|
||||
external 'kernel32' name 'GlobalAlloc';
|
||||
function GlobalHandle(p:pointer):longint;
|
||||
external 'kernel32' name 'GlobalHandle';
|
||||
function GlobalLock(handle:longint):pointer;
|
||||
external 'kernel32' name 'GlobalLock';
|
||||
function GlobalUnlock(h:longint):longint;
|
||||
external 'kernel32' name 'GlobalUnlock';
|
||||
function GlobalFree(h:longint):longint;
|
||||
external 'kernel32' name 'GlobalUnlock';
|
||||
procedure GlobalMemoryStatus(p:pointer);
|
||||
external 'kernel32' name 'GlobalMemoryStatus';
|
||||
function LocalAlloc(uFlags : UINT;uBytes :UINT) : HLOCAL;
|
||||
external 'kernel32' name 'LocalAlloc';
|
||||
function LocalFree(hMem:HLOCAL):HLOCAL;
|
||||
external 'kernel32' name 'LocalFree';
|
||||
|
||||
{ time and date functions }
|
||||
procedure GetLocalTime(var t : SYSTEMTIME);
|
||||
external 'kernel32' name 'GetLocalTime';
|
||||
function SetLocalTime(const t : SYSTEMTIME) : boolean;
|
||||
external 'kernel32' name 'SetLocalTime';
|
||||
function FileTimeToDosDateTime(const ft : FILETIME;var data,time : word) : boolean;
|
||||
external 'kernel32' name 'FileTimeToDosDateTime';
|
||||
function DosDateTimeToFileTime(date,time : word;var ft : FILETIME) : boolean;
|
||||
external 'kernel32' name 'DosDateTimeToFileTime';
|
||||
function GetTickCount : longint;
|
||||
external 'kernel32' name 'GetTickCount';
|
||||
function FileTimeToLocalFileTime(const ft : FILETIME;var lft : FILETIME) : boolean;
|
||||
external 'kernel32' name 'FileTimeToLocalFileTime';
|
||||
function LocalFileTimeToFileTime(const lft : FILETIME;var ft : FILETIME) : boolean;
|
||||
external 'kernel32' name 'LocalFileTimeToFileTime';
|
||||
|
||||
{ misc. functions }
|
||||
function GetLastError : DWORD;
|
||||
external 'kernel32' name 'GetLastError';
|
||||
function MessageBox(w1:longint;l1,l2:pointer;w2:longint):longint;
|
||||
external 'user32' name 'MessageBoxA';
|
||||
function GetVersion : longint;
|
||||
external 'kernel32' name 'GetVersion';
|
||||
PSystemTime = ^TSystemTime;
|
||||
TSystemTime = record
|
||||
wYear,
|
||||
wMonth,
|
||||
wDayOfWeek,
|
||||
wDay,
|
||||
wHour,
|
||||
wMinute,
|
||||
wSecond,
|
||||
wMilliseconds: Word;
|
||||
end;
|
||||
|
||||
{
|
||||
$Log$
|
||||
Revision 1.6 1998-05-06 12:37:22 michael
|
||||
+ Removed log from before restored version.
|
||||
Revision 1.7 1998-06-10 10:39:18 peter
|
||||
* working w32 rtl
|
||||
|
||||
Revision 1.5 1998/04/27 18:25:36 florian
|
||||
+ constants for CreateFile added
|
||||
|
||||
Revision 1.4 1998/04/26 22:37:22 florian
|
||||
* some small extensions
|
||||
|
||||
Revision 1.3 1998/04/26 21:49:58 florian
|
||||
+ more stuff added (??dir procedures etc.)
|
||||
|
||||
Revision 1.2 1998/03/27 00:50:22 peter
|
||||
* small fixes so it compiles
|
||||
|
||||
Revision 1.1.1.1 1998/03/25 11:18:47 root
|
||||
* Restored version
|
||||
}
|
||||
|
||||
@ -1,9 +1,9 @@
|
||||
{
|
||||
$Id$
|
||||
This file is part of the Free Pascal run time library.
|
||||
FPC Pascal system unit for the Win32 API.
|
||||
Copyright (c) 1998 by Florian Klaempfl and Pavel Ozerski
|
||||
member of the Free Pascal development team.
|
||||
Copyright (c) 1998 by the Free Pascal development team.
|
||||
|
||||
Win32 Memory Functions
|
||||
|
||||
See the file COPYING.FPC, included in this distribution,
|
||||
for details about the copyright.
|
||||
@ -14,40 +14,58 @@
|
||||
|
||||
**********************************************************************}
|
||||
|
||||
{ memory functions }
|
||||
function GlobalAlloc(mode,size:longint):longint;
|
||||
external 'kernel32' name 'GlobalAlloc';
|
||||
function GlobalHandle(p:pointer):longint;
|
||||
external 'kernel32' name 'GlobalHandle';
|
||||
function GlobalLock(handle:longint):pointer;
|
||||
external 'kernel32' name 'GlobalLock';
|
||||
function GlobalUnlock(h:longint):longint;
|
||||
external 'kernel32' name 'GlobalUnlock';
|
||||
function GlobalFree(h:longint):longint;
|
||||
external 'kernel32' name 'GlobalUnlock';
|
||||
procedure GlobalMemoryStatus(p:pointer);
|
||||
external 'kernel32' name 'GlobalMemoryStatus';
|
||||
function LocalAlloc(uFlags : UINT;uBytes :UINT) : HLOCAL;
|
||||
external 'kernel32' name 'LocalAlloc';
|
||||
function LocalFree(hMem:HLOCAL):HLOCAL;
|
||||
external 'kernel32' name 'LocalFree';
|
||||
|
||||
|
||||
type
|
||||
errproc=function(size:longint):integer;
|
||||
errproc=function(size:longint):integer;
|
||||
|
||||
procedure MemError(size:longint);
|
||||
const
|
||||
message:array[1..21]of char=(
|
||||
'A','b','n','o','r','m','a','l',' ',
|
||||
'T','e','r','m','i','n','a','t','i','o','n',#0);
|
||||
caption:array[1..25]of char=(
|
||||
'M','e','m','o','r','y',' ',
|
||||
'M','a','n','a','g','e','m','e','n','t',' ',
|
||||
'E','r','r','o','r','!',#0);
|
||||
var
|
||||
const
|
||||
message:pchar='Abnormal Termination';
|
||||
caption:pchar='Memory Management Error!';
|
||||
var
|
||||
res:integer;
|
||||
begin
|
||||
begin
|
||||
repeat
|
||||
res:=errproc(heaperror)(size);
|
||||
if res=0 then
|
||||
begin;
|
||||
messagebox(0,@caption,@message,$10);
|
||||
halt(getlasterror);
|
||||
end;
|
||||
res:=errproc(heaperror)(size);
|
||||
if res=0 then
|
||||
begin;
|
||||
messagebox(0,caption,message,$10);
|
||||
halt(getlasterror);
|
||||
end;
|
||||
until res<>2;
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
procedure getmem(var p:pointer;size:longint);[public,alias: 'GETMEM'];
|
||||
begin
|
||||
begin
|
||||
p:=GlobalLock(GlobalAlloc(258,size));
|
||||
if p=nil then
|
||||
memerror(size)
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
procedure freemem(var p:pointer;size:longint);[public,alias: 'FREEMEM'];
|
||||
var
|
||||
var
|
||||
h:longint;
|
||||
begin
|
||||
begin
|
||||
h:=GlobalHandle(p);
|
||||
if h<>0 then
|
||||
if globalunlock(h)=0 then
|
||||
@ -58,10 +76,11 @@ procedure freemem(var p:pointer;size:longint);[public,alias: 'FREEMEM'];
|
||||
end;
|
||||
p:=nil;
|
||||
memerror(size);
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
function memmax(_maxavail:boolean):longint;
|
||||
const
|
||||
const
|
||||
status:record
|
||||
dwLength,
|
||||
dwMemoryLoad,
|
||||
@ -72,31 +91,36 @@ function memmax(_maxavail:boolean):longint;
|
||||
dwTotalVirtual,
|
||||
dwAvailVirtual:longint;
|
||||
end=(dwLength:32);
|
||||
begin
|
||||
begin
|
||||
GlobalMemoryStatus(@status);
|
||||
if _maxavail then
|
||||
memmax:=status.dwAvailPageFile
|
||||
else
|
||||
memmax:=status.dwAvailVirtual;
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
function memavail:longint;
|
||||
begin
|
||||
begin
|
||||
memavail:=memmax(false);
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
function maxavail:longint;
|
||||
begin
|
||||
begin
|
||||
maxavail:=memmax(true);
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
function growheap(size:longint):integer;
|
||||
begin
|
||||
begin
|
||||
growheap:=0;
|
||||
end;
|
||||
end;
|
||||
|
||||
{
|
||||
$Log$
|
||||
Revision 1.2 1998-05-06 12:37:22 michael
|
||||
+ Removed log from before restored version.
|
||||
Revision 1.3 1998-06-10 10:39:19 peter
|
||||
* working w32 rtl
|
||||
|
||||
Revision 1.1.1.1 1998/03/25 11:18:47 root
|
||||
* Restored version
|
||||
}
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user