File: builder.tcl

package info (click to toggle)
cbrowser 0.8-1
  • links: PTS
  • area: main
  • in suites: sarge, woody
  • size: 324 kB
  • ctags: 66
  • sloc: tcl: 4,572; makefile: 34
file content (513 lines) | stat: -rw-r--r-- 15,943 bytes parent folder | download | duplicates (3)
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
# -*- tcl -*-

# $Id: builder.tcl,v 1.1 2000/06/26 19:23:59 cfelaco Exp $

# Cbrowser is a C/C++ source code indexing, querying and browsing tool
# Copyright (C) 1998  B. Christopher Felaco

# This program is free software; you can redistribute it and/or
# modify it under the terms of the GNU General Public License
# as published by the Free Software Foundation; either version 2
# of the License, or (at your option) any later version.

# This program 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 General Public License for more details.

# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.

# For more information about Cbrowser and it's author see:
#    URL:http://cbrowser.sourceforge.net/
#
# Feel free to contact me at URL:mailto:cfelaco@users.sourceforge.net
# with enhancements or suggestions.

# $Log: builder.tcl,v $
# Revision 1.1  2000/06/26 19:23:59  cfelaco
# Initial source file revisions for sourceforge.net.
# Existing revision history is based on RCS revisions made by original author
# in private repository.
#
# Revision 0.6  1999/03/15 01:19:16  chris
# Add support for 'xz' backend query type.
# Begin support for NT - not complete until pipe asynch IO problems resolved.
# Reorganize dialog rows.
# Add reserved words toggle for xz.
# Fetch filenames from selected database for rebuilding.
#
# Revision 0.5  1998/07/16 17:07:07  chris
# Build_dialog now prompts for filename first, so it needs the parent of the
# file dialog.
# Magic scrollbars for directory list.
# Minsize for dialogs.
# Use tk_messageBox instead of tk_dialog.
#
# Revision 0.4  1998/06/27 22:35:41  chris
# Initial revision, synched with cbrowser v0.4
#

#----------------------------------------------------------------------------
# This file contains functions that implement the database builder portions
# of cbrowser.  The functions cannot operate unless called from within
# cbrowser.
#----------------------------------------------------------------------------

##############################################################################
#
#  Purpose    : Create or raise a dialog to get information about building
#               a database.
#
#  Parameters : toplevel - the toplevel build dialog to create
#               parent - the parent window of the file selection dialog
#
#  Result     : NONE
#
##############################################################################

proc build_dialog {toplevel parent} {
  global build_dbase build_backend build_which build_source build_include \
      build_status query_backend query_backend_list

  if {[strcmp $build_status "none"] != 0} {
    tk_messageBox -parent $toplevel -title "Error" -type ok -icon error \
        -message "A build is already in progress."
    return
  }

  set new_dbase [select_database $parent 1]
  if {[strlen $new_dbase] == 0} {
    return
  }
  set build_dbase($toplevel) $new_dbase
  set build_backend($toplevel) [database_backend $new_dbase]

  set build_which($toplevel) source

  set build_source($toplevel) {}
  set build_include($toplevel) {}

  if {[strcmp $build_backend($toplevel) "xz"] == 0 &&
      [file exists $new_dbase]} {
    set build_source($toplevel) [build_get_xz_modules $new_dbase]
  }

  if [winfo exists $toplevel] {

    wm deiconify $toplevel
    catch {raise $toplevel}

    build_switch $toplevel source
    return
  }

  toplevel $toplevel

  # Top row contains the target file name
  set row [frame $toplevel.filerow]
  pack $row -side top -fill x -padx 5

  label $toplevel.flabel -text "Database: "
  label $toplevel.filename -textvariable build_dbase($toplevel) \
      -relief groove -padx 3
  eval tk_optionMenu $toplevel.backend build_backend($toplevel) \
      $query_backend_list
  pack $toplevel.flabel -side left -in $row
  pack $toplevel.filename -side left -fill x -expand yes -in $row
  pack $toplevel.backend -side left -padx 3 -in $row

  # Radio buttons and add/remove buttons
  set row [frame $toplevel.radiorow]
  pack $row -side top ; #-fill x -expand yes

  radiobutton $toplevel.source -variable build_which($toplevel) \
      -text "Source" -value source  -command "build_switch $toplevel source"
  radiobutton $toplevel.include -variable build_which($toplevel) \
      -text "Include" -value include -command "build_switch $toplevel include"

  pack $toplevel.source $toplevel.include -in $row -side left

  button $toplevel.add -text "Add" -command "build_add $toplevel" -width 10
  button $toplevel.remove -text "Remove" -command "build_remove $toplevel" \
      -width 10

  pack $toplevel.add    -in $row -side left -padx 5
  pack $toplevel.remove -in $row -side left -padx 5

  # Next row contains the entry field and select button
  set row [frame $toplevel.entryrow]
  pack $row -side top -padx 5 -fill x

  label $toplevel.elabel -text "Entry: "
  entry $toplevel.entry -width 30
  button $toplevel.sselect -text "Select" \
      -command "build_file_select $toplevel.entry"
  bind $toplevel.entry <Return> [list $toplevel.add invoke]
  pack $toplevel.elabel -side left -in $row
  pack $toplevel.entry -side left -fill x -expand yes -in $row
  pack $toplevel.sselect -side left -padx 3 -in $row

  # Next row contains the listbox
  set row [frame $toplevel.list_row]
  pack $row -expand yes -fill both -side top

  listbox $toplevel.list \
      -selectmode extended \
      -exportselection false

  magic_scroll $toplevel.list $row

  # Bindings
  bind $toplevel.list <Delete> [list $toplevel.remove invoke]
  bind $toplevel.list <BackSpace> [list $toplevel.remove invoke]
  bind $toplevel.list <Button-1> \
      "$toplevel.entry delete 0 end
       $toplevel.entry insert 0 \[ %W get \[%W nearest %y\]\]
      "

  # The next row is for toggles
  set row [frame $toplevel.toggles]
  checkbutton $toplevel.force -text "Force Rebuild" \
      -variable build_force($toplevel)
  checkbutton $toplevel.reserved -text "Reserved Words" \
      -variable build_reserved($toplevel)
  pack $toplevel.force $toplevel.reserved -side left -in $row
  pack $row -side top

  # The bottom row should be the buttonbar
  frame $toplevel.buttonbar
  pack  $toplevel.buttonbar -side top;

  button $toplevel.ok -text OK -width 8 \
      -command [concat "wm withdraw $toplevel;" \
                    "build_database $toplevel.progress " \
                    "\$build_dbase($toplevel) " \
                    "\$build_backend($toplevel) " \
                    "\$build_force($toplevel) \$build_reserved($toplevel)" \
                    "\$build_source($toplevel) \$build_include($toplevel)"]
  button $toplevel.cancel -text Cancel -width 8 \
      -command "wm withdraw $toplevel; set build_status none"
  global button_defaults
  if {$button_defaults} {
    $toplevel.ok configure -default active
    $toplevel.cancel configure -default normal
  }
  # The build_status is set so that another procedure can wait on the variable
  # to detect completion of the build.
  button $toplevel.help -text Help -width 8 -command {help_proc building}
  pack $toplevel.ok $toplevel.cancel $toplevel.help -side left \
      -in $toplevel.buttonbar -padx 10

  bind $toplevel <<Cancel>> "$toplevel.cancel invoke"
  bind $toplevel <<Help>> "$toplevel.help invoke"

  wm title $toplevel "Database Build Dialog"
  wm geometry $toplevel 450x350

  # Call build_switch to initialize the listbox
  build_switch $toplevel source
}

