summaryrefslogtreecommitdiff
path: root/migrationanalysis/src/wizard/Analyse.bas
blob: b74838057e609690cb25a7b2b7d45b3b6c879bfb (plain)
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
Attribute VB_Name = "Analyse"
'/*************************************************************************
' *
' * DO NOT ALTER OR REMOVE COPYRIGHT NOTICES OR THIS FILE HEADER.
' * 
' * Copyright 2008 by Sun Microsystems, Inc.
' *
' * OpenOffice.org - a multi-platform office productivity suite
' *
' * $RCSfile: Analyse.bas,v $
' * $Revision: 1.2.66.1 $
' *
' * This file is part of OpenOffice.org.
' *
' * OpenOffice.org is free software: you can redistribute it and/or modify
' * it under the terms of the GNU Lesser General Public License version 3
' * only, as published by the Free Software Foundation.
' *
' * OpenOffice.org is distributed in the hope that it will be useful,
' * but WITHOUT ANY WARRANTY; without even the implied warranty of
' * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
' * GNU Lesser General Public License version 3 for more details
' * (a copy is included in the LICENSE file that accompanied this code).
' *
' * You should have received a copy of the GNU Lesser General Public License
' * version 3 along with OpenOffice.org.  If not, see
' * <http://www.openoffice.org/license.html>
' * for a copy of the LGPLv3 License.
' *
' ************************************************************************/

Option Explicit

Private Const C_STAT_NOT_STARTED    As Integer = 1
Private Const C_STAT_RETRY          As Integer = 2
Private Const C_STAT_ERROR          As Integer = 3
Private Const C_STAT_DONE           As Integer = 4
Private Const C_STAT_ABORTED        As Integer = 5

Private Const C_MAX_RETRIES         As Integer = 5
Private Const C_ABORT_TIMEOUT       As Integer = 30

Private Const MAX_WAIT_TIME     As Long = 600

Private Const C_STAT_FINISHED   As String = "finished"
Private Const C_STAT_ANALYSED   As String = "analysed="
Private Const C_STAT_ANALYSING  As String = "analysing="
Private Const CSINGLE_FILE      As String = "singlefile"
Private Const CFILE_LIST        As String = "filelist"
Private Const CSTAT_FILE        As String = "statfilename"
Private Const CLAST_CHECKPOINT  As String = "LastCheckpoint"
Private Const CNEXT_FILE        As String = "NextFile"
Private Const C_ABORT_ANALYSIS  As String = "AbortAnalysis"

Private Const CAPPNAME_WORD         As String = "word"
Private Const CAPPNAME_EXCEL        As String = "excel"
Private Const CAPPNAME_POWERPOINT   As String = "powerpoint"
Private Const C_EXENAME_WORD        As String = "winword.exe"
Private Const C_EXENAME_EXCEL       As String = "excel.exe"
Private Const C_EXENAME_POWERPOINT  As String = "powerpnt.exe"

Const CNEW_RESULTS_FILE = "newresultsfile"
Const C_LAUNCH_DRIVER = ".\resources\LaunchDrivers.exe"

'from http://support.microsoft.com/kb/q129796

Private Type STARTUPINFO
    cb As Long
    lpReserved As String
    lpDesktop As String
    lpTitle As String
    dwX As Long
    dwY As Long
    dwXSize As Long
    dwYSize As Long
    dwXCountChars As Long
    dwYCountChars As Long
    dwFillAttribute As Long
    dwFlags As Long
    wShowWindow As Integer
    cbReserved2 As Integer
    lpReserved2 As Long
    hStdInput As Long
    hStdOutput As Long
    hStdError As Long
End Type

Private Type PROCESS_INFORMATION
    hProcess As Long
    hThread As Long
    dwProcessID As Long
    dwThreadID As Long
End Type

Private Declare Function WaitForSingleObject Lib "kernel32" (ByVal _
    hHandle As Long, ByVal dwMilliseconds As Long) As Long

