2 * ----------------------------------------------------------------------
12 let re = Str.regexp "\\([0-9]*\\(.[0-9]+\\)?\\)[ \t\n]*\\(px\\|cm\\|in\\|mm\\|pt\\)" in
13 if Str.string_match re s 0 then begin
14 let number = Str.matched_group 1 s in
15 let dim = Str.matched_group 3 s in
17 "px" -> Tk.Pixels (int_of_float (float_of_string number))
18 | "cm" -> Tk.Centimeters (float_of_string number)
19 | "in" -> Tk.Inches (float_of_string number)
20 | "mm" -> Tk.Millimeters (float_of_string number)
21 | "pt" -> Tk.PrinterPoint (float_of_string number)
25 failwith ("Bad dimension: " ^ s)
29 class virtual shared =
32 (* --- default_ext --- *)
34 val mutable node = (None : shared node option)
45 (* --- shared attributes: color & font settings --- *)
47 val mutable fgcolor = (None : string option)
48 val mutable bgcolor = (None : string option)
49 val mutable font = (None : string option)
52 (* Get the foreground color: If there is a local value, return it;
53 * otherwise ask parent node
57 | None -> try self # node # parent # extension # fgcolor with
58 Not_found -> failwith "#fgcolor"
61 (* Get the background color: If there is a local value, return it;
62 * otherwise ask parent node
66 | None -> try self # node # parent # extension # bgcolor with
67 Not_found -> failwith "#bgcolor"
70 (* Get the current font: If there is a local value, return it;
71 * otherwise ask parent node
75 | None -> try self # node # parent # extension # font with
76 Not_found -> failwith "#font"
78 method private init_color_and_font =
81 match self # node # attribute n with
83 | Implied_value -> None
85 with Not_found -> None in
86 fgcolor <- get_color "fgcolor";
87 bgcolor <- get_color "bgcolor";
88 font <- get_color "font"; (* sic! *)
91 method private bg_color_opt =
92 [ Tk.Background (Tk.NamedColor (self # bgcolor)) ]
94 method private fg_color_opt =
95 [ Tk.Foreground (Tk.NamedColor (self # fgcolor)) ]
97 method private font_opt =
98 [ Tk.Font (self # font) ]
100 (* --- virtual --- *)
102 method virtual prepare : shared Pxp_yacc.index -> unit
103 method virtual create_widget : Widget.widget -> context -> Widget.widget
105 method pack_opts = ( [] : Tk.options list )
106 method xstretchable = false
107 method ystretchable = false
109 method accept (c:context) = ()
111 method private get_mask =
112 (* find parent which is a mask *)
114 match n # node_type with
125 method private accept_mask (c:context) =
127 n # extension # accept c;
128 List.iter iterate (n # sub_nodes)
130 iterate (self # get_mask # node)
133 method start_node_name =
134 (failwith "#start_node_name" : string)
138 method private name =
139 let nt = self # node # node_type in
142 | T_data -> "#PCDATA"
154 self # init_color_and_font
156 method create_widget w c =
157 failwith "default # create_widget"
162 let dummy_node = new element_impl (new default);;
168 val mutable start_node = dummy_node
171 (* prepare this node *)
172 self # init_color_and_font;
173 if fgcolor = None then fgcolor <- Some "black";
174 if bgcolor = None then bgcolor <- Some "white";
175 if font = None then font <- Some "fixed";
177 match self # node # attribute "start" with
179 | _ -> assert false in
180 start_node <- (try idx # find start with
181 Not_found -> failwith "Start node not found");
182 (* iterate over the subtree *)
184 n # extension # prepare idx;
185 List.iter iterate (n # sub_nodes)
187 List.iter iterate (self # node # sub_nodes)
190 method start_node_name =
191 match self # node # attribute "start" with
195 method create_widget w c =
196 start_node # extension # create_widget w c
199 start_node # extension # pack_opts
209 self # init_color_and_font;
211 method create_widget w c =
212 let node = List.hd (self # node # sub_nodes) in
213 node # extension # create_widget w c
216 let node = List.hd (self # node # sub_nodes) in
217 node # extension # pack_opts
226 val mutable att_halign = "left"
229 self # init_color_and_font;
230 match self # node # attribute "halign" with
231 Value v -> att_halign <- v
234 method create_widget w c =
235 let f = Frame.create w (self # bg_color_opt) in
236 let nodes = self # node # sub_nodes in
238 match att_halign with
239 "left" -> [ Tk.Anchor Tk.W ]
240 | "right" -> [ Tk.Anchor Tk.E ]
241 | "center" -> [ Tk.Anchor Tk.Center ]
246 let opts = n # extension # pack_opts in
247 let wdg = n # extension # create_widget f c in
248 Tk.pack [wdg] (options @ opts);
254 match self # xstretchable, self # ystretchable with
255 true, false -> [ Tk.Fill Tk.Fill_X; (* Tk.Expand true *) ]
256 | false, true -> [ Tk.Fill Tk.Fill_Y; (* Tk.Expand true *) ]
257 | true, true -> [ Tk.Fill Tk.Fill_Both; (* Tk.Expand true *) ]
260 method xstretchable =
261 let nodes = self # node # sub_nodes in
262 List.exists (fun n -> n # extension # xstretchable) nodes
264 method ystretchable =
265 let nodes = self # node # sub_nodes in
266 List.exists (fun n -> n # extension # ystretchable) nodes
279 self # init_color_and_font;
289 val mutable att_width = None
290 val mutable att_halign = "left"
291 val mutable att_valign = "top"
294 self # init_color_and_font;
295 begin match self # node # attribute "halign" with
296 Value v -> att_halign <- v
299 begin match self # node # attribute "valign" with
300 Value v -> att_valign <- v
303 begin match self # node # attribute "width" with
304 Value v -> att_width <- Some (get_dimension v)
305 | Implied_value -> att_width <- None
309 method create_widget w c =
310 let f1 = Frame.create w (self # bg_color_opt) in
316 ( [ Tk.Width wd; Tk.Height (Tk.Pixels 0);
318 Tk.HighlightThickness (Tk.Pixels 0);
320 self # bg_color_opt ) ]
322 let f2 = Frame.create f1 (self # bg_color_opt) in
323 let nodes = self # node # sub_nodes in
325 let outer_pack_opts =
326 match att_halign with
327 "left" -> [ Tk.Anchor Tk.W ]
328 | "right" -> [ Tk.Anchor Tk.E ]
329 | "center" -> [ Tk.Anchor Tk.Center ]
332 let inner_pack_opts =
333 match att_valign with
334 "top" -> [ Tk.Anchor Tk.N ]
335 | "bottom" -> [ Tk.Anchor Tk.S ]
336 | "center" -> [ Tk.Anchor Tk.Center ]
341 let opts = n # extension # pack_opts in
342 let wdg = n # extension # create_widget f2 c in
343 Tk.pack [wdg] (inner_pack_opts @ [ Tk.Side Tk.Side_Left ] @ opts);
346 let extra_opts = self # pack_opts in
347 Tk.pack (f_extra @ [f2]) (outer_pack_opts @ extra_opts);
351 match self # xstretchable, self # ystretchable with
352 true, false -> [ Tk.Fill Tk.Fill_X; (* Tk.Expand true *) ]
353 | false, true -> [ Tk.Fill Tk.Fill_Y; (* Tk.Expand true *) ]
354 | true, true -> [ Tk.Fill Tk.Fill_Both; (* Tk.Expand true *) ]
357 method xstretchable =
358 let nodes = self # node # sub_nodes in
359 List.exists (fun n -> n # extension # xstretchable) nodes
361 method ystretchable =
362 let nodes = self # node # sub_nodes in
363 List.exists (fun n -> n # extension # ystretchable) nodes
372 val mutable att_height = Tk.Pixels 0
373 val mutable att_fill = false
376 self # init_color_and_font;
377 begin match self # node # attribute "height" with
378 Value v -> att_height <- get_dimension v
381 begin match self # node # attribute "fill" with
382 Value "yes" -> att_fill <- true
383 | Value "no" -> att_fill <- false
388 method create_widget w c =
389 let f = Frame.create w ( self # bg_color_opt ) in
392 ( [ Tk.Height att_height; Tk.Width (Tk.Pixels 0);
394 Tk.HighlightThickness (Tk.Pixels 0);
396 self # bg_color_opt ) in
398 Tk.pack [strut] [Tk.Fill Tk.Fill_Y; Tk.Expand true]
404 if att_fill then [ Tk.Fill Tk.Fill_Y; Tk.Expand true ] else []
406 method ystretchable = att_fill
415 val mutable att_width = Tk.Pixels 0
416 val mutable att_fill = false
419 self # init_color_and_font;
420 begin match self # node # attribute "width" with
421 Value v -> att_width <- get_dimension v
424 begin match self # node # attribute "fill" with
425 Value "yes" -> att_fill <- true
426 | Value "no" -> att_fill <- false
431 method create_widget w c =
432 let f = Frame.create w ( self # bg_color_opt ) in
435 ( [ Tk.Width att_width; Tk.Height (Tk.Pixels 0);
437 Tk.HighlightThickness (Tk.Pixels 0);
439 self # bg_color_opt ) in
441 Tk.pack [strut] [Tk.Fill Tk.Fill_X; Tk.Expand true]
447 if att_fill then [ Tk.Fill Tk.Fill_X; Tk.Expand true ] else []
449 method xstretchable = att_fill
457 val mutable att_textwidth = (-1)
458 val mutable att_halign = "left"
461 self # init_color_and_font;
462 att_textwidth <- (match self # node # attribute "textwidth" with
464 let w = try int_of_string v
465 with _ -> failwith ("Not an integer: " ^ v) in
469 | _ -> assert false);
470 att_halign <- (match self # node # attribute "halign" with
472 | _ -> assert false);
475 method create_widget w c =
476 let opts_textwidth = if att_textwidth < 0 then [] else
477 [ Tk.TextWidth att_textwidth ] in
479 match att_halign with
480 "left" -> [ Tk.Anchor Tk.W ]
481 | "right" -> [ Tk.Anchor Tk.E ]
482 | "center" -> [ Tk.Anchor Tk.Center ]
486 [ Tk.Text (self # node # data) ] in
487 let label = Label.create w (opts_textwidth @ opts_halign @
488 opts_content @ self # bg_color_opt @
489 self # fg_color_opt @ self # font_opt) in
499 val mutable tv = lazy (Textvariable.create())
500 val mutable att_textwidth = (-1)
501 val mutable att_slot = ""
504 self # init_color_and_font;
505 tv <- lazy (Textvariable.create());
506 att_textwidth <- (match self # node # attribute "textwidth" with
508 let w = try int_of_string v
509 with _ -> failwith ("Not an integer: " ^ v) in
513 | _ -> assert false);
514 att_slot <- (match self # node # attribute "slot" with
516 | _ -> assert false);
518 method create_widget w c =
519 let opts_textwidth = if att_textwidth < 0 then [] else
520 [ Tk.TextWidth att_textwidth ] in
521 let e = Entry.create w ( [ Tk.TextVariable (Lazy.force tv) ] @
522 self # fg_color_opt @
523 self # bg_color_opt @
528 try c # get_slot att_slot with
529 Not_found -> self # node # data in
530 Textvariable.set (Lazy.force tv) s;
534 c # set_slot att_slot (Textvariable.get (Lazy.force tv))
543 val mutable att_textwidth = (-1)
544 val mutable att_textheight = (-1)
545 val mutable att_slot = ""
546 val mutable last_widget = None
549 self # init_color_and_font;
550 att_textwidth <- (match self # node # attribute "textwidth" with
552 let w = try int_of_string v
553 with _ -> failwith ("Not an integer: " ^ v) in
557 | _ -> assert false);
558 att_textheight <- (match self # node # attribute "textheight" with
560 let w = try int_of_string v
561 with _ -> failwith ("Not an integer: " ^ v) in
565 | _ -> assert false);
566 att_slot <- (match self # node # attribute "slot" with
568 | Implied_value -> ""
569 | _ -> assert false);
572 method create_widget w c =
573 let opts_textwidth = if att_textwidth < 0 then [] else
574 [ Tk.TextWidth att_textwidth ] in
575 let opts_textheight = if att_textheight < 0 then [] else
576 [ Tk.TextHeight att_textheight ] in
577 let f = Frame.create w (self # bg_color_opt) in
578 let vscrbar = Scrollbar.create f [ Tk.Orient Tk.Vertical ] in
579 let e = Text.create f ( [ ] @
580 self # fg_color_opt @
581 self # bg_color_opt @
583 opts_textwidth @ opts_textheight
585 last_widget <- Some e;
586 Scrollbar.configure vscrbar [ Tk.ScrollCommand
587 (fun s -> Text.yview e s);
588 Tk.Width (Tk.Pixels 9) ];
589 Text.configure e [ Tk.YScrollCommand
590 (fun a b -> Scrollbar.set vscrbar a b) ];
592 if att_slot <> "" then
593 try c # get_slot att_slot with
594 Not_found -> self # node # data
598 (* Text.insert appends always a newline to the last line; so strip
599 * an existing newline first
602 if s <> "" & s.[String.length s - 1] = '\n' then
603 String.sub s 0 (String.length s - 1)
606 Text.insert e (Tk.TextIndex(Tk.End,[])) s' [];
607 if att_slot = "" then
608 Text.configure e [ Tk.State Tk.Disabled ];
609 Tk.pack [e] [ Tk.Side Tk.Side_Left ];
610 Tk.pack [vscrbar] [ Tk.Side Tk.Side_Left; Tk.Fill Tk.Fill_Y ];
614 if att_slot <> "" then
615 match last_widget with
621 (Tk.TextIndex(Tk.LineChar(1,0),[]))
622 (Tk.TextIndex(Tk.End,[])) in
623 c # set_slot att_slot s
632 val mutable att_label = ""
633 val mutable att_action = ""
634 val mutable att_goto = ""
637 self # init_color_and_font;
638 att_label <- (match self # node # attribute "label" with
640 | _ -> assert false);
641 att_action <- (match self # node # attribute "action" with
643 | _ -> assert false);
644 att_goto <- (match self # node # attribute "goto" with
646 | Implied_value -> ""
647 | _ -> assert false);
648 if att_action = "goto" then begin
649 try let _ = idx # find att_goto in () with
650 Not_found -> failwith ("Target `" ^ att_goto ^ "' not found")
652 if att_action = "list-prev" or att_action = "list-next" then begin
653 let m = self # get_mask in
654 if m # node # parent # node_type <> T_element "sequence" then
655 failwith ("action " ^ att_action ^ " must not be used out of <sequence>");
659 method create_widget w c =
661 self # accept_mask c;
662 match att_action with
673 let m = self # get_mask # node in
674 let s = m # parent in
679 match x # attribute "name" with
680 Value s -> c # goto s
686 search (s # sub_nodes)
688 let m = self # get_mask # node in
689 let s = m # parent in
694 match y # attribute "name" with
695 Value s -> c # goto s
701 search (s # sub_nodes)
703 (try c # previous with Not_found -> ())
705 (try c # next with Not_found -> ())
708 let b = Button.create w ( [ Tk.Text att_label; Tk.Command cmd ] @
709 self # fg_color_opt @
710 self # bg_color_opt @
719 (**********************************************************************)
724 make_spec_from_mapping
725 ~data_exemplar:(new data_impl (new default))
726 ~default_element_exemplar:(new element_impl (new default))
728 (let m = Hashtbl.create 50 in
729 Hashtbl.add m "application"
730 (new element_impl (new application));
731 Hashtbl.add m "sequence"
732 (new element_impl (new sequence));
734 (new element_impl (new mask));
736 (new element_impl (new vbox));
738 (new element_impl (new hbox));
739 Hashtbl.add m "vspace"
740 (new element_impl (new vspace));
741 Hashtbl.add m "hspace"
742 (new element_impl (new hspace));
743 Hashtbl.add m "label"
744 (new element_impl (new label));
745 Hashtbl.add m "entry"
746 (new element_impl (new entry));
747 Hashtbl.add m "textbox"
748 (new element_impl (new textbox));
749 Hashtbl.add m "button"
750 (new element_impl (new button));
755 (* ======================================================================
759 * Revision 1.1 2000/11/17 09:57:31 lpadovan
762 * Revision 1.5 2000/08/30 15:58:49 gerd
765 * Revision 1.4 2000/07/16 19:36:03 gerd
768 * Revision 1.3 2000/07/08 22:03:11 gerd
769 * Updates because of PXP interface changes.
771 * Revision 1.2 2000/06/04 20:29:19 gerd
772 * Updates because of renamed PXP modules.
774 * Revision 1.1 1999/08/21 19:11:05 gerd