proc build_dbase_select {entry} {
  set new_dbase [select_database [winfo toplevel $entry] 1]
  if {[strlen $new_dbase] != 0} {
    $entry delete 0 end
    $entry insert 0 $new_dbase
    cd [file dirname $new_dbase]
  }
}

proc build_file_select {entry} {

  set filetypes {
    {"C/C++ source files" {".c" ".cc" ".C" ".CC" ".cpp" ".h" ".H"}}
    {"All files" {*}}
  }

  set result [tk_getOpenFile \
                  -parent [winfo toplevel $entry] \
                  -filetypes $filetypes \
                  -title "Select File"]

  if {[strlen $result] != 0} {
    $entry delete 0 end
    $entry insert 0 $result
  }
}

##############################################################################
#
#  Purpose    : Perform a database build.
#
#  Parameters : toplevel - the toplevel build progress dialog
#               new_dbase - the new database file to construct
#               unconditional - boolean to force rebuild of database
#               reserved - boolean to include reserved words (xz only)
#               source_list - source files to scan
#               include_list - directories to search for include files
#
#  Result     : NONE
#
##############################################################################

proc build_database {toplevel new_dbase backend unconditional reserved \
                         {source_list {}} {include_list {}}} {
  global env build_status database_file

  if {[strcmp $new_dbase $database_file] == 0} {
    global query_pipe
    if [info exists query_pipe] {
      catch {close $query_pipe}
      unset query_pipe
    }
  }

  if {![winfo exists $toplevel]} {
    toplevel $toplevel
    label $toplevel.label -text "Build Progress"
    label $toplevel.line -width 50 -relief sunken
    pack $toplevel.label $toplevel.line -side top -fill x
    button $toplevel.abort -text Abort
    pack $toplevel.abort -side top
    wm title $toplevel "Build Progress"
  } else {
    wm deiconify $toplevel
    catch {raise $toplevel}
  }

  # Set an initial value for the progress field.
  $toplevel.line configure -text "(waiting for response)"

  # Switch to the directory of the database so relative paths are set properly
  set cwd [pwd]
  cd [file dirname $new_dbase]

  # Start the build process.  When building, status lines are written to
  # stderr, so the output must be redirected into one stream.
  switch -glob -- $backend {
    "cs*" {
      #set env(SOURCEDIRS) [join $source_list ":"]
      set env(INCLUDEDIRS) [join $include_list ":"]

      set cmd [concat "|$backend -b -f $new_dbase " $source_list]
      if {$unconditional} {
        lappend cmd "-u"
      }
    }
    "xz" {
      if {$reserved} {set flag "-w"}
      set cmd [concat "|$backend -t 1 $flag -ny -f $new_dbase " $source_list]
    }
    default {
      error "Unknown backend program \"$backend\"."
    }
  }

  lappend cmd "|&" "cat"
  if [catch {open $cmd "r"} f] {
    global errorInfo errorCode
    set info $errorInfo; set code $errorCode
    wm withdraw $toplevel
    error $f $info $code
  }
  cd $cwd
  if {[strlen $f] == 0} {
    error
  }

  # Disable submit temporarily
  #.submit configure -state disabled

  # Register the handler for the input pipe
  fileevent $f readable "build_handler $toplevel $f"
  set build_status "building $new_dbase"

  update idletasks

  # Set up the abort button on the dialog.  This must be done each time so
  # that the file argument is updated.
  $toplevel.abort configure -command [list build_abort $f]

  # Process file and user events until done or user presses Abort
  tkwait variable build_status

  catch {close $f; fileevent $f readable ""}

  $toplevel.line configure -text "Build Complete"
  after 1000 "wm withdraw $toplevel"

  # Clear the build status flag
  set build_status none
}