Private Declare Function CreateProcessA Lib "kernel32" (ByVal _
    lpApplicationName As String, ByVal lpCommandLine As String, ByVal _
    lpProcessAttributes As Long, ByVal lpThreadAttributes As Long, _
    ByVal bInheritHandles As Long, ByVal dwCreationFlags As Long, _
    ByVal lpEnvironment As Long, ByVal lpCurrentDirectory As String, _
    lpStartupInfo As STARTUPINFO, lpProcessInformation As _
    PROCESS_INFORMATION) As Long

Private Declare Function CloseHandle Lib "kernel32" _
    (ByVal hObject As Long) As Long

Private Declare Function GetExitCodeProcess Lib "kernel32" _
    (ByVal hProcess As Long, lpExitCode As Long) As Long

Private Declare Function TerminateProcess Lib "kernel32" (ByVal hProcess As Long, _
        ByVal uExitCode As Long) As Long

Private Const NORMAL_PRIORITY_CLASS = &H20&
Private Const WAIT_TIMEOUT  As Long = &H102
Private Const ABORTED       As Long = -2

' from http://vbnet.mvps.org/index.html?code/system/toolhelpprocesses.htm
Public Const TH32CS_SNAPPROCESS As Long = 2&
Public Const MAX_PATH As Long = 260

Public Type PROCESSENTRY32
    dwSize As Long
    cntUsage As Long
    th32ProcessID As Long
    th32DefaultHeapID As Long
    th32ModuleID As Long
    cntThreads As Long
    th32ParentProcessID As Long
    pcPriClassBase As Long
    dwFlags As Long
    szExeFile As String * MAX_PATH
End Type
    
Public Declare Function CreateToolhelp32Snapshot Lib "kernel32" _
   (ByVal lFlags As Long, ByVal lProcessID As Long) As Long

Public Declare Function ProcessFirst Lib "kernel32" _
    Alias "Process32First" _
   (ByVal hSnapShot As Long, uProcess As PROCESSENTRY32) As Long

Public Declare Function ProcessNext Lib "kernel32" _
    Alias "Process32Next" _
   (ByVal hSnapShot As Long, uProcess As PROCESSENTRY32) As Long


Public Function IsOfficeAppRunning(curApplication As String) As Boolean
'DV: we need some error handling here
    Dim hSnapShot As Long
    Dim uProcess As PROCESSENTRY32
    Dim success As Long
    Dim bRet As Boolean
    Dim bAppFound As Boolean
    Dim exeName As String
    Dim curExeName As String

    bRet = True
    On Error GoTo FinalExit

    curExeName = LCase$(curApplication)

    If (curExeName = CAPPNAME_WORD) Then
        exeName = C_EXENAME_WORD
    ElseIf (curExeName = CAPPNAME_EXCEL) Then
        exeName = C_EXENAME_EXCEL
    ElseIf (curExeName = CAPPNAME_POWERPOINT) Then
        exeName = C_EXENAME_POWERPOINT
    Else
        GoTo FinalExit
    End If

    hSnapShot = CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0&)

    If hSnapShot = -1 Then GoTo FinalExit

    uProcess.dwSize = Len(uProcess)
    success = ProcessFirst(hSnapShot, uProcess)
    bAppFound = False

    While ((success = 1) And Not bAppFound)
        Dim i As Long
        i = InStr(1, uProcess.szExeFile, Chr(0))
        curExeName = LCase$(Left$(uProcess.szExeFile, i - 1))
        If (curExeName = exeName) Then
            bAppFound = True
        Else
            success = ProcessNext(hSnapShot, uProcess)
        End If
    Wend
    bRet = bAppFound
    
    Call CloseHandle(hSnapShot)

FinalExit:
    IsOfficeAppRunning = bRet

End Function

