purebasic.info

PureBasic forum
Текущее время: Сб дек 16, 2017 12:47 am

Часовой пояс: UTC + 3 часа




Начать новую тему Ответить на тему  [ 1 сообщение ] 
Автор Сообщение
 Заголовок сообщения: MyStability (внешняя проверка ошибок)
СообщениеДобавлено: Чт мар 10, 2016 11:55 am 
Не в сети
профессор

Зарегистрирован: Чт сен 22, 2011 6:21 pm
Сообщений: 212
Благодарил (а): 29 раз.
Поблагодарили: 21 раз.
Пункты репутации: 0
Преамбула:
Как мы обычно пишем программу, сначала накидываем "рыбу" - базовый алгоритм, убеждаемся что работает, а дальше ...
А дальше, мы понимаем, что нужно добавить 100500 проверок на корректность работы ввода/вывода. (работа с файлами и сетью)
И первоначально простой и чистый (как слеза младенца) алгоритм, превращается в монстра, на которого без слез смотреть невозможно (если операций В/В много).
Очевидное решение - заменить стандартные процедуры В/В на свои - MyOpenFile(), MyCopyFile... но это связано с необходимостью править исходник (и без наших процедур он будет уже не работоспособен).
Но тут на помощь приходят макросы (по мотивам http://www.purebasic.fr/english/viewtop ... 40&t=56522)
Что получилось:
1) Исходный чистый алгоритм остается нетронут, и может быть запущен, проверен, улучшен сам по себе.
2) Просто подключив внешний файл - мы подключаем наши подменные процедуры с какой угодно расширенной проверкой ошибок.
Вариант под PB524-PB531:
Код:
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
;*********************************
; Module:  MyStability531.pbi
; Author:   void
; Compiler: PB524-PB531
; Ver:      003
;
; подменные процедуры с усиленной проверкой ошибок ввода/вывода
;*********************************
CompilerIf Not #PB_Compiler_Thread
  CompilerError "Thread Safe Reqired!"
CompilerEndIf
CompilerIf #PB_Compiler_Version < 524 Or #PB_Compiler_Version > 531
  CompilerError "For compiler version 524-531"
CompilerEndIf
 