##############################################################################
#
#  Purpose    : Add directories matching wildcard pattern to the list of
#                included directories for a database build.
#
#  Parameters : toplevel - the toplevel build dialog
#
#  Result     : NONE
#
##############################################################################

set build_status "none"

proc build_add {toplevel} {
  global build_dbase

  upvar build_which($toplevel) which_list
  upvar build_${which_list}($toplevel) the_list

  # Save the current dir and switch to the database dir
  set cwd [pwd]
  cd [file dirname $build_dbase($toplevel)]

  set pattern [$toplevel.entry get]
  if [catch {glob $pattern} file_list] {
    tk_messageBox -parent $toplevel -title "Error" -type ok -icon error \
        -message "No files match the pattern:\n$pattern"
    cd $cwd
    return
  }
  set junk_list ""
  foreach file $file_list {
    set file [file nativename $file]

    if {[strcmp [file pathtype $file] "relative"] == 0} {
      set file [file join [pwd] $file]
    }

    if {([strcmp $which_list "include"] == 0 && ![file isdirectory $file]) ||
        ![file exists $file]} {
      lappend junk_list $file
      continue
    }

    if {[lsearch $the_list $file] < 0} {
      $toplevel.list insert end $file
      lappend the_list $file
    }
  }
  if {[strlen $junk_list] > 0} {
    tk_messageBox -parent $toplevel -title "Error" -type ok -icon error \
        -message "The following are not valid:\n[join $junk_list \n]"
  }
  # Return to the original directory
  cd $cwd
}

##############################################################################
#
#  Purpose    : Remove an item from the directory list.
#
#  Parameters : toplevel - the toplevel build dialog
#
#  Result     : NONE
#
##############################################################################

proc build_remove {toplevel} {
  upvar build_which($toplevel) which_list
  upvar build_${which_list}($toplevel) the_list

  foreach entry [$toplevel.list curselection] {
    set value [$toplevel.list get $entry]

    # Find the index of the entry
    set index [lsearch -exact $the_list $value]
    # Remove the entry
    set the_list [lreplace $the_list $index $index]
  }

  # Clear the listbox and re-add the elements
  $toplevel.list delete 0 end
  eval $toplevel.list insert 0 $the_list
}

##############################################################################
#
#  Purpose    : Switch the list to the source directories or include dirs.
#
#  Parameters : toplevel - the toplevel build dialog
#               new_value - the new value, either "source" or "include"
#
#  Result     : 
#
##############################################################################

proc build_switch {toplevel new_value} {
  upvar build_${new_value}($toplevel) the_list

  $toplevel.list delete 0 end
  eval $toplevel.list insert 0 $the_list
}

##############################################################################
#
#  Purpose    : Handle status output from a database build.
#
#  Parameters : toplevel - the toplevel build dialog
#               pipe - the file handle of the input pipe
#
#  Result     : NONE
#
##############################################################################

proc build_handler {toplevel pipe} {
  global current_results

  if [eof $pipe] {
    catch {close $pipe}
    global build_status
    set build_status "done"
    return
  }

  gets $pipe line

  $toplevel.line configure -text $line
  update
}

##############################################################################
#
#  Purpose    : Abort a running database build.
#
#  Parameters : pipe - the file handle of the input pipe
#
#  Result     : NONE
#
##############################################################################

proc build_abort {pipe} {
  global build_status

  # The process must be killed, or the file close will hang
  foreach pid [pid $pipe] {
    exec kill $pid
  }
  set build_status "abort"
}

##############################################################################
#
#  Purpose    : Get the list of modules used in a xz database.
#
#  Parameters : dbname - the xz database name
#
#  Result     : NONE
#
##############################################################################

proc build_get_xz_modules {dbname} {
  set lines [exec echo .M | xz -f $dbname]

  set modules {}
  foreach line [split $lines "\n"] {
    lappend modules [lindex $line 0]
  }
  return $modules
}