Private Sub CalculateProgress(statusFileName As String, fso As FileSystemObject, _
                              lastIndex As Long, docOffset As Long, _
                              myDocList As Collection)

    On Error GoTo FinalExit

    Dim curFile As String
    Dim fileCont As TextStream
    Dim myFile As file

    If (fso.FileExists(statusFileName)) Then
        Dim statLine As String

        Set fileCont = fso.OpenTextFile(statusFileName, ForReading, False, TristateTrue)
        statLine = fileCont.ReadLine

        If (Left(statLine, Len(C_STAT_ANALYSED)) = C_STAT_ANALYSED) Then
            curFile = Mid(statLine, Len(C_STAT_ANALYSED) + 1)
        ElseIf (Left(statLine, Len(C_STAT_ANALYSING)) = C_STAT_ANALYSING) Then
            curFile = Mid(statLine, Len(C_STAT_ANALYSING) + 1)
        End If
    End If
    
    ' when we don't have a file, we will show the name of the last used file in
    ' the progress window
    If (curFile = "") Then curFile = myDocList.item(lastIndex)

    If (GetDocumentIndex(curFile, myDocList, lastIndex)) Then
        Set myFile = fso.GetFile(curFile)
        Call ShowProgress.SP_UpdateProgress(myFile.Name, myFile.ParentFolder.path, lastIndex + docOffset)
    End If

FinalExit:
    If Not (fileCont Is Nothing) Then fileCont.Close
    Set fileCont = Nothing
    Set myFile = Nothing

End Sub

Function CheckAliveStatus(statFileName As String, _
                          curApplication As String, _
                          lastDate As Date, _
                          fso As FileSystemObject) As Boolean

    Dim isAlive As Boolean
    Dim currDate As Date
    Dim statFile As file
    Dim testing As Long

    isAlive = False

    If Not fso.FileExists(statFileName) Then
        currDate = Now()
        If (val(DateDiff("s", lastDate, currDate)) > MAX_WAIT_TIME) Then
            isAlive = False
        Else
            isAlive = True
        End If
    Else
        Set statFile = fso.GetFile(statFileName)
        currDate = statFile.DateLastModified
        If (currDate > lastDate) Then
            lastDate = currDate
            isAlive = True
        Else
            currDate = Now()
            If (lastDate >= currDate) Then   ' There might be some inaccuracies in file and system dates
                isAlive = True
            ElseIf (val(DateDiff("s", lastDate, currDate)) > MAX_WAIT_TIME) Then
                isAlive = False
            Else
                isAlive = IsOfficeAppRunning(curApplication)
            End If
        End If
    End If

    CheckAliveStatus = isAlive
End Function

Sub TerminateOfficeApps(fso As FileSystemObject, aParameter As String)

    Dim msoKillFileName As String

    msoKillFileName = fso.GetAbsolutePathName(".\resources\msokill.exe")
    If fso.FileExists(msoKillFileName) Then
        Shell msoKillFileName & aParameter
    Else
    End If
End Sub

Public Function launchDriver(statFileName As String, cmdLine As String, _
                             curApplication As String, fso As FileSystemObject, _
                             myDocList As Collection, myOffset As Long, _
                             myIniFilePath As String) As Long

    Dim proc As PROCESS_INFORMATION
    Dim start As STARTUPINFO
    Dim ret As Long
    Dim currDate As Date
    Dim lastIndex As Long

    currDate = Now()
    lastIndex = 1

    ' Initialize the STARTUPINFO structure:
    start.cb = Len(start)
            
    ' Start the shelled application:
    ret = CreateProcessA(vbNullString, cmdLine$, 0&, 0&, 1&, _
                         NORMAL_PRIORITY_CLASS, 0&, vbNullString, start, proc)

    ' Wait for the shelled application to finish:
    Do
        ret = WaitForSingleObject(proc.hProcess, 100)
        If ret <> WAIT_TIMEOUT Then
            Exit Do
        End If
        If Not CheckAliveStatus(statFileName, curApplication, currDate, fso) Then
            ' Try to close open office dialogs and then wait a little bit
            TerminateOfficeApps fso, " --close"
            ret = WaitForSingleObject(proc.hProcess, 1000)

            ' next try to kill all office programs and then wait a little bit
            TerminateOfficeApps fso, " --kill"
            ret = WaitForSingleObject(proc.hProcess, 1000)

            ret = TerminateProcess(proc.hProcess, "0")
            ret = WAIT_TIMEOUT
            Exit Do
        End If
        If (ShowProgress.g_SP_Abort) Then
            WriteToLog C_ABORT_ANALYSIS, True, myIniFilePath
            Call HandleAbort(proc.hProcess, curApplication)
            ret = ABORTED
            Exit Do
        End If
        Call CalculateProgress(statFileName, fso, lastIndex, myOffset, myDocList)
        DoEvents                                'allow other processes
    Loop While True
    
    If (ret <> WAIT_TIMEOUT) And (ret <> ABORTED) Then
        Call GetExitCodeProcess(proc.hProcess, ret&)
    End If
    Call CloseHandle(proc.hThread)
    Call CloseHandle(proc.hProcess)
    launchDriver = ret
