"Fossies" - the Fresh Open Source Software Archive

Member "ical-tcl/tcllib/dg_bug.tcl" (15 Apr 2019, 4299 Bytes) of package /linux/privat/ical-3.0.4.tar.gz:


As a special service "Fossies" has tried to format the requested source page into HTML format using (guessed) Tcl/Tk source code syntax highlighting (style: standard) with prefixed line numbers and code folding option. Alternatively you can here view or download the uninterpreted source code file. For more information about "dg_bug.tcl" see the Fossies "Dox" file reference documentation.

    1 # Copyright (c) 1993 by Sanjay Ghemawat
    2 #############################################################################
    3 # Bug Report dialog
    4 #
    5 # Commands
    6 #
    7 #       bug_notify <mailer> <email> <message>
    8 #               Handle software error
    9 
   10 # Hidden global variables
   11 #
   12 #       bug_done                Is bug interaction finished
   13 
   14 set bug(done) no
   15 
   16 proc bug_notify {mailer email message} {
   17     bug_make
   18     bug_interact $mailer $email $message
   19 }
   20 
   21 proc bug_make {} {
   22     global bug
   23 
   24     set f .bug_dialog
   25     if [winfo exists $f] {return}
   26 
   27     toplevel $f -class Dialog
   28     wm title $f {Internal Error}
   29     wm protocol $f WM_DELETE_WINDOW {set bug(done) cancel}
   30 
   31     frame $f.top -class Pane
   32     frame $f.mid -class Pane
   33 
   34     make_buttons $f.bot 2 {
   35         {{Dismiss}              {set bug(done) cancel}}
   36         {{Save}                 {set bug(done) save}}
   37         {{Mail Report}          {set bug(done) send}}
   38     }
   39 
   40     label $f.icon -bitmap error
   41     message $f.warn -aspect 400 -text {Uninitialized message}
   42 
   43     set bug(message) [bug_textwin $f.message Message]
   44     set bug(edit)    [bug_textwin $f.edit    {User Notes}]
   45 
   46     $bug(message).text configure -state disabled
   47     $bug(edit).text configure -state normal
   48 
   49     pack $f.icon -in $f.top -side left -padx 5m -pady 5m
   50     pack $f.warn -in $f.top -side right -padx 5m -pady 5m -expand 1 -fill both
   51 
   52     pack $f.edit -in $f.mid -side top -padx 5m -pady 5m -expand 1 -fill both
   53     pack $f.message -in $f.mid -side top -padx 5m -pady 5m -expand 1 -fill both
   54 
   55     pack $f.top -side top -fill both
   56     pack $f.mid -side top -expand 1 -fill both
   57     pack $f.bot -side top -fill both
   58 
   59     # XXX What bindings should we add here?
   60     # bind $f <Control-c><Control-c> {set bug(done) cancel}
   61 
   62     wm withdraw $f
   63     update
   64 }
   65 
   66 proc bug_textwin {w l} {
   67     frame $w -class Inset
   68     make_scrolled_text $w.contents
   69     pack $w.contents -side top -expand 1 -fill both
   70     label_widget $w.contents $l
   71     $w.contents.text configure -width 40 -height 6 -wrap none
   72     return $w.contents
   73 }
   74 
   75 proc bug_interact {mailer email message} {
   76     global bug
   77 
   78     set f .bug_dialog
   79 
   80     # Configure notice
   81     $f.warn configure -text [format [join {
   82         "An internal error has occurred.  You can send a bug report to"
   83         "the author (%s) by clicking on the \"Mail Report\" button"
   84         "at the bottom of this dialog.  The text displayed in the text"
   85         "areas below will be the only information sent to the author."
   86         "If you do not want to send a bug report, click on the"
   87         "\"Dismiss\" button.  If you want to send extra comments to"
   88         "the author, type them into the area below."
   89     }] $email]
   90 
   91     set mtext $bug(message).text
   92     $mtext configure -state normal
   93     $mtext delete 1.0 end
   94     $mtext insert 1.0 $message
   95     $mtext configure -state disabled
   96 
   97     set etext $bug(edit).text
   98     $etext delete 1.0 end
   99 
  100     set bug(done) no
  101     dialog_run {} $f bug(done) $etext
  102 
  103     if ![string compare $bug(done) {cancel}] return
  104 
  105     set text [bug_extract]
  106     switch -exact -- $bug(done) {
  107         save {
  108             bug_save $email $text
  109         }
  110         send {
  111             # Try different ways of sending mail
  112             if [catch {bug_mail1 $mailer $email $text}] {
  113                 catch {bug_mail2 $mailer $email $text}
  114             }
  115         }
  116     }
  117 }
  118 
  119 proc bug_extract {} {
  120     global bug
  121 
  122     set f .bug_dialog
  123     set text1 [$bug(edit).text get 1.0 end]
  124     set text2 [$bug(message).text get 1.0 end]
  125 
  126     return "$text1\n========\n$text2\n========"
  127 }
  128 
  129 proc bug_save {email text} {
  130     set msg {Select file to which message should be saved}
  131     if ![get_file_name {} {File} $msg file] return
  132 
  133     catch {
  134         set f [open $file w]
  135         catch {puts $f "To: $email"}
  136         catch {puts $f "Subject: Bug report"}
  137         catch {puts $f "--------"}
  138         catch {puts $f $text}
  139         close $f
  140     }
  141 }
  142                 
  143 proc bug_mail1 {mailer email text} {
  144     set f .bug_dialog
  145 
  146     set mailproc [open [list | $mailer -s {Bug report} $email] w]
  147     catch {puts $mailproc $text}
  148     close $mailproc
  149 }
  150 
  151 proc bug_mail2 {mailer email text} {
  152     set f .bug_dialog
  153 
  154     set mailproc [open [list | $mailer $email] w]
  155     catch {puts $mailproc {Subject: Bug report}}
  156     catch {puts $mailproc $text}
  157     close $mailproc
  158 }