Problems with STklos

From: Frank Ridderbusch <ridderbusch.pad_at_sni.de>
Date: Mon, 29 Aug 94 16:49:09 MET

Hello,

attached below is some code, which I wrote to learn Scheme and Tk at
the same time. Currently it is only a skeleton, Hopefully, when I
ready, I'm hoping to have a Issue Manager, which will help me to keep
track of my daily doings.

However I'm having some problems, which might come from the fact, that
I'm pretty unexperienced and that I'm didn't interpret the STklos
files correctly.

1. My menus don't do anything.
   I can create several menues in a menubar, which all look
   okay. However, when I select a menuentry the corresponding action
   is _not_ invoked.

   (menu-add m-file 'command :label "Print"
             :command '(print-issue-file) :underline 0)

   Is this the right way, to add a menuentry with a command.

2. When I invoke the add-button several times, stk abort with a
   segmentation fault under Linux.

   The sequence is add btn, cancel btn, add btn, cancel btn, add btn,
   segmentation fault.

   Am I doing something fundamentally wrong?

3. The grab command doesn't work for me.
   Currentlty I use tkwait in the routine add-issue, but somehow I
   can't find the right invokation of the grab, to grab the screen
   created in add-issue.

Any help would by greatly appretiated.

BTW, STklos is a great improvement over pure stk programming.

-- 
MfG/Regards
     /====                          Siemens Nixdorf Informationssysteme AG
    /    Ridderbusch        / ,    Abt.: SU MR PD 251
   /                       /./    Heinz Nixdorf Ring
  /=== /,== ,===/  /,==,  //     33106 Paderborn, Germany
 /    //   /   /  //   / / \    Tel.: (49) 05251-8-15211
/    /     `==/\ /    / /   \  NERV:ridderbusch.pad
Email: ridderbusch.pad_at_sni-usa.com (America (North & South))
       ridderbusch.pad_at_sni.de      (Rest of world)
       
============================== cut here =========================
;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -*- Mode: Scheme -*- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; issue.stklos -- 
;; 
;; 
;; Author          : Frank Ridderbusch
;; Created On      : Fri Aug 26 22:11:30 1994
;; Last Modified By: Frank Ridderbusch
;; Last Modified On: Sat Aug 27 19:50:29 1994
;; Update Count    : 34
;; Status          : Unknown, Use with caution!
;; 
;; $Locker$
;; $Log$
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Requirements
(require "Frame")
(require "Button")
(require "Menu")
(require "Scrollbox")
(require "Toplevel")
(require "Lentry")
;;; Global Variable Section
(define possible-stati '(("Open"     1 #t)
			 ("To Do"    2 #t)
			 ("Pending"  3 #t)
			 ("Caution"  4 #t)
			 ("Closed"   5 #f)))
(define issues #((("To Do"   "" "21.8.94" "PSM-Protokoll fertigmachen")
		  ("To Do"   "" "21.8.94" "Issue opened"))
                 (("To Do"   "" "20.8.94" "5.43 QSM Plan fertig stellen")
		  ("To Do"   "" "20.8.94" "Issue opened"))
		 (("Pending" "" "25.8.94" "Modem installieren")
		  ("Pending" "" "25.8.94" "C informiert")
		  ("To Do"   "" "24.8.94" "Issue opened"))))
(wm 'title "." "Issue Manager")
;;; The Menue Bar
;;
(define m (make <Frame> :width 500))
(pack m :side "top" :fill "x")
;----
(define mb-file  (make <Menu-Button> :text "File"    :underline 0 :parent m))
(define m-file   (make <Menu>))
(set! (menu-of mb-file) m-file)
(menu-add m-file 'command :label "New"
	  :command '(new-issue-file) :underline 0)
(menu-add m-file 'command :label "Open"  
	  :command '(open-issue-file) :underline 0)
(menu-add m-file 'command :label "Save"
	  :command '(save-issue-file) :underline 0)
(menu-add m-file 'command :label "Save As .."
	  :command '(save-issue-file-as) :underline 5)
(menu-add m-file 'separator)
(menu-add m-file 'command :label "Print"
	  :command '(print-issue-file) :underline 0)
(menu-add m-file 'separator)
(menu-add m-file 'command :label "Quit"
	  :command '(destroy *root*) :underline 0)
;----
(define mb-edit  (make <Menu-Button> :text "Edit"    :underline 0 :parent m))
(define m-edit   (make <Menu>))
(set! (menu-of mb-edit) m-edit)
(menu-add m-edit 'command :label "Add Issue"
	  :command '(add-issue) :underline 0)
(menu-add m-edit 'command :label "Edit Issue"
	  :command '(add-issue) :underline 0)
(menu-add m-edit 'command :label "Add History"
	  :command '(add-issue) :underline 5)
(menu-add m-edit 'separator)
(menu-add m-edit 'command :label "Delete Issue"
	  :command '(add-issue) :underline 0)
;----
(define mb-view  (make <Menu-Button> :text "View"    :underline 0 :parent m))
(define m-view   (make <Menu>))
(set! (menu-of mb-view) m-view)
;----
(define mb-opt   (make <Menu-Button> :text "Options" :underline 0 :parent m))
(define m-opt    (make <Menu>))
(set! (menu-of mb-opt) m-opt)
;----
(define mb-help  (make <Menu-Button> :text "Help"    :underline 0 :parent m))
(define m-help   (make <Menu>))
(set! (menu-of mb-help) m-help)
(pack mb-file mb-edit mb-view mb-opt :side "left" :fill "x")
(pack mb-help :side "right")
;;; The Toolbar
;;
(define toolbar       (make <Frame>))
(pack toolbar :side "top" :fill "x")
(define toolbar-open  (make <Button> :text "New"   :parent toolbar))
(define toolbar-new   (make <Button> :text "Open"  :parent toolbar))
(define toolbar-save  (make <Button> :text "Save"  :parent toolbar))
(pack toolbar-open toolbar-new toolbar-save 
      :side "left" :fill "x" :expand "t")
(define toolbar-print (make <Button> :text "Print" :parent toolbar))
(pack toolbar-print
      :side "left" :padx 5 :fill "x" :expand "t")
(define toolbar-add   (make <Button> :text "Add"  
			    :command '(add-issue)  :parent toolbar))
(define toolbar-edit  (make <Button> :text "Edit"  :parent toolbar))
(pack toolbar-add toolbar-edit
            :side "left" :fill "x" :expand "t")
;;; 
;;
(define issues-lbl (make <Label> :font "fixed" :anchor "w"
			 :text "Act. Cat. Date Description"))
(pack issues-lbl :fill "x" :side "top")
;;;
;;
(define issues-sbox (make <Scroll-listbox> :font "fixed" :setgrid "true"
			  :geometry "60x14" :scroll-side "right"))
(pack issues-sbox :fill "x")
(for-each (lambda (n)
	    (insert issues-sbox "end"
		    (string-append (caar n) " "
				   (cadar n) " "
				   (caddar n) " "
				   (car (cdddar n))))) 
	  (vector->list issues))
;;; Functions for the File menu
;;
(define new-issue-file
  (lambda ()
    (display "clicked new issue file")
    (newline)))
(define open-issue-file
  (lambda ()
    (display "clicked open issue file")
    (newline)))
(define save-issue-file
  (lambda ()
    (display "clicked save issue file")
    (newline)))
(define save-issue-file-as
  (lambda ()
    (display "clicked save issue file as")
    (newline)))
(define print-issue-file
  (lambda ()
    (display "clicked print issue file")
    (newline)))
;;; Functions for the Edit menu
;;
(define add-issue-lock #f)
(define add-issue
  (lambda ()
    (let* ((t (make <Toplevel>)) 
	   (t-lbl ())
	   (t-d-p ())
	   (t-d-p-date ())
	   (t-d-p-prio ())
	   (t-short ())
	   (t-sb ())
	   (t-sb-stat ())
	   (t-sb-cat ())
	   (t-btn ())
	   (t-btn-ok  ())
	   (t-btn-can ())
	   (t-btn-hlp ()))
      
      ; The Label above all
      (define t-lbl (make <Label> :text "Inital Issue Specification"
			  :borderwidth 10 :parent t))
      (pack t-lbl :fill "x" :expand "t" :side "top")
      ; The Date and the Prio fields
      (set! t-d-p (make <Frame> :parent t :borderwidth 5))
      (pack t-d-p :side "top" :fill "x")
      (set! t-d-p-date (make <Labeled-entry> 
			     :parent t-d-p :title "Date:" :width 10))
      (pack t-d-p-date :side "left")
;      (let ((date (get-decoded-time))
;	    (date-string #f))
;	(set! date-string (string-append
;			   (number->string (vector-ref date 3))
;			   "."
;			   (number->string (+ 1 (vector-ref date 4)))
;			   "."
;			   (number->string (vector-ref date 5))))
;	(text-insert t-d-p-date date-string 0))
      (set! t-d-p-prio (make <Labeled-entry>
			     :parent t-d-p :title "Prio (1-99):" :width 3))
      (pack t-d-p-prio :side "right")
      ; The Short description
      (define t-short (make <Labeled-entry> 
			  :parent t :title "Short Description:" :width 40))
      (pack t-short :side "top")
      ; Two Scrollboxes for Status and Category
      (set! t-sb (make <Frame> :parent t))
      (pack t-sb :side "top" :fill "x")
      (set! t-sb-stat (make <Scroll-listbox> 
			    :parent t-sb :scroll-side "right" 
			    :geometry "10x5" :setgrid 1 :borderwidth 5))
      (pack t-sb-stat :side "left" :expand "t")
      (map (lambda (n) 
	     (insert t-sb-stat "end" 
		     (car n))) possible-stati)
      (set! t-sb-cat (make <Scroll-listbox> 
			   :parent t-sb :scroll-side "right" 
			   :geometry "10x5" :setgrid 1 :borderwidth 5))
      (pack t-sb-cat :side "right" :expand "t")
      ; The Buttons at the bottom
      (define t-btn (make <Frame> :parent t))
      (pack t-btn :side "bottom" :fill "x")
      (define t-btn-ok  (make <Button> :text "OK"
			    :parent t-btn))
      (define t-btn-can (make <Button> :text "Cancel"
			    :command '(set! add-issue-lock 'can) 
			    :parent t-btn))
      (define t-btn-hlp (make <Button> :text "Help"
			    :parent t-btn))
      (pack t-btn-ok t-btn-can t-btn-hlp
	    :side "left" :fill "x" :expand "t")
      (wm 'title t "Add a new issue")
      (tkwait 'variable 'add-issue-lock)
      (catch (destroy t))
      )))
(define edit-issue
  (lambda ()
    (display "clicked edit issue")
    (newline)))
(define add-history-to-issue
  (lambda ()
    (display "clicked add history to issue")
    (newline)))
(define delete-issue
  (lambda ()
    (display "clicked delete issue")
    (newline)))
; Local Variables:
; eval: (require 'cmuscheme)
; eval: (setq scheme-program-name "/usr/local/bin/stk")
; eval: (dmacro-load "~/.elisp/scheme.dm")
; eval: (require 'header)
; End:

Received on Mon Aug 29 1994 - 17:27:22 CEST