End Function

Function CheckAnalyseStatus(statusFileName As String, _
                            lastFile As String, _
                            fso As FileSystemObject) As Integer

    Dim currStatus As Integer
    Dim fileCont As TextStream

    If Not fso.FileExists(statusFileName) Then
        currStatus = C_STAT_NOT_STARTED
    Else
        Dim statText As String
        Set fileCont = fso.OpenTextFile(statusFileName, ForReading, False, TristateTrue)
        statText = fileCont.ReadLine
        If (statText = C_STAT_FINISHED) Then
            currStatus = C_STAT_DONE
        ElseIf (Left(statText, Len(C_STAT_ANALYSED)) = C_STAT_ANALYSED) Then
            currStatus = C_STAT_RETRY
            lastFile = Mid(statText, Len(C_STAT_ANALYSED) + 1)
        ElseIf (Left(statText, Len(C_STAT_ANALYSING)) = C_STAT_ANALYSING) Then
            currStatus = C_STAT_RETRY
            lastFile = Mid(statText, Len(C_STAT_ANALYSING) + 1)
        Else
            currStatus = C_STAT_ERROR
        End If
        fileCont.Close
    End If

    CheckAnalyseStatus = currStatus
End Function

Function WriteDocsToAnalyze(myDocList As Collection, myApp As String, _
                            fso As FileSystemObject) As String
    On Error GoTo HandleErrors
    Dim currentFunctionName As String
    currentFunctionName = "WriteDocsToAnalyze"

    Dim TempPath As String
    Dim fileName As String
    Dim fileContent As TextStream

    fileName = ""
    TempPath = fso.GetSpecialFolder(TemporaryFolder).path

    If (TempPath = "") Then
        TempPath = "."
    End If

    Dim vFileName As Variant
    Dim Index As Long
    Dim limit As Long
    
    limit = myDocList.count
    If (limit > 0) Then
        fileName = fso.GetAbsolutePathName(TempPath & "\FileList" & myApp & ".txt")
        Set fileContent = fso.OpenTextFile(fileName, ForWriting, True, TristateTrue)
    
        For Index = 1 To limit
            vFileName = myDocList(Index)
            fileContent.WriteLine (vFileName)
        Next
        
        fileContent.Close
    End If

FinalExit:
    Set fileContent = Nothing
    WriteDocsToAnalyze = fileName
    Exit Function

HandleErrors:
    WriteDebug currentFunctionName & " : " & Err.Number & " " & Err.Description & " " & Err.Source
    Resume FinalExit
End Function

' This function looks for the given document name in the document collection
' and returns TRUE and the position of the document in that collection if found,
' FALSE otherwise
Function GetDocumentIndex(myDocument As String, _
                          myDocList As Collection, _
                          lastIndex As Long) As Boolean

    Dim currentFunctionName As String
    currentFunctionName = "GetDocumentIndex"
    
    On Error GoTo HandleErrors
    
    Dim lastEntry As Long
    Dim curIndex As Long
    Dim curEntry As String
    Dim entryFound As Boolean
    
    entryFound = False
    lastEntry = myDocList.count
    curIndex = lastIndex

    ' We start the search at the position of the last found
    ' document
    While Not entryFound And curIndex <= lastEntry
        curEntry = myDocList.item(curIndex)
        If (curEntry = myDocument) Then
            lastIndex = curIndex
            entryFound = True
        Else
            curIndex = curIndex + 1
        End If
    Wend

    ' When we could not find the document, we start the search
    ' from the beginning of the list
    If Not entryFound Then
        curIndex = 1
        While Not entryFound And curIndex <= lastIndex
            curEntry = myDocList.item(curIndex)
            If (curEntry = myDocument) Then
                lastIndex = curIndex
                entryFound = True
            Else
                curIndex = curIndex + 1
            End If
        Wend
    End If