DeclareModule MyStability
  EnableExplicit
  ;{ Constants
  ;завершать-ли программу если фатальная ошибка, для готовой программы #True, для отладки #False
  #END_IF_FATAL = Bool(Not #PB_Compiler_Debugger)
 
  ;тайм-ауты и повторы
  #ERROR_MAX_LOOP   = 3     ;количество попыток IO
  #ERROR_DELAY_LOOP = 200   ;пауза между попытками (ms)
  #LAN_CONNECT_TIME = 2000  ;там-аут сетевого коннекта
  #LAN_ERROR_LOOP   = 5     ;попыток соединения
  #LAN_DELAY_LOOP   = 500   ;пауза между попытками соединения
 
  ;}
  ;{ Macroses
  Macro MacroColon
    :
  EndMacro
  Macro Override(ProcName, Prefix=_, Blank=)
    Blank#Macro ProcName MacroColon Prefix#ProcName MacroColon Blank#EndMacro MacroColon
  EndMacro
  Macro UnOverride(Name1, Name2, Blank=)
    Blank#UndefineMacro Blank#Name1#Name2 MacroColon
  EndMacro
  ;}
  ;{ Declarations
  ;FileSystem
  Declare  _CopyDirectory(SourceDirectory$,DestinationDirectory$,Pattern$,Flags=#PB_FileSystem_Recursive|#PB_FileSystem_Force)
  Declare  _CopyFile(SourceFilename$,DestinationFilename$)
  Declare  _CreateDirectory(FileName$)
  Declare  _DeleteDirectory(FileName$,Pattern$,Flags=#PB_FileSystem_Recursive|#PB_FileSystem_Force)
  Declare  _DeleteFile(FileName$,Flags=#PB_FileSystem_Force)
  Declare  _ExamineDirectory(NDirectory,DirectoryName$,Pattern$)
  Declare$ _GetCurrentDirectory()
  Declare$ _GetTemporaryDirectory()
  Declare  _RenameFile(OldFilename$,NewFilename$)
  ;File
  Declare  _CreateFile(NFile,FileName$,Flags=0)
  Declare  _OpenFile(NFile,Filename$,Flags=0)
  Declare  _ReadFile(NFile,Filename$,Flags=0)
  ;Thread
  Declare  _CreateMutex()
  Declare  _CreateSemaphore(InitialCount=0)
  Declare  _CreateThread(*ProcedureName,*Value)
  ;Lan
  Declare  _InitNetwork()
  Declare  _CreateNetworkServer(NServer,Port,Mode=#PB_Network_TCP,BindedIP$="")
  Declare  _OpenNetworkConnection(ServerName$,Port,Mode=#PB_Network_TCP,TimeOut=#LAN_CONNECT_TIME,LocalIP$="",LocalPort=0)
  ;Http
  Declare$ _GetHTTPHeader(URL$)
  Declare  _ReceiveHTTPFile(URL$,Filename$)
  ;Cipher
  Declare$ _MD5FileFingerprint(FileName$)
  ;Preferences
  Declare  _CreatePreferences(Filename$,Flags=0)
  Declare  _OpenPreferences(Filename$,Flags=0)
  ;RunProgram
  Declare  _RunProgram(Filename$,Parameter$="",WorkingDirectory$="",Flags=0,SenderProgram=0)
  ;}
  ;{ Enable/Disable macroses
  Macro MyStabilityEnable()
    ;FileSystem
    Override(CopyDirectory)
    Override(CopyFile)
    Override(CreateDirectory)
    Override(DeleteDirectory)
    Override(DeleteFile)
    Override(ExamineDirectory)
    Override(GetCurrentDirectory)
    Override(GetTemporaryDirectory)
    Override(RenameFile)
    ;File
    Override(CreateFile)
    Override(OpenFile)
    Override(ReadFile)
    ;Thread
    Override(CreateMutex)
    Override(CreateSemaphore)
    Override(CreateThread)
    ;Lan
    Override(InitNetwork)
    Override(CreateNetworkServer)
    Override(OpenNetworkConnection)
    Override(GetHTTPHeader)
    Override(ReceiveHTTPFile)
    ;Cipher
    Override(MD5FileFingerprint)
    ;Preferences
    Override(CreatePreferences)
    Override(OpenPreferences)
    ;RunProgram
    Override(RunProgram)
  EndMacro
  Macro MyStabilityDisable()
    ;FileSystem
    UnOverride(C,opyDirectory)
    UnOverride(C,opyFile)
    UnOverride(C,reateDirectory)
    UnOverride(D,eleteDirectory)
    UnOverride(D,eleteFile)
    UnOverride(E,xamineDirectory)
    UnOverride(G,etCurrentDirectory)
    UnOverride(G,etTemporaryDirectory)
    UnOverride(R,enameFile)
    ;File
    UnOverride(C,reateFile)
    UnOverride(O,penFile)
    UnOverride(R,eadFile)
    ;Thread
    UnOverride(C,reateMutex)
    UnOverride(C,reateSemaphore)
    UnOverride(C,reateThread)
    ;Lan
    UnOverride(I,nitNetwork)
    UnOverride(C,reateNetworkServer)
    UnOverride(O,penNetworkConnection)
    UnOverride(G,etHTTPHeader)
    UnOverride(R,eceiveHTTPFile)
    ;Cipher
    UnOverride(M,D5FileFingerprint)
    ;Preferences
    UnOverride(C,reatePreferences)
    UnOverride(O,penPreferences)
    ;RunProgram
    UnOverride(R,unProgram)
  EndMacro  
  ;}
EndDeclareModule
Module MyStability
  EnableExplicit
  ;{*************************** Макросы проверок ***************************
  ;проверка процедур возвращающих числовой(целый) результат.
  Macro _CheckDigProc(ProcName, ErrMsg, FileName="", GetLastErr=#True)
    Protected errcount, result, err
    result = ProcName
    If Not result  
      Repeat
        Delay(#ERROR_DELAY_LOOP)
        result = ProcName
        CompilerIf GetLastErr
          err = GetLastError_()
        CompilerEndIf
        If result
          Break
        EndIf
        errcount + 1
        If errcount >= #ERROR_MAX_LOOP
          FatalIO(ErrMsg, FileName, err)
          Break
        EndIf        
      ForEver
    EndIf
    ProcedureReturn result
  EndMacro
 
  ;то-же для сети
  Macro _CheckDigProcLan(ProcName, ErrMsg, GetLastErr=#True)
    Protected errcount, result, err
    result = ProcName
    If Not result  
      Repeat
        Delay(#LAN_DELAY_LOOP)
        result = ProcName
        CompilerIf GetLastErr
          err = WSAGetLastError_()
        CompilerEndIf
        If result
          Break
        EndIf
        errcount + 1
        If errcount >= #LAN_ERROR_LOOP
          FatalIO(ErrMsg, "", err)
          Break
        EndIf        
      ForEver
    EndIf
    ProcedureReturn result
  EndMacro
 
  ;проверка процедур возвращающих строковый результат.
  Macro _CheckStrProc(ProcName, ErrMsg, FileName="")
    Protected errcount, result$
    result$ = ProcName
    If Not Len(result$)
      Repeat
        Delay(#ERROR_DELAY_LOOP)
        result$ = ProcName
        If Len(result$)
          Break
        EndIf
        errcount + 1
        If errcount >= #ERROR_MAX_LOOP
          FatalIO(ErrMsg, FileName)
          Break
        EndIf        
      ForEver
    EndIf
    ProcedureReturn result$
  EndMacro
 
  ;}
  ;{*************************** служебные процедуры ***************************
  ;возвращает полное имя файла с путем, для отображения в фатальном экране
  Procedure$ GetFullPathName(FileName$)
    If Not FindString(FileName$,":")
      FileName$ = GetCurrentDirectory() + FileName$
    EndIf
    ProcedureReturn FileName$
  EndProcedure
  ;возвращает текстовое представление системной ошибки
  Procedure$ SysErrToStr(Err)
    Protected ErrorBuffer$=Space(1024)
    ProcedureReturn PeekS(@ErrorBuffer$,FormatMessage_(#FORMAT_MESSAGE_FROM_SYSTEM, 0, Err, 0, @ErrorBuffer$, StringByteLength(ErrorBuffer$), 0))
  EndProcedure
  ;выдает фатальное сообщение
  Procedure  FatalIO(Msg$,FileName$="",Err=0)
    Protected tmp$
    tmp$ = "Невозможно "+Msg$
    If Len(FileName$)      
      tmp$ + ":"+#CRLF$+GetFullPathName(FileName$)+#CRLF$
    EndIf  
    If Err
      tmp$+"Сообщение системы:"+#CRLF$+
           SysErrToStr(Err)+#CRLF$
     
    EndIf
    MessageRequester("FATAL ERROR!!!",tmp$,#MB_ICONERROR|#MB_SYSTEMMODAL)
    If #END_IF_FATAL
      End
    EndIf
  EndProcedure
 
  ;}
  ;{*************************** подменяемые процедуры ***************************
  ;{ FileSystem
  Procedure _CopyDirectory(SourceDirectory$, DestinationDirectory$, Pattern$ ,Flags=#PB_FileSystem_Recursive|#PB_FileSystem_Force)
    If FileSize(SourceDirectory$) = -1 ;исходеый файл/папка отсутствует
      FatalIO("скопировать отсутствующую папку",SourceDirectory$,0)
    Else
      _CheckDigProc(CopyDirectory(SourceDirectory$, DestinationDirectory$, Pattern$ ,Flags),"скопировать папку",SourceDirectory$)
    EndIf
    ProcedureReturn 0
  EndProcedure
 
  Procedure _CopyFile(SourceFilename$, DestinationFilename$)
    If FileSize(SourceFilename$) = -1 ;исходеый файл/папка отсутствует
      FatalIO("скопировать отсутствующий файл",SourceFilename$,0)
    Else
      _CheckDigProc(CopyFile(SourceFilename$, DestinationFilename$),"скопировать файл",SourceFilename$)
    EndIf
    ProcedureReturn 0
  EndProcedure
 
  Procedure _CreateDirectory(FileName$)
    Select FileSize(FileName$)
      Case -2 ;уже существует - ничего делать не надо
              ;в отличие от стандарта я не считаю это ошибкой, но вернет 0
      Case -1 ;ничего нет, можно создавать
        _CheckDigProc(CreateDirectory(FileName$),"создать новую папку",FileName$)
      Default ;существует одноименнвй файл - создание папки невозможно
        FatalIO("создать новую папку, по причине существования одноименного файла.",FileName$)
    EndSelect
    ProcedureReturn 0
  EndProcedure
 
  Procedure _DeleteDirectory(FileName$,Pattern$,Flags=#PB_FileSystem_Recursive|#PB_FileSystem_Force)
    Select FileSize(FileName$)
        ;Case -1 ;ничего нет, и делать нечего
        ;не ошибка, но вернет 0
      Case -2 ;есть папка - можно удалять
        _CheckDigProc(DeleteDirectory(FileName$,Pattern$,Flags),"удалить папку",FileName$)
      Default ;это не папка, это файл
        FatalIO("удалить папку, это не папка а файл",FileName$)
    EndSelect
    ProcedureReturn 0
  EndProcedure  
 
  Procedure _DeleteFile(FileName$,Flags=#PB_FileSystem_Force)
    Select FileSize(FileName$)
      Case -2 ;папка
        FatalIO("удалить файл, это не файл а папка",FileName$)
      Case -1 ;ничего нет                      
      Default ;файл присутствует
        _CheckDigProc(DeleteFile(FileName$,Flags),"удалить файл",FileName$)
    EndSelect
    ;если файл отсутствует - ничего удалять не надо, не ошибка но вернет 0
    ProcedureReturn 0
  EndProcedure
 
  Procedure _ExamineDirectory(NDirectory, DirectoryName$, Pattern$)
    _CheckDigProc(ExamineDirectory(NDirectory,DirectoryName$,Pattern$),"прочитать содержимое папки",DirectoryName$)
  EndProcedure
 
  Procedure$ _GetCurrentDirectory()
    _CheckStrProc(GetCurrentDirectory(),"определить текущую папку")
  EndProcedure
 
  Procedure$ _GetTemporaryDirectory()
    _CheckStrProc(GetTemporaryDirectory(),"определить временную папку")
  EndProcedure
 
  Procedure _RenameFile(OldFilename$, NewFilename$)
    If FileSize(OldFilename$) = -1 ;исходеый файл/папка отсутствует
      FatalIO("переименовать отсутствующий файл/папку",OldFilename$)
    Else
      _CheckDigProc(RenameFile(OldFilename$, NewFilename$),"переименовать файл/папку",OldFilename$)
    EndIf
    ProcedureReturn 0
  EndProcedure
  ;}
  ;{ File
  Procedure _CreateFile(NFile,FileName$,Flags=0)
    _DeleteFile(FileName$) ;удаляем, если был
    _CheckDigProc(CreateFile(NFile,FileName$,Flags),"создать файл",FileName$)
  EndProcedure
 
  Procedure _OpenFile(NFile, Filename$ ,Flags=0)
    _CheckDigProc(OpenFile(NFile, Filename$ ,Flags),"открыть файл",Filename$)
  EndProcedure
 
  Procedure _ReadFile(NFile,Filename$,Flags=0)
    _CheckDigProc(ReadFile(NFile,Filename$,Flags),"прочитать файл",Filename$)
  EndProcedure
  ;}
  ;{ Thread
  Procedure _CreateMutex()
    _CheckDigProc(CreateMutex(),"создать мутекс")
  EndProcedure
 
  Procedure _CreateSemaphore(InitialCount=0)
    _CheckDigProc(CreateSemaphore(InitialCount),"создать симафор")
  EndProcedure
 
  Procedure _CreateThread(*ProcedureName, *Value)
    _CheckDigProc(CreateThread(*ProcedureName, *Value),"создать поток")
  EndProcedure
 
  ;}
  ;{ Lan
  Procedure _InitNetwork()
    _CheckDigProcLan(InitNetwork(),"инициализировать сетевую подсистему")
  EndProcedure
 
  Procedure _CreateNetworkServer(NServer,Port,Mode=#PB_Network_TCP,BindedIP$="")
    _CheckDigProcLan(CreateNetworkServer(NServer,Port,Mode,BindedIP$),"открыть порт: "+Str(Port))
  EndProcedure
 
  Procedure _OpenNetworkConnection(ServerName$,Port,Mode=#PB_Network_TCP,TimeOut=#LAN_CONNECT_TIME,LocalIP$="",LocalPort=0)
    Protected errcount,result
    Repeat
      result = OpenNetworkConnection(ServerName$,Port,Mode,TimeOut,LocalIP$,LocalPort)
      If result
        Break
      EndIf
      Delay(#LAN_DELAY_LOOP)
      errcount +1
    Until errcount>#LAN_ERROR_LOOP
    ProcedureReturn result
  EndProcedure
  ;}
  ;{ Http
  ;структура для передачи в поток thrGetHTTPHeader
  Structure HTTPHeaderStruc
    url$
    head$
  EndStructure
  ;GetHTTPHeader - в отдельном потоке, для остановки по тайм-ауту
  Procedure thrGetHTTPHeader(*url.HTTPHeaderStruc)
    *url\head$ = GetHTTPHeader(*url\url$)
  EndProcedure
  Procedure$ _GetHTTPHeader(URL$)
    Protected tmp.HTTPHeaderStruc,thr,errcount
    tmp\url$ = URLEncoder(URL$)
    Repeat
      thr = _CreateThread(@thrGetHTTPHeader(),@tmp)
      If Not WaitThread(thr,#LAN_CONNECT_TIME)
        KillThread(thr)
        Delay(#LAN_DELAY_LOOP)
        tmp\head$=""
      Else
        Break
      EndIf
      errcount +1
      If errcount>#LAN_ERROR_LOOP
        tmp\head$=""
        Break
      EndIf
    ForEver
    ProcedureReturn tmp\head$
  EndProcedure  
 
  ;структура для передачи в поток thrReceiveHTTPFile
  Structure ReceiveHTTPStruct
    url$
    filename$
    filesize.i
  EndStructure
  ;ReceiveHTTPFile - в отдельном потоке, для остановки по тайм-ауту
  Procedure thrReceiveHTTPFile(*rhttp.ReceiveHTTPStruct)
    *rhttp\filesize = ReceiveHTTPFile(*rhttp\url$, *rhttp\filename$)
  EndProcedure
  Procedure _ReceiveHTTPFile(URL$, Filename$)
    Protected header$,headerline$,currentline,headersize,thr,errcount,oldfilesize,rhttp.ReceiveHTTPStruct
    rhttp\url$=URLEncoder(URL$)
    rhttp\filename$=Filename$
    header$ = _GetHTTPHeader(URL$);пробуем запросить заголовок
    If Len(header$) And Left(header$,4)="HTTP";сервер http(уже хорошо)
      If StringField(header$,2," ")="200"     ;ok
                                              ;ищем длину, для проверки правильности загрузки
        Repeat                                
          currentline+1
          headerline$ = StringField(header$,currentline,#LF$);очередная строка
          If FindString(headerline$,"Content-Length:",1,#PB_String_NoCase)
            headersize = Val(StringField(headerline$,2," "))
            ;Debug headersize
            Break
          EndIf  
        Until headerline$=""
        ;цикл попыток приема
        Repeat
          DeleteFile(Filename$);зачищаем (вдруг заблокирован)
          thr = _CreateThread(@thrReceiveHTTPFile(),@rhttp)
          ;цикл ожидания потока приема
          Repeat
            If Not WaitThread(thr,#LAN_CONNECT_TIME)
              ;если поток не завершен
              ;буфер сбрасывается каждые 1000мс, если нет изменений - соединение висит
              If FileSize(Filename$)=oldfilesize
                KillThread(thr)
                Delay(#LAN_DELAY_LOOP)
                Break
              Else ;файл приема изменился (данные поступают)
                oldfilesize=FileSize(Filename$)
              EndIf
            Else
              ;поток окончен - проверяем результат  
              If rhttp\filesize And ((headersize And headersize=rhttp\filesize) Or headersize=0 )
                ProcedureReturn rhttp\filesize
              Else
                Break
              EndIf
            EndIf
          ForEver
          errcount +1
          ;Debug "Err "+errcount+" rSize= "+rhttp\filesize
          If errcount>#LAN_ERROR_LOOP
            DeleteFile(Filename$)
            Break
          EndIf
        ForEver
      EndIf
    EndIf
    ProcedureReturn 0
  EndProcedure
  ;}
  ;{ Cipher
  Procedure$ _MD5FileFingerprint(FileName$)
    If FileSize(FileName$) > 0  ;файл присутствует
      _CheckStrProc(MD5FileFingerprint(FileName$),"прочитать файл, нет доступа",FileName$)
    Else  ;нет файла
      FatalIO("прочитать файл, по причине его отсутствия",FileName$,0)
    EndIf
    ProcedureReturn ""
  EndProcedure
  ;}
  ;{ Preferences
  Procedure _CreatePreferences(Filename$,Flags=0)
    _DeleteFile(Filename$)
    _CheckDigProc(CreatePreferences(Filename$,Flags),"создать файл настроек",Filename$)
  EndProcedure
 
  Procedure _OpenPreferences(Filename$,Flags=0)
    _CheckDigProc(OpenPreferences(Filename$,Flags),"открыть файл настроек",Filename$)
  EndProcedure
  ;}
  ;{ RunProgram
  Procedure _RunProgram(Filename$,Parameter$="",WorkingDirectory$="",Flags=0,SenderProgram=0)
    _CheckDigProc(RunProgram(Filename$,Parameter$,WorkingDirectory$,Flags,SenderProgram),"выполнить",Filename$)
  EndProcedure
  ;}
  ;}
  ;}
EndModule
 
;сразу включаем в работу
UseModule MyStability
MyStabilityEnable()
 
 
;Test Module
CompilerIf #PB_Compiler_IsMainFile
 
  ; FileSystem
  CopyDirectory("c:\Nothing","c:\1","*.*")
  CopyFile("c:\Nothing","c:\1")
  CreateDirectory("x:\1")
  DeleteDirectory("c:\Temp","")
  DeleteFile("c:\WINDOWS\explorer.exe")
  ExamineDirectory(0,"x:\1","")
  RenameFile("c:\Nothing","c:\1")
 
  ; File
  CreateFile(0,"x:\1")
  OpenFile(0, "x:\1")
  ReadFile(0,"c:\1")
 
  ; Lan
  InitNetwork()
  CreateNetworkServer(0,445)
 
  ; Cipher
  MD5FileFingerprint("c:\WINDOWS\system32\config\SAM")
 
  ; Preferences
  CreatePreferences("x:\1")
  OpenPreferences("x:\1")
 
  ; RunProgram
  RunProgram("c:\Nothing.exe")
 
CompilerEndIf
 


Использование:
XIncludeFile "MyStability.pbi" - в начае файла, все стандартные PB-шные процедуры В/В будут подменены
Временно отключить подмену нативных процедур(для собственной обработки) - MyStabilityDisable()
Снова включить перехват - MyStabilityEnable()
Известные проблемы:
1) Не все процедуры перехвачены - нужные добавляем по аналогии (тут только те, что я использовал)
2) Все процедуры компилируются и попадают в выходной файл (даже те, что не используются)

Версия с использованием "IncludeOnDemandCore" (viewtopic.php?f=10&t=4403) под PB540+
Код:
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
;*********************************
; Module:  MyStability542.pbi
; Author:   void
; Compiler: PB540+
; Ver:      004
;
; подменные процедуры с усиленной проверкой ошибок ввода/вывода (подменяются родные PB-шные)
; выполняются несколько попыток(#MyStability_ERROR_MAX_LOOP) выполнить команду с паузой(#MyStability_ERROR_DELAY_LOOP)
; при невозможности выводится осмысленное сообщение с указанием что именно невозможно сделать.
;*********************************
;- Docs
;{ Docs
; Использование:
; инклудим 2 раза в начале и конце основного файла проекта
; IncludeFile "MyStability.pbi" ; не "ХIncludeFile"
;}
XIncludeFile "IncludeOnDemandCore.pbi"
 
CompilerIf Not #PB_Compiler_Thread
  CompilerError "Thread Safe Reqired!"
CompilerEndIf
CompilerIf #PB_Compiler_Version < 540
  CompilerError "For compiler version >= 540"
CompilerEndIf
EnableExplicit
 
CompilerIf IsFirstStep(MyStability)
  ;{ Constants
  ;завершать-ли программу если фатальная ошибка, для готовой программы #True, для отладки #False
  #MyStability_END_IF_FATAL = Bool(Not #PB_Compiler_Debugger)
 
  ;тайм-ауты и повторы
  #MyStability_ERROR_MAX_LOOP   = 3     ;количество попыток IO
  #MyStability_ERROR_DELAY_LOOP = 200   ;пауза между попытками (ms)
  #MyStability_LAN_CONNECT_TIME = 2000  ;там-аут сетевого коннекта
  #MyStability_LAN_ERROR_LOOP   = 5     ;попыток соединения
  #MyStability_LAN_DELAY_LOOP   = 500   ;пауза между попытками соединения
 
  ;}  
  ;{ Declarations
  ;FileSystem
  Declare  MyStability_CopyDirectory(SourceDirectory$,DestinationDirectory$,Pattern$,Flags=#PB_FileSystem_Recursive|#PB_FileSystem_Force)
  Declare  MyStability_CopyFile(SourceFilename$,DestinationFilename$)
  Declare  MyStability_CreateDirectory(FileName$)
  Declare  MyStability_DeleteDirectory(FileName$,Pattern$,Flags=#PB_FileSystem_Recursive|#PB_FileSystem_Force)
  Declare  MyStability_DeleteFile(FileName$,Flags=#PB_FileSystem_Force)
  Declare  MyStability_ExamineDirectory(NDirectory,DirectoryName$,Pattern$)
  Declare$ MyStability_GetCurrentDirectory()
  Declare$ MyStability_GetTemporaryDirectory()
  Declare  MyStability_RenameFile(OldFilename$,NewFilename$)
  ;File
  Declare  MyStability_CreateFile(NFile,FileName$,Flags=0)
  Declare  MyStability_OpenFile(NFile,Filename$,Flags=0)
  Declare  MyStability_ReadFile(NFile,Filename$,Flags=0)
  ;Thread
  Declare  MyStability_CreateMutex()
  Declare  MyStability_CreateSemaphore(InitialCount=0)
  Declare  MyStability_CreateThread(*ProcedureName,*Value)
  ;Lan
  Declare  MyStability_InitNetwork()
  Declare  MyStability_CreateNetworkServer(NServer,Port,Mode=#PB_Network_TCP,BindedIP$="")
  Declare  MyStability_OpenNetworkConnection(ServerName$,Port,Mode=#PB_Network_TCP,TimeOut=#MyStability_LAN_CONNECT_TIME,LocalIP$="",LocalPort=0)
  ;Http
  Declare$ MyStability_GetHTTPHeader(URL$)
  Declare  MyStability_ReceiveHTTPFile(URL$, Filename$, Flags=0)
  Declare  MyStability_ReceiveHTTPMemory(URL$, Flags=0)
  ;Cipher
  Declare$ MyStability_FileFingerprint(FileName$, Plugin, Bits=256, Offset=0, Length=-1)
  ;Preferences
  Declare  MyStability_CreatePreferences(Filename$,Flags=0)
  Declare  MyStability_OpenPreferences(Filename$,Flags=0)
  ;RunProgram
  Declare  MyStability_RunProgram(Filename$,Parameter$="",WorkingDirectory$="",Flags=0,SenderProgram=0)
  ;}
  ;{ Enable/Disable macroses
  Macro MyStability_Enable()
    ;FileSystem
    Override4 (MyStability_,CopyDirectory,p1,p2,p3,p4=#PB_FileSystem_Recursive|#PB_FileSystem_Force)
    Override2 (MyStability_,CopyFile,p1,p2)
    Override1 (MyStability_,CreateDirectory,p1)
    Override3 (MyStability_,DeleteDirectory,p1,p2,p3=#PB_FileSystem_Recursive|#PB_FileSystem_Force)
    Override2 (MyStability_,DeleteFile,p1,p2=#PB_FileSystem_Force)
    Override3 (MyStability_,ExamineDirectory,p1,p2,p3)
    Override0 (MyStability_,GetCurrentDirectory)
    Override0 (MyStability_,GetTemporaryDirectory)
    Override2 (MyStability_,RenameFile,p1,p2)
    ;File
    Override3 (MyStability_,CreateFile,p1,p2,p3=0)
    Override3 (MyStability_,OpenFile,p1,p2,p3=0)
    Override3 (MyStability_,ReadFile,p1,p2,p3=0)
    ;Thread
    Override0 (MyStability_,CreateMutex)
    Override1 (MyStability_,CreateSemaphore,p1=0)
    Override2 (MyStability_,CreateThread,p1,p2)
    ;Lan
    Override0 (MyStability_,InitNetwork)
    Override4 (MyStability_,CreateNetworkServer,p1,p2,p3=#PB_Network_TCP,p4="")
    Override6 (MyStability_,OpenNetworkConnection,p1,p2,p3=#PB_Network_TCP,p4=#MyStability_LAN_CONNECT_TIME,p5="",p6=0)
    ;Http
    Override1 (MyStability_,GetHTTPHeader,p1)
    Override3 (MyStability_,ReceiveHTTPFile,p1,p2,p3=0)
    Override2 (MyStability_,ReceiveHTTPMemory,p1,p2=0)
    ;Cipher
    Override5 (MyStability_,FileFingerprint,p1,p2,p3=256,p4=0,p5=-1)
    ;Preferences
    Override2 (MyStability_,CreatePreferences,p1,p2=0)
    Override2 (MyStability_,OpenPreferences,p1,p2=0)
    ;RunProgram
    Override5 (MyStability_,RunProgram,p1,p2="",p3="",p4=0,p5=0)
  EndMacro
  Macro MyStability_Disable()
    ;FileSystem
    UnOverride(C,opyDirectory)
    UnOverride(C,opyFile)
    UnOverride(C,reateDirectory)
    UnOverride(D,eleteDirectory)
    UnOverride(D,eleteFile)
    UnOverride(E,xamineDirectory)
    UnOverride(G,etCurrentDirectory)
    UnOverride(G,etTemporaryDirectory)
    UnOverride(R,enameFile)
    ;File
    UnOverride(C,reateFile)
    UnOverride(O,penFile)
    UnOverride(R,eadFile)
    ;Thread
    UnOverride(C,reateMutex)
    UnOverride(C,reateSemaphore)
    UnOverride(C,reateThread)
    ;Lan
    UnOverride(I,nitNetwork)
    UnOverride(C,reateNetworkServer)
    UnOverride(O,penNetworkConnection)
    ;Http
    UnOverride(G,etHTTPHeader)
    UnOverride(R,eceiveHTTPFile)
    UnOverride(R,eceiveHTTPMemory)
    ;Cipher
    UnOverride(F,ileFingerprint)
    ;Preferences
    UnOverride(C,reatePreferences)
    UnOverride(O,penPreferences)
    ;RunProgram
    UnOverride(R,unProgram)
  EndMacro  
  ;}
  MyStability_Enable()  
CompilerEndIf
 
;- Test Module
CompilerIf #PB_Compiler_IsMainFile
 
  ; FileSystem
  CopyDirectory("c:\Nothing","c:\1","*.*")
  CopyFile("c:\Nothing","c:\1")
  CreateDirectory("x:\1")
  DeleteDirectory("c:\Temp","")
  DeleteFile("c:\WINDOWS\explorer.exe")
  ExamineDirectory(0,"x:\1","")
  RenameFile("c:\Nothing","c:\1")
 
  ; File
  CreateFile(0,"x:\1")
  OpenFile(0, "x:\1")
  ReadFile(0,"c:\1")
 
  ; Lan
  InitNetwork()
  CreateNetworkServer(0,445)
 
  ; Cipher
  UseMD5Fingerprint()
  FileFingerprint("c:\WINDOWS\system32\config\SAM", #PB_Cipher_MD5)
 
  ; Preferences
  CreatePreferences("x:\1")
  OpenPreferences("x:\1")
 
  ; RunProgram
  RunProgram("c:\Nothing.exe")
 
CompilerEndIf
 
CompilerIf IsSecondStep(MyStability)
  MyStability_Disable()
  ;{*************************** Макросы проверок ***************************
  ;проверка процедур возвращающих числовой(целый) результат.
  Macro MyStability_CheckDigProc(ProcName, ErrMsg, FileName="", GetLastErr=#True)
    Protected errcount, result, err
    result = ProcName
    If Not result  
      Repeat
        Delay(#MyStability_ERROR_DELAY_LOOP)
        result = ProcName
        CompilerIf GetLastErr
          err = GetLastError_()
        CompilerEndIf
        If result
          Break
        EndIf
        errcount + 1
        If errcount >= #MyStability_ERROR_MAX_LOOP
          MyStability_FatalIO(ErrMsg, FileName, err)
          Break
        EndIf        
      ForEver
    EndIf
    ProcedureReturn result
  EndMacro
 
  ;то-же для сети
  Macro MyStability_CheckDigProcLan(ProcName, ErrMsg, GetLastErr=#True)
    Protected errcount, result, err
    result = ProcName
    If Not result  
      Repeat
        Delay(#MyStability_LAN_DELAY_LOOP)
        result = ProcName
        CompilerIf GetLastErr
          err = WSAGetLastError_()
        CompilerEndIf
        If result
          Break
        EndIf
        errcount + 1
        If errcount >= #MyStability_LAN_ERROR_LOOP
          MyStability_FatalIO(ErrMsg, "", err)
          Break
        EndIf        
      ForEver
    EndIf
    ProcedureReturn result
  EndMacro
 
  ;проверка процедур возвращающих строковый результат.
  Macro MyStability_CheckStrProc(ProcName, ErrMsg, FileName="")
    Protected errcount, result$
    result$ = ProcName
    If Not Len(result$)
      Repeat
        Delay(#MyStability_ERROR_DELAY_LOOP)
        result$ = ProcName
        If Len(result$)
          Break
        EndIf
        errcount + 1
        If errcount >= #MyStability_ERROR_MAX_LOOP
          MyStability_FatalIO(ErrMsg, FileName)
          Break
        EndIf        
      ForEver
    EndIf
    ProcedureReturn result$
  EndMacro
 
  ;}
  ;{*************************** служебные процедуры ***************************
  ;возвращает полное имя файла с путем, для отображения в фатальном экране
  Procedure$ MyStability_GetFullPathName(FileName$)
    If Not FindString(FileName$,":")
      FileName$ = GetCurrentDirectory() + FileName$
    EndIf
    ProcedureReturn FileName$
  EndProcedure
  ;возвращает текстовое представление системной ошибки
  Procedure$ MyStability_SysErrToStr(Err)
    Protected ErrorBuffer$=Space(1024)
    ProcedureReturn PeekS(@ErrorBuffer$,FormatMessage_(#FORMAT_MESSAGE_FROM_SYSTEM, 0, Err, 0, @ErrorBuffer$, StringByteLength(ErrorBuffer$), 0))
  EndProcedure
  ;выдает фатальное сообщение
  Procedure  MyStability_FatalIO(Msg$,FileName$="",Err=0)
    Protected tmp$
    tmp$ = "Невозможно "+Msg$
    If Len(FileName$)      
      tmp$ + ":" + #CRLF$ + MyStability_GetFullPathName(FileName$) + #CRLF$
    EndIf  
    If Err
      tmp$+"Сообщение системы:"+#CRLF$+
           MyStability_SysErrToStr(Err)+#CRLF$
     
    EndIf
    MessageRequester("FATAL ERROR!!!",tmp$,#MB_ICONERROR|#MB_SYSTEMMODAL)
    If #MyStability_END_IF_FATAL
      End
    EndIf
  EndProcedure
 
  ;}
  ;{*************************** подменяемые процедуры ***************************
  ;{ FileSystem
  CompilerIf IsUse(MyStability_CopyDirectory)
    Procedure MyStability_CopyDirectory(SourceDirectory$, DestinationDirectory$, Pattern$ ,Flags = #PB_FileSystem_Recursive|#PB_FileSystem_Force)
      If FileSize(SourceDirectory$) = -1 ;исходеый файл/папка отсутствует
        MyStability_FatalIO("скопировать отсутствующую папку",SourceDirectory$,0)
      Else
        MyStability_CheckDigProc(CopyDirectory(SourceDirectory$, DestinationDirectory$, Pattern$ ,Flags),"скопировать папку",SourceDirectory$)
      EndIf
      ProcedureReturn 0
    EndProcedure
  CompilerEndIf
 
  CompilerIf IsUse(MyStability_CopyFile)
    Procedure MyStability_CopyFile(SourceFilename$, DestinationFilename$)
      If FileSize(SourceFilename$) = -1 ;исходеый файл/папка отсутствует
        MyStability_FatalIO("скопировать отсутствующий файл",SourceFilename$,0)
      Else
        MyStability_CheckDigProc(CopyFile(SourceFilename$, DestinationFilename$),"скопировать файл",SourceFilename$)
      EndIf
      ProcedureReturn 0
    EndProcedure
  CompilerEndIf
 
  CompilerIf IsUse(MyStability_CreateDirectory)
    Procedure MyStability_CreateDirectory(FileName$)
      Select FileSize(FileName$)
        Case -2 ;уже существует - ничего делать не надо
                ;в отличие от стандарта я не считаю это ошибкой, но вернет 0
        Case -1 ;ничего нет, можно создавать
          MyStability_CheckDigProc(CreateDirectory(FileName$),"создать новую папку",FileName$)
        Default ;существует одноименнвй файл - создание папки невозможно
          MyStability_FatalIO("создать новую папку, по причине существования одноименного файла.",FileName$)
      EndSelect
      ProcedureReturn 0
    EndProcedure
  CompilerEndIf
 
  CompilerIf IsUse(MyStability_DeleteDirectory)
    Procedure MyStability_DeleteDirectory(FileName$,Pattern$,Flags=#PB_FileSystem_Recursive|#PB_FileSystem_Force)
      Select FileSize(FileName$)
        Case -1 ;ничего нет, и делать нечего
                ;не ошибка, но вернет 0
        Case -2 ;есть папка - можно удалять
          MyStability_CheckDigProc(DeleteDirectory(FileName$,Pattern$,Flags),"удалить папку",FileName$)
        Default ;это не папка, это файл
          MyStability_FatalIO("удалить папку, это не папка а файл",FileName$)
      EndSelect
      ProcedureReturn 0
    EndProcedure  
  CompilerEndIf
 
  ;CompilerIf IsUse(MyStability_DeleteFile) Or IsUse(MyStability_CreatePreferences)
    Procedure MyStability_DeleteFile(FileName$,Flags=#PB_FileSystem_Force)
      Select FileSize(FileName$)
        Case -2 ;папка
          MyStability_FatalIO("удалить файл, это не файл а папка",FileName$)
        Case -1 ;ничего нет                      
        Default ;файл присутствует
          MyStability_CheckDigProc(DeleteFile(FileName$,Flags),"удалить файл",FileName$)
      EndSelect
      ;если файл отсутствует - ничего удалять не надо, не ошибка но вернет 0
      ProcedureReturn 0
    EndProcedure
  ;CompilerEndIf
 
  CompilerIf IsUse(MyStability_ExamineDirectory)
    Procedure MyStability_ExamineDirectory(NDirectory, DirectoryName$, Pattern$)
      MyStability_CheckDigProc(ExamineDirectory(NDirectory,DirectoryName$,Pattern$),"прочитать содержимое папки",DirectoryName$)
    EndProcedure
  CompilerEndIf
 
  CompilerIf IsUse(MyStability_GetCurrentDirectory)
    Procedure$ MyStability_GetCurrentDirectory()
      MyStability_CheckStrProc(GetCurrentDirectory(),"определить текущую папку")
    EndProcedure
  CompilerEndIf
 
  CompilerIf IsUse(MyStability_GetTemporaryDirectory)
    Procedure$ MyStability_GetTemporaryDirectory()
      MyStability_CheckStrProc(GetTemporaryDirectory(),"определить временную папку")
    EndProcedure
  CompilerEndIf
 
  CompilerIf IsUse(MyStability_RenameFile)
    Procedure MyStability_RenameFile(OldFilename$, NewFilename$)
      If FileSize(OldFilename$) = -1 ;исходеый файл/папка отсутствует
        MyStability_FatalIO("переименовать отсутствующий файл/папку",OldFilename$)
      Else
        MyStability_CheckDigProc(RenameFile(OldFilename$, NewFilename$),"переименовать файл/папку",OldFilename$)
      EndIf
      ProcedureReturn 0
    EndProcedure
  CompilerEndIf
  ;}
  ;{ File
  CompilerIf IsUse(MyStability_CreateFile)
    Procedure MyStability_CreateFile(NFile,FileName$,Flags=0)
      MyStability_DeleteFile(FileName$) ;удаляем, если был
      MyStability_CheckDigProc(CreateFile(NFile,FileName$,Flags),"создать файл",FileName$)
    EndProcedure
  CompilerEndIf
 
  CompilerIf IsUse(MyStability_OpenFile)
    Procedure MyStability_OpenFile(NFile, Filename$ ,Flags=0)
      MyStability_CheckDigProc(OpenFile(NFile, Filename$ ,Flags),"открыть файл",Filename$)
    EndProcedure
  CompilerEndIf
 
  CompilerIf IsUse(MyStability_ReadFile)
    Procedure MyStability_ReadFile(NFile,Filename$,Flags=0)
      MyStability_CheckDigProc(ReadFile(NFile,Filename$,Flags),"прочитать файл",Filename$)
    EndProcedure
  CompilerEndIf  
  ;}
  ;{ Thread
  CompilerIf IsUse(MyStability_CreateMutex)
    Procedure MyStability_CreateMutex()
      MyStability_CheckDigProc(CreateMutex(),"создать мутекс")
    EndProcedure
  CompilerEndIf
 
  CompilerIf IsUse(MyStability_CreateSemaphore)
    Procedure MyStability_CreateSemaphore(InitialCount=0)
      MyStability_CheckDigProc(CreateSemaphore(InitialCount),"создать симафор")
    EndProcedure
  CompilerEndIf
 
  CompilerIf IsUse(MyStability_CreateThread)
    Procedure MyStability_CreateThread(*ProcedureName, *Value)
      MyStability_CheckDigProc(CreateThread(*ProcedureName, *Value),"создать поток")
    EndProcedure
  CompilerEndIf
  ;}
  ;{ Lan
  CompilerIf IsUse(MyStability_InitNetwork)
    Procedure MyStability_InitNetwork()
      MyStability_CheckDigProcLan(InitNetwork(),"инициализировать сетевую подсистему")
    EndProcedure
  CompilerEndIf
 
  CompilerIf IsUse(MyStability_CreateNetworkServer)
    Procedure MyStability_CreateNetworkServer(NServer,Port,Mode=#PB_Network_TCP,BindedIP$="")
      MyStability_CheckDigProcLan(CreateNetworkServer(NServer,Port,Mode,BindedIP$),"открыть порт: "+Str(Port))
    EndProcedure
  CompilerEndIf
 
  CompilerIf IsUse(MyStability_OpenNetworkConnection)
    Procedure MyStability_OpenNetworkConnection(ServerName$,Port,Mode=#PB_Network_TCP,TimeOut=#MyStability_LAN_CONNECT_TIME,LocalIP$="",LocalPort=0)
      Protected errcount,result
      Repeat
        result = OpenNetworkConnection(ServerName$,Port,Mode,TimeOut,LocalIP$,LocalPort)
        If result
          Break
        EndIf
        Delay(#MyStability_LAN_DELAY_LOOP)
        errcount +1
      Until errcount>#MyStability_LAN_ERROR_LOOP
      ProcedureReturn result
    EndProcedure
  CompilerEndIf  
  ;}
  ;{ Http
  CompilerIf IsUse(MyStability_ReceiveHTTPFile) Or IsUse(MyStability_ReceiveHTTPMemory)
    ;структура для передачи в поток thrGetHTTPHeader
    Structure HTTPHeaderStruc
      url$
      head$
    EndStructure
    ;GetHTTPHeader - в отдельном потоке, для остановки по тайм-ауту
    Procedure thrGetHTTPHeader(*url.HTTPHeaderStruc)
      *url\head$ = GetHTTPHeader(*url\url$)
    EndProcedure
    Procedure$ MyStability_GetHTTPHeader(URL$)
      Protected tmp.HTTPHeaderStruc,thr,errcount
      tmp\url$ = URLEncoder(URL$)
      Repeat
        thr = MyStability_CreateThread(@thrGetHTTPHeader(),@tmp)
        If Not WaitThread(thr,#MyStability_LAN_CONNECT_TIME)
          KillThread(thr)
          Delay(#MyStability_LAN_DELAY_LOOP)
          tmp\head$=""
        Else
          Break
        EndIf
        errcount +1
        If errcount>=#MyStability_LAN_ERROR_LOOP
          tmp\head$=""
          Break
        EndIf
      ForEver
      ProcedureReturn tmp\head$
    EndProcedure
    Procedure MyStability_GetHTTPSize(URL$)
      Protected currentline = 1, headerline$, header$ = MyStability_GetHTTPHeader(URL$);пробуем запросить заголовок
                                                                                       ;Debug header$
      If Len(header$) And Left(header$, 4) = "HTTP"                                    ;сервер http(уже хорошо)
        If StringField(header$, 2, " ") = "200"                                        ;ok                                    
          Repeat                                                                       ;ищем длину, для проверки правильности загрузки                              
            currentline +1
            headerline$ = StringField(header$, currentline, #LF$);очередная строка
            If FindString(headerline$, "Content-Length:", 1, #PB_String_NoCase)
              ProcedureReturn Val(StringField(headerline$, 2, " "))
            EndIf  
          Until headerline$=""
          ProcedureReturn 0
        EndIf
      EndIf
      ProcedureReturn -1 ;ошибка
    EndProcedure  
  CompilerEndIf
 
  CompilerIf IsUse(MyStability_ReceiveHTTPFile)
    Procedure MyStability_ReceiveHTTPFile(URL$, Filename$, Flags=0)
      Protected result, headersize, thr, errcount, curfilesize
      URL$ = URLEncoder(URL$)
      ;проверяем наличие
      headersize = MyStability_GetHTTPSize(URL$)
      If headersize = -1
        ProcedureReturn 0
      EndIf
      MyStability_DeleteFile(Filename$) ;зачищаем (вдруг заблокирован)
                                        ;асинхронный режим
      If Flags & #PB_HTTP_Asynchronous
        Repeat
          result = ReceiveHTTPFile(URL$, Filename$, Flags)
          If result
            Break
          EndIf
          errcount +1
          If errcount >= #MyStability_LAN_ERROR_LOOP
            Break
          EndIf
          Delay(#MyStability_LAN_DELAY_LOOP)
        ForEver
        ProcedureReturn result
      EndIf  
      ;синхронный режим
      Repeat
        ;зачищаем (вдруг заблокирован)
        MyStability_DeleteFile(Filename$)
        ;цикл потока приема
        Repeat
          If Not ReceiveHTTPFile(URL$, Filename$, Flags)
            Break
          Else;поток окончен - проверяем результат
            curfilesize = FileSize(Filename$)
            If curfilesize And (headersize = 0 Or (headersize And headersize = curfilesize))
              ProcedureReturn #True
            Else
              Break
            EndIf
          EndIf
        ForEver
        errcount +1
        ;Debug "Err "+errcount+" rSize= "+rhttp\filesize
        If errcount >= #MyStability_LAN_ERROR_LOOP
          MyStability_DeleteFile(Filename$)
          Break
        EndIf
      ForEver
     
      ProcedureReturn 0
    EndProcedure
  CompilerEndIf
 
  CompilerIf IsUse(MyStability_ReceiveHTTPMemory)
    Procedure MyStability_ReceiveHTTPMemory(URL$, Flags=0)
      Protected headersize, errcount, result
      URL$ = URLEncoder(URL$)
      ;проверяем наличие
      headersize = MyStability_GetHTTPSize(URL$)
      If headersize = -1
        ProcedureReturn 0
      EndIf
      ;цикл попыток приема
      Repeat
        result = ReceiveHTTPMemory(URL$, Flags)
        If result
          If Flags & #PB_HTTP_Asynchronous Or headersize = 0 Or headersize = MemorySize(result)
            Break
          Else
            FreeMemory(result)
            result = 0
          EndIf
        EndIf
        errcount +1
        If errcount >= #MyStability_LAN_ERROR_LOOP
          Break
        EndIf
        Delay(#MyStability_LAN_DELAY_LOOP)
      ForEver
      ProcedureReturn result
    EndProcedure
  CompilerEndIf
  ;}
  ;{ Cipher
  CompilerIf IsUse(MyStability_FileFingerprint)
    Procedure$ MyStability_FileFingerprint(FileName$, Plugin, Bits=256, Offset=0, Length=-1)
      If FileSize(FileName$) > 0  ;файл присутствует
        MyStability_CheckStrProc(FileFingerprint(FileName$, Plugin, Bits, Offset, Length),"прочитать файл, нет доступа",FileName$)
      Else  ;нет файла
        MyStability_FatalIO("прочитать файл, по причине его отсутствия",FileName$,0)
      EndIf
      ProcedureReturn ""
    EndProcedure
  CompilerEndIf
  ;}
  ;{ Preferences
  CompilerIf IsUse(MyStability_CreatePreferences)
    Procedure MyStability_CreatePreferences(Filename$,Flags=0)
      MyStability_DeleteFile(Filename$)
      MyStability_CheckDigProc(CreatePreferences(Filename$,Flags),"создать файл настроек",Filename$)
    EndProcedure
  CompilerEndIf
 
  CompilerIf IsUse(MyStability_OpenPreferences)
    Procedure MyStability_OpenPreferences(Filename$,Flags=0)
      MyStability_CheckDigProc(OpenPreferences(Filename$,Flags),"открыть файл настроек",Filename$)
    EndProcedure
  CompilerEndIf
  ;}
  ;{ RunProgram
  CompilerIf IsUse(MyStability_RunProgram)
    Procedure MyStability_RunProgram(Filename$,Parameter$="",WorkingDirectory$="",Flags=0,SenderProgram=0)
      MyStability_CheckDigProc(RunProgram(Filename$,Parameter$,WorkingDirectory$,Flags,SenderProgram),"выполнить",Filename$)
    EndProcedure
  CompilerEndIf
  ;}
  ;}
CompilerEndIf
EndOfInclude(MyStability)
 


Достоинства:
1) неиспользуемые процедуры в выходной файл не попадают.
Недостатки:
1) подмененная процедура должна быть последней в строке (ограничение IncludeOnDemandCore)

зы. оба варианта использовались в реальном проекте, чем доказали работоспособность.


Вернуться наверх
 Профиль  
 
Показать сообщения за:  Сортировать по:  
Начать новую тему Ответить на тему  [ 1 сообщение ] 

Часовой пояс: UTC + 3 часа


Кто сейчас на форуме

Сейчас этот форум просматривают: нет зарегистрированных пользователей и гости: 4


Вы не можете начинать темы
Вы не можете отвечать на сообщения
Вы не можете редактировать свои сообщения
Вы не можете удалять свои сообщения
Вы не можете добавлять вложения

Найти:
Перейти:  
cron
Создано на основе phpBB® Forum Software © phpBB Group (блог о phpBB)
Сборка создана CMSart Studio
Русская поддержка phpBB