FinalExit:
    GetDocumentIndex = entryFound
    Exit Function
HandleErrors:
    WriteDebug currentFunctionName & " : " & Err.Number & " " & Err.Description & " " & Err.Source
    Resume FinalExit
End Function

Function AnalyseList(myDocList As Collection, _
                     myApp As String, _
                     myIniFilePath As String, _
                     myOffset As Long, _
                     analysisAborted As Boolean) As Boolean

    On Error GoTo HandleErrors
    Dim currentFunctionName As String
    currentFunctionName = "AnalyseList"

    Dim cmdLine As String
    Dim filelist As String
    Dim statFileName As String
    Dim finished As Boolean
    Dim analyseStatus As Integer
    Dim nRetries As Integer
    Dim lastFile As String
    Dim lastHandledFile As String
    Dim launchStatus As Long
    Dim fso As New FileSystemObject
    Dim progressTitle As String

    filelist = WriteDocsToAnalyze(myDocList, myApp, fso)
    cmdLine = fso.GetAbsolutePathName(C_LAUNCH_DRIVER) & " " & myApp
    finished = False

    Dim TempPath As String
    TempPath = fso.GetSpecialFolder(TemporaryFolder).path
    If (TempPath = "") Then TempPath = "."
    statFileName = fso.GetAbsolutePathName(TempPath & "\StatFile" & myApp & ".txt")
    If (fso.FileExists(statFileName)) Then fso.DeleteFile (statFileName)

    WriteToLog CFILE_LIST, filelist, myIniFilePath
    WriteToLog CSTAT_FILE, statFileName, myIniFilePath
    WriteToLog CLAST_CHECKPOINT, "", myIniFilePath
    WriteToLog CNEXT_FILE, "", myIniFilePath
    WriteToLog C_ABORT_ANALYSIS, "", myIniFilePath

    ' In this loop we will restart the driver until we have finished the analysis
    nRetries = 0
    While Not finished And nRetries < C_MAX_RETRIES
        launchStatus = launchDriver(statFileName, cmdLine, myApp, fso, _
                                    myDocList, myOffset, myIniFilePath)
        If (launchStatus = ABORTED) Then
            finished = True
            analyseStatus = C_STAT_ABORTED
            analysisAborted = True
        Else
            analyseStatus = CheckAnalyseStatus(statFileName, lastHandledFile, fso)
        End If
        If (analyseStatus = C_STAT_DONE) Then
            finished = True
        ElseIf (analyseStatus = C_STAT_RETRY) Then
            If (lastHandledFile = lastFile) Then
                nRetries = nRetries + 1
            Else
                lastFile = lastHandledFile
                nRetries = 1
            End If
        Else
            nRetries = nRetries + 1
        End If
    Wend
    
    If (analyseStatus = C_STAT_DONE) Then
        AnalyseList = True
    Else
        AnalyseList = False
    End If

    'The next driver should not overwrite this result file
    WriteToLog CNEW_RESULTS_FILE, "False", myIniFilePath

FinalExit:
    Set fso = Nothing
    Exit Function

HandleErrors:
    AnalyseList = False
    WriteDebug currentFunctionName & " : " & Err.Number & " " & Err.Description & " " & Err.Source
    Resume FinalExit
End Function

Sub HandleAbort(hProcess As Long, curApplication As String)

    On Error Resume Next

    Dim ret As Long
    Dim curDate As Date
    Dim stillWaiting As Boolean
    Dim killApplication As Boolean
    Dim waitTime As Long

    curDate = Now()
    stillWaiting = True
    killApplication = False

    While stillWaiting
        stillWaiting = IsOfficeAppRunning(curApplication)
        If (stillWaiting) Then
            waitTime = val(DateDiff("s", curDate, Now()))
            If (waitTime > C_ABORT_TIMEOUT) Then
                stillWaiting = False
                killApplication = True
            End If
        End If
    Wend

    If (killApplication) Then
        ShowProgress.g_SP_AllowOtherDLG = True
        TerminateMSO.Show vbModal, ShowProgress
    End If
    
    ret = TerminateProcess(hProcess, "0")
End Sub