Hoare again
[llpp.git] / main.ml
blob89b437ab2dd2ad307f51da88e1c72a54e15effe9
1 exception Quit;;
3 type under =
4 | Unone
5 | Ulinkuri of string
6 | Ulinkgoto of (int * int)
7 | Utext of facename
8 | Uunexpected of string
9 | Ulaunch of string
10 | Unamed of string
11 | Uremote of (string * int)
12 and facename = string;;
14 let dolog fmt = Printf.kprintf prerr_endline fmt;;
15 let now = Unix.gettimeofday;;
17 type params = (angle * proportional * trimparams
18 * texcount * sliceheight * memsize
19 * colorspace * fontpath)
20 and pageno = int
21 and width = int
22 and height = int
23 and leftx = int
24 and opaque = string
25 and recttype = int
26 and pixmapsize = int
27 and angle = int
28 and proportional = bool
29 and trimmargins = bool
30 and interpagespace = int
31 and texcount = int
32 and sliceheight = int
33 and gen = int
34 and top = float
35 and fontpath = string
36 and memsize = int
37 and aalevel = int
38 and irect = (int * int * int * int)
39 and trimparams = (trimmargins * irect)
40 and colorspace = | Rgb | Bgr | Gray
43 type link =
44 | Lnotfound
45 | Lfound of int
46 and linkdir =
47 | LDfirst
48 | LDlast
49 | LDfirstvisible of (int * int * int)
50 | LDleft of int
51 | LDright of int
52 | LDdown of int
53 | LDup of int
56 type pagewithlinks =
57 | Pwlnotfound
58 | Pwl of int
61 type keymap =
62 | KMinsrt of key
63 | KMinsrl of key list
64 | KMmulti of key list * key list
65 and key = int * int
66 and keyhash = (key, keymap) Hashtbl.t
67 and keystate =
68 | KSnone
69 | KSinto of (key list * key list)
72 type platform = | Punknown | Plinux | Posx | Psun | Pfreebsd
73 | Pdragonflybsd | Popenbsd | Pnetbsd | Pcygwin;;
75 type pipe = (Unix.file_descr * Unix.file_descr);;
77 external init : pipe -> params -> unit = "ml_init";;
78 external seltext : string -> (int * int * int * int) -> unit = "ml_seltext";;
79 external copysel : string -> opaque -> unit = "ml_copysel";;
80 external getpdimrect : int -> float array = "ml_getpdimrect";;
81 external whatsunder : string -> int -> int -> under = "ml_whatsunder";;
82 external zoomforh : int -> int -> int -> float = "ml_zoom_for_height";;
83 external drawstr : int -> int -> int -> string -> float = "ml_draw_string";;
84 external measurestr : int -> string -> float = "ml_measure_string";;
85 external getmaxw : unit -> float = "ml_getmaxw";;
86 external postprocess : opaque -> bool -> int -> int -> unit = "ml_postprocess";;
87 external pagebbox : opaque -> (int * int * int * int) = "ml_getpagebox";;
88 external platform : unit -> platform = "ml_platform";;
89 external setaalevel : int -> unit = "ml_setaalevel";;
90 external realloctexts : int -> bool = "ml_realloctexts";;
91 external cloexec : Unix.file_descr -> unit = "ml_cloexec";;
92 external findlink : opaque -> linkdir -> link = "ml_findlink";;
93 external getlink : opaque -> int -> under = "ml_getlink";;
94 external getlinkrect : opaque -> int -> irect = "ml_getlinkrect";;
95 external findpwl: int -> int -> pagewithlinks = "ml_find_page_with_links"
97 let platform_to_string = function
98 | Punknown -> "unknown"
99 | Plinux -> "Linux"
100 | Posx -> "OSX"
101 | Psun -> "Sun"
102 | Pfreebsd -> "FreeBSD"
103 | Pdragonflybsd -> "DragonflyBSD"
104 | Popenbsd -> "OpenBSD"
105 | Pnetbsd -> "NetBSD"
106 | Pcygwin -> "Cygwin"
109 let platform = platform ();;
111 type x = int
112 and y = int
113 and tilex = int
114 and tiley = int
115 and tileparams = (x * y * width * height * tilex * tiley)
118 external drawtile : tileparams -> opaque -> unit = "ml_drawtile";;
120 type mpos = int * int
121 and mstate =
122 | Msel of (mpos * mpos)
123 | Mpan of mpos
124 | Mscrolly | Mscrollx
125 | Mzoom of (int * int)
126 | Mzoomrect of (mpos * mpos)
127 | Mnone
130 type textentry = string * string * onhist option * onkey * ondone
131 and onkey = string -> int -> te
132 and ondone = string -> unit
133 and histcancel = unit -> unit
134 and onhist = ((histcmd -> string) * histcancel)
135 and histcmd = HCnext | HCprev | HCfirst | HClast
136 and te =
137 | TEstop
138 | TEdone of string
139 | TEcont of string
140 | TEswitch of textentry
143 type 'a circbuf =
144 { store : 'a array
145 ; mutable rc : int
146 ; mutable wc : int
147 ; mutable len : int
151 let bound v minv maxv =
152 max minv (min maxv v);
155 let cbnew n v =
156 { store = Array.create n v
157 ; rc = 0
158 ; wc = 0
159 ; len = 0
163 let drawstring size x y s =
164 Gl.enable `blend;
165 Gl.enable `texture_2d;
166 GlFunc.blend_func `src_alpha `one_minus_src_alpha;
167 ignore (drawstr size x y s);
168 Gl.disable `blend;
169 Gl.disable `texture_2d;
172 let drawstring1 size x y s =
173 drawstr size x y s;
176 let drawstring2 size x y fmt =
177 Printf.kprintf (drawstring size (x+1) (y+size+1)) fmt
180 let cbcap b = Array.length b.store;;
182 let cbput b v =
183 let cap = cbcap b in
184 b.store.(b.wc) <- v;
185 b.wc <- (b.wc + 1) mod cap;
186 b.rc <- b.wc;
187 b.len <- min (b.len + 1) cap;
190 let cbempty b = b.len = 0;;
192 let cbgetg b circular dir =
193 if cbempty b
194 then b.store.(0)
195 else
196 let rc = b.rc + dir in
197 let rc =
198 if circular
199 then (
200 if rc = -1
201 then b.len-1
202 else (
203 if rc = b.len
204 then 0
205 else rc
208 else max 0 (min rc (b.len-1))
210 b.rc <- rc;
211 b.store.(rc);
214 let cbget b = cbgetg b false;;
215 let cbgetc b = cbgetg b true;;
217 type page =
218 { pageno : int
219 ; pagedimno : int
220 ; pagew : int
221 ; pageh : int
222 ; pagex : int
223 ; pagey : int
224 ; pagevw : int
225 ; pagevh : int
226 ; pagedispx : int
227 ; pagedispy : int
231 let debugl l =
232 dolog "l %d dim=%d {" l.pageno l.pagedimno;
233 dolog " WxH %dx%d" l.pagew l.pageh;
234 dolog " vWxH %dx%d" l.pagevw l.pagevh;
235 dolog " pagex,y %d,%d" l.pagex l.pagey;
236 dolog " dispx,y %d,%d" l.pagedispx l.pagedispy;
237 dolog "}";
240 let debugrect (x0, y0, x1, y1, x2, y2, x3, y3) =
241 dolog "rect {";
242 dolog " x0,y0=(% f, % f)" x0 y0;
243 dolog " x1,y1=(% f, % f)" x1 y1;
244 dolog " x2,y2=(% f, % f)" x2 y2;
245 dolog " x3,y3=(% f, % f)" x3 y3;
246 dolog "}";
249 type columns =
250 multicol * ((pdimno * x * y * (pageno * width * height * leftx)) array)
251 and multicol = columncount * covercount * covercount
252 and pdimno = int
253 and columncount = int
254 and covercount = int;;
256 type conf =
257 { mutable scrollbw : int
258 ; mutable scrollh : int
259 ; mutable icase : bool
260 ; mutable preload : bool
261 ; mutable pagebias : int
262 ; mutable verbose : bool
263 ; mutable debug : bool
264 ; mutable scrollstep : int
265 ; mutable maxhfit : bool
266 ; mutable crophack : bool
267 ; mutable autoscrollstep : int
268 ; mutable maxwait : float option
269 ; mutable hlinks : bool
270 ; mutable underinfo : bool
271 ; mutable interpagespace : interpagespace
272 ; mutable zoom : float
273 ; mutable presentation : bool
274 ; mutable angle : angle
275 ; mutable winw : int
276 ; mutable winh : int
277 ; mutable savebmarks : bool
278 ; mutable proportional : proportional
279 ; mutable trimmargins : trimmargins
280 ; mutable trimfuzz : irect
281 ; mutable memlimit : memsize
282 ; mutable texcount : texcount
283 ; mutable sliceheight : sliceheight
284 ; mutable thumbw : width
285 ; mutable jumpback : bool
286 ; mutable bgcolor : float * float * float
287 ; mutable bedefault : bool
288 ; mutable scrollbarinpm : bool
289 ; mutable tilew : int
290 ; mutable tileh : int
291 ; mutable mustoresize : memsize
292 ; mutable checkers : bool
293 ; mutable aalevel : int
294 ; mutable urilauncher : string
295 ; mutable pathlauncher : string
296 ; mutable colorspace : colorspace
297 ; mutable invert : bool
298 ; mutable colorscale : float
299 ; mutable redirectstderr : bool
300 ; mutable ghyllscroll : (int * int * int) option
301 ; mutable columns : columns option
302 ; mutable beyecolumns : columncount option
303 ; mutable selcmd : string
304 ; mutable updatecurs : bool
305 ; mutable keyhashes : (string * keyhash) list
309 type anchor = pageno * top;;
311 type outline = string * int * anchor;;
313 type rect = float * float * float * float * float * float * float * float;;
315 type tile = opaque * pixmapsize * elapsed
316 and elapsed = float;;
317 type pagemapkey = pageno * gen;;
318 type tilemapkey = pageno * gen * colorspace * angle * width * height * col * row
319 and row = int
320 and col = int;;
322 let emptyanchor = (0, 0.0);;
324 type infochange = | Memused | Docinfo | Pdim;;
326 class type uioh = object
327 method display : unit
328 method key : int -> int -> uioh
329 method button : int -> bool -> int -> int -> int -> uioh
330 method motion : int -> int -> uioh
331 method pmotion : int -> int -> uioh
332 method infochanged : infochange -> unit
333 method scrollpw : (int * float * float)
334 method scrollph : (int * float * float)
335 method modehash : keyhash
336 end;;
338 type mode =
339 | Birdseye of (conf * leftx * pageno * pageno * anchor)
340 | Textentry of (textentry * onleave)
341 | View
342 | LinkNav of linktarget
343 and onleave = leavetextentrystatus -> unit
344 and leavetextentrystatus = | Cancel | Confirm
345 and helpitem = string * int * action
346 and action =
347 | Noaction
348 | Action of (uioh -> uioh)
349 and linktarget =
350 | Ltexact of (pageno * int)
351 | Ltgendir of int
354 let isbirdseye = function Birdseye _ -> true | _ -> false;;
355 let istextentry = function Textentry _ -> true | _ -> false;;
357 type currently =
358 | Idle
359 | Loading of (page * gen)
360 | Tiling of (
361 page * opaque * colorspace * angle * gen * col * row * width * height
363 | Outlining of outline list
366 let emptykeyhash = Hashtbl.create 0;;
367 let nouioh : uioh = object (self)
368 method display = ()
369 method key _ _ = self
370 method button _ _ _ _ _ = self
371 method motion _ _ = self
372 method pmotion _ _ = self
373 method infochanged _ = ()
374 method scrollpw = (0, nan, nan)
375 method scrollph = (0, nan, nan)
376 method modehash = emptykeyhash
377 end;;
379 type state =
380 { mutable sr : Unix.file_descr
381 ; mutable sw : Unix.file_descr
382 ; mutable wsfd : Unix.file_descr
383 ; mutable errfd : Unix.file_descr option
384 ; mutable stderr : Unix.file_descr
385 ; mutable errmsgs : Buffer.t
386 ; mutable newerrmsgs : bool
387 ; mutable w : int
388 ; mutable x : int
389 ; mutable y : int
390 ; mutable scrollw : int
391 ; mutable hscrollh : int
392 ; mutable anchor : anchor
393 ; mutable ranchors : (string * string * anchor) list
394 ; mutable maxy : int
395 ; mutable layout : page list
396 ; pagemap : (pagemapkey, opaque) Hashtbl.t
397 ; tilemap : (tilemapkey, tile) Hashtbl.t
398 ; tilelru : (tilemapkey * opaque * pixmapsize) Queue.t
399 ; mutable pdims : (pageno * width * height * leftx) list
400 ; mutable pagecount : int
401 ; mutable currently : currently
402 ; mutable mstate : mstate
403 ; mutable searchpattern : string
404 ; mutable rects : (pageno * recttype * rect) list
405 ; mutable rects1 : (pageno * recttype * rect) list
406 ; mutable text : string
407 ; mutable fullscreen : (width * height) option
408 ; mutable mode : mode
409 ; mutable uioh : uioh
410 ; mutable outlines : outline array
411 ; mutable bookmarks : outline list
412 ; mutable path : string
413 ; mutable password : string
414 ; mutable geomcmds : (string * ((string * (unit -> unit)) list))
415 ; mutable memused : memsize
416 ; mutable gen : gen
417 ; mutable throttle : (page list * int * float) option
418 ; mutable autoscroll : int option
419 ; mutable ghyll : (int option -> unit)
420 ; mutable help : helpitem array
421 ; mutable docinfo : (int * string) list
422 ; mutable texid : GlTex.texture_id option
423 ; hists : hists
424 ; mutable prevzoom : float
425 ; mutable progress : float
426 ; mutable redisplay : bool
427 ; mutable mpos : mpos
428 ; mutable keystate : keystate
430 and hists =
431 { pat : string circbuf
432 ; pag : string circbuf
433 ; nav : anchor circbuf
434 ; sel : string circbuf
438 let defconf =
439 { scrollbw = 7
440 ; scrollh = 12
441 ; icase = true
442 ; preload = true
443 ; pagebias = 0
444 ; verbose = false
445 ; debug = false
446 ; scrollstep = 24
447 ; maxhfit = true
448 ; crophack = false
449 ; autoscrollstep = 2
450 ; maxwait = None
451 ; hlinks = false
452 ; underinfo = false
453 ; interpagespace = 2
454 ; zoom = 1.0
455 ; presentation = false
456 ; angle = 0
457 ; winw = 900
458 ; winh = 900
459 ; savebmarks = true
460 ; proportional = true
461 ; trimmargins = false
462 ; trimfuzz = (0,0,0,0)
463 ; memlimit = 32 lsl 20
464 ; texcount = 256
465 ; sliceheight = 24
466 ; thumbw = 76
467 ; jumpback = true
468 ; bgcolor = (0.5, 0.5, 0.5)
469 ; bedefault = false
470 ; scrollbarinpm = true
471 ; tilew = 2048
472 ; tileh = 2048
473 ; mustoresize = 128 lsl 20
474 ; checkers = true
475 ; aalevel = 8
476 ; urilauncher =
477 (match platform with
478 | Plinux | Pfreebsd | Pdragonflybsd
479 | Popenbsd | Pnetbsd | Psun -> "xdg-open \"%s\""
480 | Posx -> "open \"%s\""
481 | Pcygwin -> "cygstart %s"
482 | Punknown -> "echo %s")
483 ; pathlauncher = "lp \"%s\""
484 ; selcmd =
485 (match platform with
486 | Plinux | Pfreebsd | Pdragonflybsd
487 | Popenbsd | Pnetbsd | Psun -> "xsel -i"
488 | Posx -> "pbcopy"
489 | Pcygwin -> "wsel"
490 | Punknown -> "cat")
491 ; colorspace = Rgb
492 ; invert = false
493 ; colorscale = 1.0
494 ; redirectstderr = false
495 ; ghyllscroll = None
496 ; columns = None
497 ; beyecolumns = None
498 ; updatecurs = false
499 ; keyhashes =
500 let mk n = (n, Hashtbl.create 1) in
501 [ mk "global"
502 ; mk "info"
503 ; mk "help"
504 ; mk "outline"
505 ; mk "listview"
506 ; mk "birdseye"
507 ; mk "textentry"
508 ; mk "links"
513 let findkeyhash c name =
514 try List.assoc name c.keyhashes
515 with Not_found -> failwith ("invalid mode name `" ^ name ^ "'")
518 let conf = { defconf with angle = defconf.angle };;
520 type fontstate =
521 { mutable fontsize : int
522 ; mutable wwidth : float
523 ; mutable maxrows : int
527 let fstate =
528 { fontsize = 14
529 ; wwidth = nan
530 ; maxrows = -1
534 let setfontsize n =
535 fstate.fontsize <- n;
536 fstate.wwidth <- measurestr fstate.fontsize "w";
537 fstate.maxrows <- (conf.winh - fstate.fontsize - 1) / (fstate.fontsize + 1);
540 let geturl s =
541 let colonpos = try String.index s ':' with Not_found -> -1 in
542 let len = String.length s in
543 if colonpos >= 0 && colonpos + 3 < len
544 then (
545 if s.[colonpos+1] = '/' && s.[colonpos+2] = '/'
546 then
547 let schemestartpos =
548 try String.rindex_from s colonpos ' '
549 with Not_found -> -1
551 let scheme =
552 String.sub s (schemestartpos+1) (colonpos-1-schemestartpos)
554 match scheme with
555 | "http" | "ftp" | "mailto" ->
556 let epos =
557 try String.index_from s colonpos ' '
558 with Not_found -> len
560 String.sub s (schemestartpos+1) (epos-1-schemestartpos)
561 | _ -> ""
562 else ""
564 else ""
567 let popen =
568 let shell, farg = "/bin/sh", "-c" in
569 fun s ->
570 let args = [|shell; farg; s|] in
571 ignore (Unix.create_process shell args Unix.stdin Unix.stdout Unix.stderr)
574 let gotouri uri =
575 if String.length conf.urilauncher = 0
576 then print_endline uri
577 else (
578 let url = geturl uri in
579 if String.length url = 0
580 then print_endline uri
581 else
582 let re = Str.regexp "%s" in
583 let command = Str.global_replace re url conf.urilauncher in
584 try popen command
585 with exn ->
586 Printf.eprintf
587 "failed to execute `%s': %s\n" command (Printexc.to_string exn);
588 flush stderr;
592 let version () =
593 Printf.sprintf "llpp version %s (%s/%dbit, ocaml %s)" Help.version
594 (platform_to_string platform) Sys.word_size Sys.ocaml_version
597 let makehelp () =
598 let strings = version () :: "" :: Help.keys in
599 Array.of_list (
600 List.map (fun s ->
601 let url = geturl s in
602 if String.length url > 0
603 then (s, 0, Action (fun u -> gotouri url; u))
604 else (s, 0, Noaction)
605 ) strings);
608 let noghyll _ = ();;
609 let firstgeomcmds = "", [];;
611 let state =
612 { sr = Unix.stdin
613 ; sw = Unix.stdin
614 ; wsfd = Unix.stdin
615 ; errfd = None
616 ; stderr = Unix.stderr
617 ; errmsgs = Buffer.create 0
618 ; newerrmsgs = false
619 ; x = 0
620 ; y = 0
621 ; w = 0
622 ; scrollw = 0
623 ; hscrollh = 0
624 ; anchor = emptyanchor
625 ; ranchors = []
626 ; layout = []
627 ; maxy = max_int
628 ; tilelru = Queue.create ()
629 ; pagemap = Hashtbl.create 10
630 ; tilemap = Hashtbl.create 10
631 ; pdims = []
632 ; pagecount = 0
633 ; currently = Idle
634 ; mstate = Mnone
635 ; rects = []
636 ; rects1 = []
637 ; text = ""
638 ; mode = View
639 ; fullscreen = None
640 ; searchpattern = ""
641 ; outlines = [||]
642 ; bookmarks = []
643 ; path = ""
644 ; password = ""
645 ; geomcmds = firstgeomcmds
646 ; hists =
647 { nav = cbnew 10 (0, 0.0)
648 ; pat = cbnew 10 ""
649 ; pag = cbnew 10 ""
650 ; sel = cbnew 10 ""
652 ; memused = 0
653 ; gen = 0
654 ; throttle = None
655 ; autoscroll = None
656 ; ghyll = noghyll
657 ; help = makehelp ()
658 ; docinfo = []
659 ; texid = None
660 ; prevzoom = 1.0
661 ; progress = -1.0
662 ; uioh = nouioh
663 ; redisplay = true
664 ; mpos = (-1, -1)
665 ; keystate = KSnone
669 let vlog fmt =
670 if conf.verbose
671 then
672 Printf.kprintf prerr_endline fmt
673 else
674 Printf.kprintf ignore fmt
677 let launchpath () =
678 if String.length conf.pathlauncher = 0
679 then print_endline state.path
680 else (
681 let re = Str.regexp "%s" in
682 let command = Str.global_replace re state.path conf.pathlauncher in
683 try popen command
684 with exn ->
685 Printf.eprintf
686 "failed to execute `%s': %s\n" command (Printexc.to_string exn);
687 flush stderr;
691 let redirectstderr () =
692 if conf.redirectstderr
693 then
694 let rfd, wfd = Unix.pipe () in
695 state.stderr <- Unix.dup Unix.stderr;
696 state.errfd <- Some rfd;
697 Unix.dup2 wfd Unix.stderr;
698 else (
699 state.newerrmsgs <- false;
700 begin match state.errfd with
701 | Some fd ->
702 Unix.close fd;
703 Unix.dup2 state.stderr Unix.stderr;
704 state.errfd <- None;
705 | None -> ()
706 end;
707 prerr_string (Buffer.contents state.errmsgs);
708 flush stderr;
709 Buffer.clear state.errmsgs;
713 module G =
714 struct
715 let postRedisplay who =
716 if conf.verbose
717 then prerr_endline ("redisplay for " ^ who);
718 state.redisplay <- true;
720 end;;
722 let getopaque pageno =
723 try Some (Hashtbl.find state.pagemap (pageno, state.gen))
724 with Not_found -> None
727 let putopaque pageno opaque =
728 Hashtbl.replace state.pagemap (pageno, state.gen) opaque
731 let pagetranslatepoint l x y =
732 let dy = y - l.pagedispy in
733 let y = dy + l.pagey in
734 let dx = x - l.pagedispx in
735 let x = dx + l.pagex in
736 (x, y);
739 let getunder x y =
740 let rec f = function
741 | l :: rest ->
742 begin match getopaque l.pageno with
743 | Some opaque ->
744 let x0 = l.pagedispx in
745 let x1 = x0 + l.pagevw in
746 let y0 = l.pagedispy in
747 let y1 = y0 + l.pagevh in
748 if y >= y0 && y <= y1 && x >= x0 && x <= x1
749 then
750 let px, py = pagetranslatepoint l x y in
751 match whatsunder opaque px py with
752 | Unone -> f rest
753 | under -> under
754 else f rest
755 | _ ->
756 f rest
758 | [] -> Unone
760 f state.layout
763 let showtext c s =
764 state.text <- Printf.sprintf "%c%s" c s;
765 G.postRedisplay "showtext";
768 let updateunder x y =
769 match getunder x y with
770 | Unone -> Wsi.setcursor Wsi.CURSOR_INHERIT
771 | Ulinkuri uri ->
772 if conf.underinfo then showtext 'u' ("ri: " ^ uri);
773 Wsi.setcursor Wsi.CURSOR_INFO
774 | Ulinkgoto (page, _) ->
775 if conf.underinfo
776 then showtext 'p' ("age: " ^ string_of_int (page+1));
777 Wsi.setcursor Wsi.CURSOR_INFO
778 | Utext s ->
779 if conf.underinfo then showtext 'f' ("ont: " ^ s);
780 Wsi.setcursor Wsi.CURSOR_TEXT
781 | Uunexpected s ->
782 if conf.underinfo then showtext 'u' ("nexpected: " ^ s);
783 Wsi.setcursor Wsi.CURSOR_INHERIT
784 | Ulaunch s ->
785 if conf.underinfo then showtext 'l' ("aunch: " ^ s);
786 Wsi.setcursor Wsi.CURSOR_INHERIT
787 | Unamed s ->
788 if conf.underinfo then showtext 'n' ("amed: " ^ s);
789 Wsi.setcursor Wsi.CURSOR_INHERIT
790 | Uremote (filename, pageno) ->
791 if conf.underinfo then showtext 'r'
792 (Printf.sprintf "emote: %s (%d)" filename pageno);
793 Wsi.setcursor Wsi.CURSOR_INFO
796 let showlinktype under =
797 if conf.underinfo
798 then
799 match under with
800 | Unone -> ()
801 | Ulinkuri uri ->
802 showtext 'u' ("ri: " ^ uri)
803 | Ulinkgoto (page, _) ->
804 showtext 'p' ("age: " ^ string_of_int (page+1));
805 | Utext s ->
806 showtext 'f' ("ont: " ^ s);
807 | Uunexpected s ->
808 showtext 'u' ("nexpected: " ^ s);
809 | Ulaunch s ->
810 showtext 'l' ("aunch: " ^ s);
811 | Unamed s ->
812 showtext 'n' ("amed: " ^ s);
813 | Uremote (filename, pageno) ->
814 showtext 'r' (Printf.sprintf "emote: %s (%d)" filename pageno);
817 let addchar s c =
818 let b = Buffer.create (String.length s + 1) in
819 Buffer.add_string b s;
820 Buffer.add_char b c;
821 Buffer.contents b;
824 let colorspace_of_string s =
825 match String.lowercase s with
826 | "rgb" -> Rgb
827 | "bgr" -> Bgr
828 | "gray" -> Gray
829 | _ -> failwith "invalid colorspace"
832 let int_of_colorspace = function
833 | Rgb -> 0
834 | Bgr -> 1
835 | Gray -> 2
838 let colorspace_of_int = function
839 | 0 -> Rgb
840 | 1 -> Bgr
841 | 2 -> Gray
842 | n -> failwith ("invalid colorspace index " ^ string_of_int n)
845 let colorspace_to_string = function
846 | Rgb -> "rgb"
847 | Bgr -> "bgr"
848 | Gray -> "gray"
851 let intentry_with_suffix text key =
852 let c =
853 if key >= 32 && key < 127
854 then Char.chr key
855 else '\000'
857 match Char.lowercase c with
858 | '0' .. '9' ->
859 let text = addchar text c in
860 TEcont text
862 | 'k' | 'm' | 'g' ->
863 let text = addchar text c in
864 TEcont text
866 | _ ->
867 state.text <- Printf.sprintf "invalid char (%d, `%c')" key c;
868 TEcont text
871 let columns_to_string (n, a, b) =
872 if a = 0 && b = 0
873 then Printf.sprintf "%d" n
874 else Printf.sprintf "%d,%d,%d" n a b;
877 let columns_of_string s =
879 (int_of_string s, 0, 0)
880 with _ ->
881 Scanf.sscanf s "%u,%u,%u" (fun n a b -> (n, a, b));
884 let readcmd fd =
885 let s = "xxxx" in
886 let n = Unix.read fd s 0 4 in
887 if n != 4 then failwith "incomplete read(len)";
888 let len = 0
889 lor (Char.code s.[0] lsl 24)
890 lor (Char.code s.[1] lsl 16)
891 lor (Char.code s.[2] lsl 8)
892 lor (Char.code s.[3] lsl 0)
894 let s = String.create len in
895 let n = Unix.read fd s 0 len in
896 if n != len then failwith "incomplete read(data)";
900 let btod b = if b then 1 else 0;;
902 let wcmd fmt =
903 let b = Buffer.create 16 in
904 Buffer.add_string b "llll";
905 Printf.kbprintf
906 (fun b ->
907 let s = Buffer.contents b in
908 let n = String.length s in
909 let len = n - 4 in
910 (* dolog "wcmd %S" (String.sub s 4 len); *)
911 s.[0] <- Char.chr ((len lsr 24) land 0xff);
912 s.[1] <- Char.chr ((len lsr 16) land 0xff);
913 s.[2] <- Char.chr ((len lsr 8) land 0xff);
914 s.[3] <- Char.chr (len land 0xff);
915 let n' = Unix.write state.sw s 0 n in
916 if n' != n then failwith "write failed";
917 ) b fmt;
920 let calcips h =
921 if conf.presentation
922 then
923 let d = conf.winh - h in
924 max 0 ((d + 1) / 2)
925 else
926 conf.interpagespace
929 let calcheight () =
930 let rec f pn ph pi fh l =
931 match l with
932 | (n, _, h, _) :: rest ->
933 let ips = calcips h in
934 let fh =
935 if conf.presentation
936 then fh+ips
937 else (
938 if isbirdseye state.mode && pn = 0
939 then fh + ips
940 else fh
943 let fh = fh + ((n - pn) * (ph + pi)) in
944 f n h ips fh rest;
946 | [] ->
947 let inc =
948 if conf.presentation || (isbirdseye state.mode && pn = 0)
949 then 0
950 else -pi
952 let fh = fh + ((state.pagecount - pn) * (ph + pi)) + inc in
953 max 0 fh
955 let fh = f 0 0 0 0 state.pdims in
959 let calcheight () =
960 match conf.columns with
961 | None -> calcheight ()
962 | Some (_, b) ->
963 if Array.length b > 0
964 then
965 let (_, _, y, (_, _, h, _)) = b.(Array.length b - 1) in
966 y + h
967 else 0
970 let getpageyh pageno =
971 let rec f pn ph pi y l =
972 match l with
973 | (n, _, h, _) :: rest ->
974 let ips = calcips h in
975 if n >= pageno
976 then
977 let h = if n = pageno then h else ph in
978 if conf.presentation && n = pageno
979 then
980 y + (pageno - pn) * (ph + pi) + pi, h
981 else
982 y + (pageno - pn) * (ph + pi), h
983 else
984 let y = y + (if conf.presentation then pi else 0) in
985 let y = y + (n - pn) * (ph + pi) in
986 f n h ips y rest
988 | [] ->
989 y + (pageno - pn) * (ph + pi), ph
991 f 0 0 0 0 state.pdims
994 let getpageyh pageno =
995 match conf.columns with
996 | None -> getpageyh pageno
997 | Some (_, b) ->
998 let (_, _, y, (_, _, h, _)) = b.(pageno) in
999 y, h
1002 let getpagedim pageno =
1003 let rec f ppdim l =
1004 match l with
1005 | (n, _, _, _) as pdim :: rest ->
1006 if n >= pageno
1007 then (if n = pageno then pdim else ppdim)
1008 else f pdim rest
1010 | [] -> ppdim
1012 f (-1, -1, -1, -1) state.pdims
1015 let getpagey pageno = fst (getpageyh pageno);;
1017 let nogeomcmds cmds =
1018 match cmds with
1019 | s, [] -> String.length s = 0
1020 | _ -> false
1023 let layout1 y sh =
1024 let sh = sh - state.hscrollh in
1025 let rec f ~pageno ~pdimno ~prev ~py ~dy ~pdims ~accu =
1026 let ((w, h, ips, xoff) as curr), rest, pdimno, yinc =
1027 match pdims with
1028 | (pageno', w, h, xoff) :: rest when pageno' = pageno ->
1029 let ips = calcips h in
1030 let yinc =
1031 if conf.presentation || (isbirdseye state.mode && pageno = 0)
1032 then ips
1033 else 0
1035 (w, h, ips, xoff), rest, pdimno + 1, yinc
1036 | _ ->
1037 prev, pdims, pdimno, 0
1039 let dy = dy + yinc in
1040 let py = py + yinc in
1041 if pageno = state.pagecount || dy >= sh
1042 then
1043 accu
1044 else
1045 let vy = y + dy in
1046 if py + h <= vy - yinc
1047 then
1048 let py = py + h + ips in
1049 let dy = max 0 (py - y) in
1050 f ~pageno:(pageno+1)
1051 ~pdimno
1052 ~prev:curr
1055 ~pdims:rest
1056 ~accu
1057 else
1058 let pagey = vy - py in
1059 let pagevh = h - pagey in
1060 let pagevh = min (sh - dy) pagevh in
1061 let off = if yinc > 0 then py - vy else 0 in
1062 let py = py + h + ips in
1063 let pagex, dx =
1064 let xoff = xoff +
1065 if state.w < conf.winw - state.scrollw
1066 then (conf.winw - state.scrollw - state.w) / 2
1067 else 0
1069 let dispx = xoff + state.x in
1070 if dispx < 0
1071 then (-dispx, 0)
1072 else (0, dispx)
1074 let pagevw =
1075 let lw = w - pagex in
1076 min lw (conf.winw - state.scrollw)
1078 let e =
1079 { pageno = pageno
1080 ; pagedimno = pdimno
1081 ; pagew = w
1082 ; pageh = h
1083 ; pagex = pagex
1084 ; pagey = pagey + off
1085 ; pagevw = pagevw
1086 ; pagevh = pagevh - off
1087 ; pagedispx = dx
1088 ; pagedispy = dy + off
1091 let accu = e :: accu in
1092 f ~pageno:(pageno+1)
1093 ~pdimno
1094 ~prev:curr
1096 ~dy:(dy+pagevh+ips)
1097 ~pdims:rest
1098 ~accu
1100 if nogeomcmds state.geomcmds
1101 then (
1102 let accu =
1104 ~pageno:0
1105 ~pdimno:~-1
1106 ~prev:(0,0,0,0)
1107 ~py:0
1108 ~dy:0
1109 ~pdims:state.pdims
1110 ~accu:[]
1112 List.rev accu
1114 else
1118 let layoutN ((columns, coverA, coverB), b) y sh =
1119 let sh = sh - state.hscrollh in
1120 let rec fold accu n =
1121 if n = Array.length b
1122 then accu
1123 else
1124 let pdimno, dx, vy, (_, w, h, xoff) = b.(n) in
1125 if (vy - y) > sh &&
1126 (n = coverA - 1
1127 || n = state.pagecount - coverB
1128 || (n - coverA) mod columns = columns - 1)
1129 then accu
1130 else
1131 let accu =
1132 if vy + h > y
1133 then
1134 let pagey = max 0 (y - vy) in
1135 let pagedispy = if pagey > 0 then 0 else vy - y in
1136 let pagedispx, pagex, pagevw =
1137 let pdx =
1138 if n = coverA - 1 || n = state.pagecount - coverB
1139 then state.x + (conf.winw - state.scrollw - w) / 2
1140 else dx + xoff + state.x
1142 if pdx < 0
1143 then 0, -pdx, w + pdx
1144 else pdx, 0, min (conf.winw - state.scrollw) w
1146 let pagevh = min (h - pagey) (sh - pagedispy) in
1147 if pagedispx < conf.winw - state.scrollw && pagevw > 0 && pagevh > 0
1148 then
1149 let e =
1150 { pageno = n
1151 ; pagedimno = pdimno
1152 ; pagew = w
1153 ; pageh = h
1154 ; pagex = pagex
1155 ; pagey = pagey
1156 ; pagevw = pagevw
1157 ; pagevh = pagevh
1158 ; pagedispx = pagedispx
1159 ; pagedispy = pagedispy
1162 e :: accu
1163 else
1164 accu
1165 else
1166 accu
1168 fold accu (n+1)
1170 if nogeomcmds state.geomcmds
1171 then List.rev (fold [] 0)
1172 else []
1175 let layout y sh =
1176 match conf.columns with
1177 | None -> layout1 y sh
1178 | Some c -> layoutN c y sh
1181 let clamp incr =
1182 let y = state.y + incr in
1183 let y = max 0 y in
1184 let y = min y (state.maxy - (if conf.maxhfit then conf.winh else 0)) in
1188 let itertiles l f =
1189 let tilex = l.pagex mod conf.tilew in
1190 let tiley = l.pagey mod conf.tileh in
1192 let col = l.pagex / conf.tilew in
1193 let row = l.pagey / conf.tileh in
1195 let vw =
1196 let a = l.pagew - l.pagex in
1197 let b = conf.winw - state.scrollw in
1198 min a b
1199 and vh = l.pagevh in
1201 let rec rowloop row y0 dispy h =
1202 if h = 0
1203 then ()
1204 else (
1205 let dh = conf.tileh - y0 in
1206 let dh = min h dh in
1207 let rec colloop col x0 dispx w =
1208 if w = 0
1209 then ()
1210 else (
1211 let dw = conf.tilew - x0 in
1212 let dw = min w dw in
1214 f col row dispx dispy x0 y0 dw dh;
1215 colloop (col+1) 0 (dispx+dw) (w-dw)
1218 colloop col tilex l.pagedispx vw;
1219 rowloop (row+1) 0 (dispy+dh) (h-dh)
1222 if vw > 0 && vh > 0
1223 then rowloop row tiley l.pagedispy vh;
1226 let gettileopaque l col row =
1227 let key =
1228 l.pageno, state.gen, conf.colorspace, conf.angle, l.pagew, l.pageh, col, row
1230 try Some (Hashtbl.find state.tilemap key)
1231 with Not_found -> None
1234 let puttileopaque l col row gen colorspace angle opaque size elapsed =
1235 let key = l.pageno, gen, colorspace, angle, l.pagew, l.pageh, col, row in
1236 Hashtbl.add state.tilemap key (opaque, size, elapsed)
1239 let drawtiles l color =
1240 GlDraw.color color;
1241 let f col row x y tilex tiley w h =
1242 match gettileopaque l col row with
1243 | Some (opaque, _, t) ->
1244 let params = x, y, w, h, tilex, tiley in
1245 if conf.invert
1246 then (
1247 Gl.enable `blend;
1248 GlFunc.blend_func `zero `one_minus_src_color;
1250 drawtile params opaque;
1251 if conf.invert
1252 then Gl.disable `blend;
1253 if conf.debug
1254 then (
1255 let s = Printf.sprintf
1256 "%d[%d,%d] %f sec"
1257 l.pageno col row t
1259 let w = measurestr fstate.fontsize s in
1260 GlMisc.push_attrib [`current];
1261 GlDraw.color (0.0, 0.0, 0.0);
1262 GlDraw.rect
1263 (float (x-2), float (y-2))
1264 (float (x+2) +. w, float (y + fstate.fontsize + 2));
1265 GlDraw.color (1.0, 1.0, 1.0);
1266 drawstring fstate.fontsize x (y + fstate.fontsize - 1) s;
1267 GlMisc.pop_attrib ();
1270 | _ ->
1271 let w =
1272 let lw = conf.winw - state.scrollw - x in
1273 min lw w
1274 and h =
1275 let lh = conf.winh - y in
1276 min lh h
1278 Gl.enable `texture_2d;
1279 begin match state.texid with
1280 | Some id ->
1281 GlTex.bind_texture `texture_2d id;
1282 let x0 = float x
1283 and y0 = float y
1284 and x1 = float (x+w)
1285 and y1 = float (y+h) in
1287 let tw = float w /. 64.0
1288 and th = float h /. 64.0 in
1289 let tx0 = float tilex /. 64.0
1290 and ty0 = float tiley /. 64.0 in
1291 let tx1 = tx0 +. tw
1292 and ty1 = ty0 +. th in
1293 GlDraw.begins `quads;
1294 GlTex.coord2 (tx0, ty0); GlDraw.vertex2 (x0, y0);
1295 GlTex.coord2 (tx0, ty1); GlDraw.vertex2 (x0, y1);
1296 GlTex.coord2 (tx1, ty1); GlDraw.vertex2 (x1, y1);
1297 GlTex.coord2 (tx1, ty0); GlDraw.vertex2 (x1, y0);
1298 GlDraw.ends ();
1300 Gl.disable `texture_2d;
1301 | None ->
1302 GlDraw.color (1.0, 1.0, 1.0);
1303 GlDraw.rect
1304 (float x, float y)
1305 (float (x+w), float (y+h));
1306 end;
1307 if w > 128 && h > fstate.fontsize + 10
1308 then (
1309 GlDraw.color (0.0, 0.0, 0.0);
1310 let c, r =
1311 if conf.verbose
1312 then (col*conf.tilew, row*conf.tileh)
1313 else col, row
1315 drawstring2 fstate.fontsize x y "Loading %d [%d,%d]" l.pageno c r;
1317 GlDraw.color color;
1319 itertiles l f
1322 let pagevisible layout n = List.exists (fun l -> l.pageno = n) layout;;
1324 let tilevisible1 l x y =
1325 let ax0 = l.pagex
1326 and ax1 = l.pagex + l.pagevw
1327 and ay0 = l.pagey
1328 and ay1 = l.pagey + l.pagevh in
1330 let bx0 = x
1331 and by0 = y in
1332 let bx1 = min (bx0 + conf.tilew) l.pagew
1333 and by1 = min (by0 + conf.tileh) l.pageh in
1335 let rx0 = max ax0 bx0
1336 and ry0 = max ay0 by0
1337 and rx1 = min ax1 bx1
1338 and ry1 = min ay1 by1 in
1340 let nonemptyintersection = rx1 > rx0 && ry1 > ry0 in
1341 nonemptyintersection
1344 let tilevisible layout n x y =
1345 let rec findpageinlayout = function
1346 | l :: _ when l.pageno = n -> tilevisible1 l x y
1347 | _ :: rest -> findpageinlayout rest
1348 | [] -> false
1350 findpageinlayout layout
1353 let tileready l x y =
1354 tilevisible1 l x y &&
1355 gettileopaque l (x/conf.tilew) (y/conf.tileh) != None
1358 let tilepage n p layout =
1359 let rec loop = function
1360 | l :: rest ->
1361 if l.pageno = n
1362 then
1363 let f col row _ _ _ _ _ _ =
1364 if state.currently = Idle
1365 then
1366 match gettileopaque l col row with
1367 | Some _ -> ()
1368 | None ->
1369 let x = col*conf.tilew
1370 and y = row*conf.tileh in
1371 let w =
1372 let w = l.pagew - x in
1373 min w conf.tilew
1375 let h =
1376 let h = l.pageh - y in
1377 min h conf.tileh
1379 wcmd "tile %s %d %d %d %d" p x y w h;
1380 state.currently <-
1381 Tiling (
1382 l, p, conf.colorspace, conf.angle, state.gen, col, row,
1383 conf.tilew, conf.tileh
1386 itertiles l f;
1387 else
1388 loop rest
1390 | [] -> ()
1392 if nogeomcmds state.geomcmds
1393 then loop layout;
1396 let preloadlayout visiblepages =
1397 let presentation = conf.presentation in
1398 let interpagespace = conf.interpagespace in
1399 let maxy = state.maxy in
1400 conf.presentation <- false;
1401 conf.interpagespace <- 0;
1402 state.maxy <- calcheight ();
1403 let y =
1404 match visiblepages with
1405 | [] -> 0
1406 | l :: _ -> getpagey l.pageno + l.pagey
1408 let y = if y < conf.winh then 0 else y - conf.winh in
1409 let h = state.y - y + conf.winh*3 in
1410 let pages = layout y h in
1411 conf.presentation <- presentation;
1412 conf.interpagespace <- interpagespace;
1413 state.maxy <- maxy;
1414 pages;
1417 let load pages =
1418 let rec loop pages =
1419 if state.currently != Idle
1420 then ()
1421 else
1422 match pages with
1423 | l :: rest ->
1424 begin match getopaque l.pageno with
1425 | None ->
1426 wcmd "page %d %d" l.pageno l.pagedimno;
1427 state.currently <- Loading (l, state.gen);
1428 | Some opaque ->
1429 tilepage l.pageno opaque pages;
1430 loop rest
1431 end;
1432 | _ -> ()
1434 if nogeomcmds state.geomcmds
1435 then loop pages
1438 let preload pages =
1439 load pages;
1440 if conf.preload && state.currently = Idle
1441 then load (preloadlayout pages);
1444 let layoutready layout =
1445 let rec fold all ls =
1446 all && match ls with
1447 | l :: rest ->
1448 let seen = ref false in
1449 let allvisible = ref true in
1450 let foo col row _ _ _ _ _ _ =
1451 seen := true;
1452 allvisible := !allvisible &&
1453 begin match gettileopaque l col row with
1454 | Some _ -> true
1455 | None -> false
1458 itertiles l foo;
1459 fold (!seen && !allvisible) rest
1460 | [] -> true
1462 let alltilesvisible = fold true layout in
1463 alltilesvisible;
1466 let gotoy y =
1467 let y = bound y 0 state.maxy in
1468 let y, layout, proceed =
1469 match conf.maxwait with
1470 | Some time when state.ghyll == noghyll ->
1471 begin match state.throttle with
1472 | None ->
1473 let layout = layout y conf.winh in
1474 let ready = layoutready layout in
1475 if not ready
1476 then (
1477 load layout;
1478 state.throttle <- Some (layout, y, now ());
1480 else G.postRedisplay "gotoy showall (None)";
1481 y, layout, ready
1482 | Some (_, _, started) ->
1483 let dt = now () -. started in
1484 if dt > time
1485 then (
1486 state.throttle <- None;
1487 let layout = layout y conf.winh in
1488 load layout;
1489 G.postRedisplay "maxwait";
1490 y, layout, true
1492 else -1, [], false
1495 | _ ->
1496 let layout = layout y conf.winh in
1497 if true || layoutready layout
1498 then G.postRedisplay "gotoy ready";
1499 y, layout, true
1501 if proceed
1502 then (
1503 state.y <- y;
1504 state.layout <- layout;
1505 begin match state.mode with
1506 | Birdseye (conf, leftx, pageno, hooverpageno, anchor) ->
1507 if not (pagevisible layout pageno)
1508 then (
1509 match state.layout with
1510 | [] -> ()
1511 | l :: _ ->
1512 state.mode <- Birdseye (
1513 conf, leftx, l.pageno, hooverpageno, anchor
1516 | LinkNav (Ltgendir dir as lt) ->
1517 let linknav =
1518 let rec loop = function
1519 | [] -> lt
1520 | l :: rest ->
1521 match getopaque l.pageno with
1522 | None -> loop rest
1523 | Some opaque ->
1524 let link =
1525 let ld =
1526 if dir = 0
1527 then LDfirstvisible (l.pagex, l.pagey, dir)
1528 else (
1529 if dir > 0 then LDfirst else LDlast
1532 findlink opaque ld
1534 match link with
1535 | Lnotfound -> loop rest
1536 | Lfound n ->
1537 showlinktype (getlink opaque n);
1538 Ltexact (l.pageno, n)
1540 loop state.layout
1542 state.mode <- LinkNav linknav
1543 | _ -> ()
1544 end;
1545 preload layout;
1547 state.ghyll <- noghyll;
1548 if conf.updatecurs
1549 then (
1550 let mx, my = state.mpos in
1551 updateunder mx my;
1555 let conttiling pageno opaque =
1556 tilepage pageno opaque
1557 (if conf.preload then preloadlayout state.layout else state.layout)
1560 let gotoy_and_clear_text y =
1561 if not conf.verbose then state.text <- "";
1562 gotoy y;
1565 let getanchor () =
1566 match state.layout with
1567 | [] -> emptyanchor
1568 | l :: _ -> (l.pageno, float l.pagey /. float l.pageh)
1571 let getanchory (n, top) =
1572 let y, h = getpageyh n in
1573 y + (truncate (top *. float h));
1576 let gotoanchor anchor =
1577 gotoy (getanchory anchor);
1580 let addnav () =
1581 cbput state.hists.nav (getanchor ());
1584 let getnav dir =
1585 let anchor = cbgetc state.hists.nav dir in
1586 getanchory anchor;
1589 let gotoghyll y =
1590 let rec scroll f n a b =
1591 (* http://devmaster.net/forums/topic/9796-ease-in-ease-out-algorithm/ *)
1592 let snake f a b =
1593 let s x = 3.0*.x**2.0 -. 2.0*.x**3.0 in
1594 if f < a
1595 then s (float f /. float a)
1596 else (
1597 if f > b
1598 then 1.0 -. s ((float (f-b) /. float (n-b)))
1599 else 1.0
1602 snake f a b
1603 and summa f n a b =
1604 (* courtesy:
1605 http://integrals.wolfram.com/index.jsp?expr=3x%5E2-2x%5E3&random=false *)
1606 let iv x = -.((-.2.0 +. x)*.x**3.0)/.2.0 in
1607 let iv1 = iv f in
1608 let ins = float a *. iv1
1609 and outs = float (n-b) *. iv1 in
1610 let ones = b - a in
1611 ins +. outs +. float ones
1613 let rec set (_N, _A, _B) y sy =
1614 let sum = summa 1.0 _N _A _B in
1615 let dy = float (y - sy) in
1616 state.ghyll <- (
1617 let rec gf n y1 o =
1618 if n >= _N
1619 then state.ghyll <- noghyll
1620 else
1621 let go n =
1622 let s = scroll n _N _A _B in
1623 let y1 = y1 +. ((s *. dy) /. sum) in
1624 gotoy_and_clear_text (truncate y1);
1625 state.ghyll <- gf (n+1) y1;
1627 match o with
1628 | None -> go n
1629 | Some y' -> set (_N/2, 0, 0) y' state.y
1631 gf 0 (float state.y)
1634 match conf.ghyllscroll with
1635 | None ->
1636 gotoy_and_clear_text y
1637 | Some nab ->
1638 if state.ghyll == noghyll
1639 then set nab y state.y
1640 else state.ghyll (Some y)
1643 let gotopage n top =
1644 let y, h = getpageyh n in
1645 let y = y + (truncate (top *. float h)) in
1646 gotoghyll y
1649 let gotopage1 n top =
1650 let y = getpagey n in
1651 let y = y + top in
1652 gotoghyll y
1655 let invalidate s f =
1656 state.layout <- [];
1657 state.pdims <- [];
1658 state.rects <- [];
1659 state.rects1 <- [];
1660 match state.geomcmds with
1661 | ps, [] when String.length ps = 0 ->
1662 f ();
1663 state.geomcmds <- s, [];
1665 | ps, [] ->
1666 state.geomcmds <- ps, [s, f];
1668 | ps, (s', _) :: rest when s' = s ->
1669 state.geomcmds <- ps, ((s, f) :: rest);
1671 | ps, cmds ->
1672 state.geomcmds <- ps, ((s, f) :: cmds);
1675 let opendoc path password =
1676 state.path <- path;
1677 state.password <- password;
1678 state.gen <- state.gen + 1;
1679 state.docinfo <- [];
1681 setaalevel conf.aalevel;
1682 Wsi.settitle ("llpp " ^ Filename.basename path);
1683 wcmd "open %s\000%s\000" path password;
1684 invalidate "reqlayout"
1685 (fun () ->
1686 wcmd "reqlayout %d %d" conf.angle (btod conf.proportional));
1689 let scalecolor c =
1690 let c = c *. conf.colorscale in
1691 (c, c, c);
1694 let scalecolor2 (r, g, b) =
1695 (r *. conf.colorscale, g *. conf.colorscale, b *. conf.colorscale);
1698 let represent () =
1699 let docolumns = function
1700 | None -> ()
1701 | Some ((columns, coverA, coverB), _) ->
1702 let a = Array.make state.pagecount (-1, -1, -1, (-1, -1, -1, -1)) in
1703 let rec loop pageno pdimno pdim x y rowh pdims =
1704 if pageno = state.pagecount
1705 then ()
1706 else
1707 let pdimno, ((_, w, h, xoff) as pdim), pdims =
1708 match pdims with
1709 | ((pageno', _, _, _) as pdim) :: rest when pageno' = pageno ->
1710 pdimno+1, pdim, rest
1711 | _ ->
1712 pdimno, pdim, pdims
1714 let x, y, rowh' =
1715 if pageno = coverA - 1 || pageno = state.pagecount - coverB
1716 then (
1717 (conf.winw - state.scrollw - w) / 2,
1718 y + rowh + conf.interpagespace, h
1720 else (
1721 if (pageno - coverA) mod columns = 0
1722 then 0, y + rowh + conf.interpagespace, h
1723 else x, y, max rowh h
1726 let rec fixrow m = if m = pageno then () else
1727 let (pdimno, x, y, ((_, _, h, _) as pdim)) = a.(m) in
1728 if h < rowh
1729 then (
1730 let y = y + (rowh - h) / 2 in
1731 a.(m) <- (pdimno, x, y, pdim);
1733 fixrow (m+1)
1735 if pageno > 1 && (pageno - coverA) mod columns = 0
1736 then fixrow (pageno - columns);
1737 a.(pageno) <- (pdimno, x, y, pdim);
1738 let x = x + w + xoff*2 + conf.interpagespace in
1739 loop (pageno+1) pdimno pdim x y rowh' pdims
1741 loop 0 ~-1 (-1,-1,-1,-1) 0 0 0 state.pdims;
1742 conf.columns <- Some ((columns, coverA, coverB), a);
1744 docolumns conf.columns;
1745 state.maxy <- calcheight ();
1746 state.hscrollh <-
1747 if state.w <= conf.winw - state.scrollw
1748 then 0
1749 else state.scrollw
1751 match state.mode with
1752 | Birdseye (_, _, pageno, _, _) ->
1753 let y, h = getpageyh pageno in
1754 let top = (conf.winh - h) / 2 in
1755 gotoy (max 0 (y - top))
1756 | _ -> gotoanchor state.anchor
1759 let reshape w h =
1760 GlDraw.viewport 0 0 w h;
1761 if state.geomcmds != firstgeomcmds && nogeomcmds state.geomcmds
1762 then state.anchor <- getanchor ();
1764 conf.winw <- w;
1765 let w = truncate (float w *. conf.zoom) - state.scrollw in
1766 let w = max w 2 in
1767 conf.winh <- h;
1768 setfontsize fstate.fontsize;
1769 GlMat.mode `modelview;
1770 GlMat.load_identity ();
1772 GlMat.mode `projection;
1773 GlMat.load_identity ();
1774 GlMat.rotate ~x:1.0 ~angle:180.0 ();
1775 GlMat.translate ~x:~-.1.0 ~y:~-.1.0 ();
1776 GlMat.scale3 (2.0 /. float conf.winw, 2.0 /. float conf.winh, 1.0);
1778 let relx =
1779 if conf.zoom <= 1.0
1780 then 0.0
1781 else float state.x /. float state.w
1783 invalidate "geometry"
1784 (fun () ->
1785 state.w <- w;
1786 state.x <- truncate (relx *. float w);
1787 let w =
1788 match conf.columns with
1789 | None -> w
1790 | Some ((c, _, _), _) -> (w - (c-1)*conf.interpagespace) / c
1792 wcmd "geometry %d %d" w h);
1795 let enttext () =
1796 let len = String.length state.text in
1797 let drawstring s =
1798 let hscrollh =
1799 match state.mode with
1800 | Textentry _
1801 | View -> state.hscrollh
1802 | _ -> 0
1804 let rect x w =
1805 GlDraw.rect
1806 (x, float (conf.winh - (fstate.fontsize + 4) - hscrollh))
1807 (x+.w, float (conf.winh - hscrollh))
1810 let w = float (conf.winw - state.scrollw - 1) in
1811 if state.progress >= 0.0 && state.progress < 1.0
1812 then (
1813 GlDraw.color (0.3, 0.3, 0.3);
1814 let w1 = w *. state.progress in
1815 rect 0.0 w1;
1816 GlDraw.color (0.0, 0.0, 0.0);
1817 rect w1 (w-.w1)
1819 else (
1820 GlDraw.color (0.0, 0.0, 0.0);
1821 rect 0.0 w;
1824 GlDraw.color (1.0, 1.0, 1.0);
1825 drawstring fstate.fontsize
1826 (if len > 0 then 8 else 2) (conf.winh - hscrollh - 5) s;
1828 let s =
1829 match state.mode with
1830 | Textentry ((prefix, text, _, _, _), _) ->
1831 let s =
1832 if len > 0
1833 then
1834 Printf.sprintf "%s%s_ [%s]" prefix text state.text
1835 else
1836 Printf.sprintf "%s%s_" prefix text
1840 | _ -> state.text
1842 let s =
1843 if state.newerrmsgs
1844 then (
1845 if not (istextentry state.mode)
1846 then
1847 let s1 = "(press 'e' to review error messasges)" in
1848 if String.length s > 0 then s ^ " " ^ s1 else s1
1849 else s
1851 else s
1853 if String.length s > 0
1854 then drawstring s
1857 let gctiles () =
1858 let len = Queue.length state.tilelru in
1859 let rec loop qpos =
1860 if state.memused <= conf.memlimit
1861 then ()
1862 else (
1863 if qpos < len
1864 then
1865 let (k, p, s) as lruitem = Queue.pop state.tilelru in
1866 let n, gen, colorspace, angle, pagew, pageh, col, row = k in
1867 let (_, pw, ph, _) = getpagedim n in
1869 gen = state.gen
1870 && colorspace = conf.colorspace
1871 && angle = conf.angle
1872 && pagew = pw
1873 && pageh = ph
1874 && (
1875 let layout =
1876 match state.throttle with
1877 | None ->
1878 if conf.preload
1879 then preloadlayout state.layout
1880 else state.layout
1881 | Some (layout, _, _) ->
1882 layout
1884 let x = col*conf.tilew
1885 and y = row*conf.tileh in
1886 tilevisible layout n x y
1888 then Queue.push lruitem state.tilelru
1889 else (
1890 wcmd "freetile %s" p;
1891 state.memused <- state.memused - s;
1892 state.uioh#infochanged Memused;
1893 Hashtbl.remove state.tilemap k;
1895 loop (qpos+1)
1898 loop 0
1901 let flushtiles () =
1902 Queue.iter (fun (k, p, s) ->
1903 wcmd "freetile %s" p;
1904 state.memused <- state.memused - s;
1905 state.uioh#infochanged Memused;
1906 Hashtbl.remove state.tilemap k;
1907 ) state.tilelru;
1908 Queue.clear state.tilelru;
1909 load state.layout;
1912 let logcurrently = function
1913 | Idle -> dolog "Idle"
1914 | Loading (l, gen) ->
1915 dolog "Loading %d gen=%d curgen=%d" l.pageno gen state.gen
1916 | Tiling (l, pageopaque, colorspace, angle, gen, col, row, tilew, tileh) ->
1917 dolog
1918 "Tiling %d[%d,%d] page=%s cs=%s angle"
1919 l.pageno col row pageopaque
1920 (colorspace_to_string colorspace)
1922 dolog "gen=(%d,%d) (%d,%d) tile=(%d,%d) (%d,%d)"
1923 angle gen conf.angle state.gen
1924 tilew tileh
1925 conf.tilew conf.tileh
1927 | Outlining _ ->
1928 dolog "outlining"
1931 let act cmds =
1932 (* dolog "%S" cmds; *)
1933 let op, args =
1934 let spacepos =
1935 try String.index cmds ' '
1936 with Not_found -> -1
1938 if spacepos = -1
1939 then cmds, ""
1940 else
1941 let l = String.length cmds in
1942 let op = String.sub cmds 0 spacepos in
1943 op, begin
1944 if l - spacepos < 2 then ""
1945 else String.sub cmds (spacepos+1) (l-spacepos-1)
1948 match op with
1949 | "clear" ->
1950 state.uioh#infochanged Pdim;
1951 state.pdims <- [];
1953 | "clearrects" ->
1954 state.rects <- state.rects1;
1955 G.postRedisplay "clearrects";
1957 | "continue" ->
1958 let n =
1959 try Scanf.sscanf args "%u" (fun n -> n)
1960 with exn ->
1961 dolog "error processing 'continue' %S: %s"
1962 cmds (Printexc.to_string exn);
1963 exit 1;
1965 state.pagecount <- n;
1966 begin match state.currently with
1967 | Outlining l ->
1968 state.currently <- Idle;
1969 state.outlines <- Array.of_list (List.rev l)
1970 | _ -> ()
1971 end;
1973 let cur, cmds = state.geomcmds in
1974 if String.length cur = 0
1975 then failwith "umpossible";
1977 begin match List.rev cmds with
1978 | [] ->
1979 state.geomcmds <- "", [];
1980 represent ();
1981 | (s, f) :: rest ->
1982 f ();
1983 state.geomcmds <- s, List.rev rest;
1984 end;
1985 if conf.maxwait = None
1986 then G.postRedisplay "continue";
1988 | "title" ->
1989 Wsi.settitle args
1991 | "msg" ->
1992 showtext ' ' args
1994 | "vmsg" ->
1995 if conf.verbose
1996 then showtext ' ' args
1998 | "progress" ->
1999 let progress, text =
2001 Scanf.sscanf args "%f %n"
2002 (fun f pos ->
2003 f, String.sub args pos (String.length args - pos))
2004 with exn ->
2005 dolog "error processing 'progress' %S: %s"
2006 cmds (Printexc.to_string exn);
2007 exit 1;
2009 state.text <- text;
2010 state.progress <- progress;
2011 G.postRedisplay "progress"
2013 | "firstmatch" ->
2014 let pageno, c, x0, y0, x1, y1, x2, y2, x3, y3 =
2016 Scanf.sscanf args "%u %d %f %f %f %f %f %f %f %f"
2017 (fun p c x0 y0 x1 y1 x2 y2 x3 y3 ->
2018 (p, c, x0, y0, x1, y1, x2, y2, x3, y3))
2019 with exn ->
2020 dolog "error processing 'firstmatch' %S: %s"
2021 cmds (Printexc.to_string exn);
2022 exit 1;
2024 let y = (getpagey pageno) + truncate y0 in
2025 addnav ();
2026 gotoy y;
2027 state.rects1 <- [pageno, c, (x0, y0, x1, y1, x2, y2, x3, y3)]
2029 | "match" ->
2030 let pageno, c, x0, y0, x1, y1, x2, y2, x3, y3 =
2032 Scanf.sscanf args "%u %d %f %f %f %f %f %f %f %f"
2033 (fun p c x0 y0 x1 y1 x2 y2 x3 y3 ->
2034 (p, c, x0, y0, x1, y1, x2, y2, x3, y3))
2035 with exn ->
2036 dolog "error processing 'match' %S: %s"
2037 cmds (Printexc.to_string exn);
2038 exit 1;
2040 state.rects1 <-
2041 (pageno, c, (x0, y0, x1, y1, x2, y2, x3, y3)) :: state.rects1
2043 | "page" ->
2044 let pageopaque, t =
2046 Scanf.sscanf args "%s %f" (fun p t -> p, t)
2047 with exn ->
2048 dolog "error processing 'page' %S: %s"
2049 cmds (Printexc.to_string exn);
2050 exit 1;
2052 begin match state.currently with
2053 | Loading (l, gen) ->
2054 vlog "page %d took %f sec" l.pageno t;
2055 Hashtbl.replace state.pagemap (l.pageno, gen) pageopaque;
2056 begin match state.throttle with
2057 | None ->
2058 let preloadedpages =
2059 if conf.preload
2060 then preloadlayout state.layout
2061 else state.layout
2063 let evict () =
2064 let module IntSet =
2065 Set.Make (struct type t = int let compare = (-) end) in
2066 let set =
2067 List.fold_left (fun s l -> IntSet.add l.pageno s)
2068 IntSet.empty preloadedpages
2070 let evictedpages =
2071 Hashtbl.fold (fun ((pageno, _) as key) opaque accu ->
2072 if not (IntSet.mem pageno set)
2073 then (
2074 wcmd "freepage %s" opaque;
2075 key :: accu
2077 else accu
2078 ) state.pagemap []
2080 List.iter (Hashtbl.remove state.pagemap) evictedpages;
2082 evict ();
2083 state.currently <- Idle;
2084 if gen = state.gen
2085 then (
2086 tilepage l.pageno pageopaque state.layout;
2087 load state.layout;
2088 load preloadedpages;
2089 if pagevisible state.layout l.pageno
2090 && layoutready state.layout
2091 then G.postRedisplay "page";
2094 | Some (layout, _, _) ->
2095 state.currently <- Idle;
2096 tilepage l.pageno pageopaque layout;
2097 load state.layout
2098 end;
2100 | _ ->
2101 dolog "Inconsistent loading state";
2102 logcurrently state.currently;
2103 exit 1
2106 | "tile" ->
2107 let (x, y, opaque, size, t) =
2109 Scanf.sscanf args "%u %u %s %u %f"
2110 (fun x y p size t -> (x, y, p, size, t))
2111 with exn ->
2112 dolog "error processing 'tile' %S: %s"
2113 cmds (Printexc.to_string exn);
2114 exit 1;
2116 begin match state.currently with
2117 | Tiling (l, pageopaque, cs, angle, gen, col, row, tilew, tileh) ->
2118 vlog "tile %d [%d,%d] took %f sec" l.pageno col row t;
2120 if tilew != conf.tilew || tileh != conf.tileh
2121 then (
2122 wcmd "freetile %s" opaque;
2123 state.currently <- Idle;
2124 load state.layout;
2126 else (
2127 puttileopaque l col row gen cs angle opaque size t;
2128 state.memused <- state.memused + size;
2129 state.uioh#infochanged Memused;
2130 gctiles ();
2131 Queue.push ((l.pageno, gen, cs, angle, l.pagew, l.pageh, col, row),
2132 opaque, size) state.tilelru;
2134 let layout =
2135 match state.throttle with
2136 | None -> state.layout
2137 | Some (layout, _, _) -> layout
2140 state.currently <- Idle;
2141 if gen = state.gen
2142 && conf.colorspace = cs
2143 && conf.angle = angle
2144 && tilevisible layout l.pageno x y
2145 then conttiling l.pageno pageopaque;
2147 begin match state.throttle with
2148 | None ->
2149 preload state.layout;
2150 if gen = state.gen
2151 && conf.colorspace = cs
2152 && conf.angle = angle
2153 && tilevisible state.layout l.pageno x y
2154 then G.postRedisplay "tile nothrottle";
2156 | Some (layout, y, _) ->
2157 let ready = layoutready layout in
2158 if ready
2159 then (
2160 state.y <- y;
2161 state.layout <- layout;
2162 state.throttle <- None;
2163 G.postRedisplay "throttle";
2165 else load layout;
2166 end;
2169 | _ ->
2170 dolog "Inconsistent tiling state";
2171 logcurrently state.currently;
2172 exit 1
2175 | "pdim" ->
2176 let pdim =
2178 Scanf.sscanf args "%u %u %u %u" (fun n w h x -> n, w, h, x)
2179 with exn ->
2180 dolog "error processing 'pdim' %S: %s"
2181 cmds (Printexc.to_string exn);
2182 exit 1;
2184 state.uioh#infochanged Pdim;
2185 state.pdims <- pdim :: state.pdims
2187 | "o" ->
2188 let (l, n, t, h, pos) =
2190 Scanf.sscanf args "%u %u %d %u %n"
2191 (fun l n t h pos -> l, n, t, h, pos)
2192 with exn ->
2193 dolog "error processing 'o' %S: %s"
2194 cmds (Printexc.to_string exn);
2195 exit 1;
2197 let s = String.sub args pos (String.length args - pos) in
2198 let outline = (s, l, (n, float t /. float h)) in
2199 begin match state.currently with
2200 | Outlining outlines ->
2201 state.currently <- Outlining (outline :: outlines)
2202 | Idle ->
2203 state.currently <- Outlining [outline]
2204 | currently ->
2205 dolog "invalid outlining state";
2206 logcurrently currently
2209 | "info" ->
2210 state.docinfo <- (1, args) :: state.docinfo
2212 | "infoend" ->
2213 state.uioh#infochanged Docinfo;
2214 state.docinfo <- List.rev state.docinfo
2216 | _ ->
2217 dolog "unknown cmd `%S'" cmds
2220 let onhist cb =
2221 let rc = cb.rc in
2222 let action = function
2223 | HCprev -> cbget cb ~-1
2224 | HCnext -> cbget cb 1
2225 | HCfirst -> cbget cb ~-(cb.rc)
2226 | HClast -> cbget cb (cb.len - 1 - cb.rc)
2227 and cancel () = cb.rc <- rc
2228 in (action, cancel)
2231 let search pattern forward =
2232 if String.length pattern > 0
2233 then
2234 let pn, py =
2235 match state.layout with
2236 | [] -> 0, 0
2237 | l :: _ ->
2238 l.pageno, (l.pagey + if forward then 0 else 0*l.pagevh)
2240 wcmd "search %d %d %d %d,%s\000"
2241 (btod conf.icase) pn py (btod forward) pattern;
2244 let intentry text key =
2245 let c =
2246 if key >= 32 && key < 127
2247 then Char.chr key
2248 else '\000'
2250 match c with
2251 | '0' .. '9' ->
2252 let text = addchar text c in
2253 TEcont text
2255 | _ ->
2256 state.text <- Printf.sprintf "invalid char (%d, `%c')" key c;
2257 TEcont text
2260 let textentry text key =
2261 if key land 0xff00 = 0xff00
2262 then TEcont text
2263 else TEcont (text ^ Wsi.toutf8 key)
2266 let reqlayout angle proportional =
2267 match state.throttle with
2268 | None ->
2269 if nogeomcmds state.geomcmds
2270 then state.anchor <- getanchor ();
2271 conf.angle <- angle mod 360;
2272 if conf.angle != 0
2273 then (
2274 match state.mode with
2275 | LinkNav _ -> state.mode <- View
2276 | _ -> ()
2278 conf.proportional <- proportional;
2279 invalidate "reqlayout"
2280 (fun () -> wcmd "reqlayout %d %d" conf.angle (btod proportional));
2281 | _ -> ()
2284 let settrim trimmargins trimfuzz =
2285 if nogeomcmds state.geomcmds
2286 then state.anchor <- getanchor ();
2287 conf.trimmargins <- trimmargins;
2288 conf.trimfuzz <- trimfuzz;
2289 let x0, y0, x1, y1 = trimfuzz in
2290 invalidate "settrim"
2291 (fun () ->
2292 wcmd "settrim %d %d %d %d %d" (btod conf.trimmargins) x0 y0 x1 y1);
2293 Hashtbl.iter (fun _ opaque ->
2294 wcmd "freepage %s" opaque;
2295 ) state.pagemap;
2296 Hashtbl.clear state.pagemap;
2299 let setzoom zoom =
2300 match state.throttle with
2301 | None ->
2302 let zoom = max 0.01 zoom in
2303 if zoom <> conf.zoom
2304 then (
2305 state.prevzoom <- conf.zoom;
2306 conf.zoom <- zoom;
2307 reshape conf.winw conf.winh;
2308 state.text <- Printf.sprintf "zoom is now %-5.1f" (zoom *. 100.0);
2311 | Some (layout, y, started) ->
2312 let time =
2313 match conf.maxwait with
2314 | None -> 0.0
2315 | Some t -> t
2317 let dt = now () -. started in
2318 if dt > time
2319 then (
2320 state.y <- y;
2321 load layout;
2325 let setcolumns columns coverA coverB =
2326 if columns < 2
2327 then (
2328 conf.columns <- None;
2329 state.x <- 0;
2330 setzoom 1.0;
2332 else (
2333 conf.columns <- Some ((columns, coverA, coverB), [||]);
2334 conf.zoom <- 1.0;
2336 reshape conf.winw conf.winh;
2339 let enterbirdseye () =
2340 let zoom = float conf.thumbw /. float conf.winw in
2341 let birdseyepageno =
2342 let cy = conf.winh / 2 in
2343 let fold = function
2344 | [] -> 0
2345 | l :: rest ->
2346 let rec fold best = function
2347 | [] -> best.pageno
2348 | l :: rest ->
2349 let d = cy - (l.pagedispy + l.pagevh/2)
2350 and dbest = cy - (best.pagedispy + best.pagevh/2) in
2351 if abs d < abs dbest
2352 then fold l rest
2353 else best.pageno
2354 in fold l rest
2356 fold state.layout
2358 state.mode <- Birdseye (
2359 { conf with zoom = conf.zoom }, state.x, birdseyepageno, -1, getanchor ()
2361 conf.zoom <- zoom;
2362 conf.presentation <- false;
2363 conf.interpagespace <- 10;
2364 conf.hlinks <- false;
2365 state.x <- 0;
2366 state.mstate <- Mnone;
2367 conf.maxwait <- None;
2368 conf.columns <- (
2369 match conf.beyecolumns with
2370 | Some c ->
2371 conf.zoom <- 1.0;
2372 Some ((c, 0, 0), [||])
2373 | None -> None
2375 Wsi.setcursor Wsi.CURSOR_INHERIT;
2376 if conf.verbose
2377 then
2378 state.text <- Printf.sprintf "birds eye mode on (zoom %3.1f%%)"
2379 (100.0*.zoom)
2380 else
2381 state.text <- ""
2383 reshape conf.winw conf.winh;
2386 let leavebirdseye (c, leftx, pageno, _, anchor) goback =
2387 state.mode <- View;
2388 conf.zoom <- c.zoom;
2389 conf.presentation <- c.presentation;
2390 conf.interpagespace <- c.interpagespace;
2391 conf.maxwait <- c.maxwait;
2392 conf.hlinks <- c.hlinks;
2393 conf.beyecolumns <- (
2394 match conf.columns with
2395 | Some ((c, _, _), _) -> Some c
2396 | None -> None
2398 conf.columns <- (
2399 match c.columns with
2400 | Some (c, _) -> Some (c, [||])
2401 | None -> None
2403 state.x <- leftx;
2404 if conf.verbose
2405 then
2406 state.text <- Printf.sprintf "birds eye mode off (zoom %3.1f%%)"
2407 (100.0*.conf.zoom)
2409 reshape conf.winw conf.winh;
2410 state.anchor <- if goback then anchor else (pageno, 0.0);
2413 let togglebirdseye () =
2414 match state.mode with
2415 | Birdseye vals -> leavebirdseye vals true
2416 | View -> enterbirdseye ()
2417 | _ -> ()
2420 let upbirdseye incr (conf, leftx, pageno, hooverpageno, anchor) =
2421 let pageno = max 0 (pageno - incr) in
2422 let rec loop = function
2423 | [] -> gotopage1 pageno 0
2424 | l :: _ when l.pageno = pageno ->
2425 if l.pagedispy >= 0 && l.pagey = 0
2426 then G.postRedisplay "upbirdseye"
2427 else gotopage1 pageno 0
2428 | _ :: rest -> loop rest
2430 loop state.layout;
2431 state.mode <- Birdseye (conf, leftx, pageno, hooverpageno, anchor)
2434 let downbirdseye incr (conf, leftx, pageno, hooverpageno, anchor) =
2435 let pageno = min (state.pagecount - 1) (pageno + incr) in
2436 state.mode <- Birdseye (conf, leftx, pageno, hooverpageno, anchor);
2437 let rec loop = function
2438 | [] ->
2439 let y, h = getpageyh pageno in
2440 let dy = (y - state.y) - (conf.winh - h - conf.interpagespace) in
2441 gotoy (clamp dy)
2442 | l :: _ when l.pageno = pageno ->
2443 if l.pagevh != l.pageh
2444 then gotoy (clamp (l.pageh - l.pagevh + conf.interpagespace))
2445 else G.postRedisplay "downbirdseye"
2446 | _ :: rest -> loop rest
2448 loop state.layout
2451 let optentry mode _ key =
2452 let btos b = if b then "on" else "off" in
2453 if key >= 32 && key < 127
2454 then
2455 let c = Char.chr key in
2456 match c with
2457 | 's' ->
2458 let ondone s =
2459 try conf.scrollstep <- int_of_string s with exc ->
2460 state.text <- Printf.sprintf "bad integer `%s': %s"
2461 s (Printexc.to_string exc)
2463 TEswitch ("scroll step: ", "", None, intentry, ondone)
2465 | 'A' ->
2466 let ondone s =
2468 conf.autoscrollstep <- int_of_string s;
2469 if state.autoscroll <> None
2470 then state.autoscroll <- Some conf.autoscrollstep
2471 with exc ->
2472 state.text <- Printf.sprintf "bad integer `%s': %s"
2473 s (Printexc.to_string exc)
2475 TEswitch ("auto scroll step: ", "", None, intentry, ondone)
2477 | 'C' ->
2478 let ondone s =
2480 let n, a, b = columns_of_string s in
2481 setcolumns n a b;
2482 with exc ->
2483 state.text <- Printf.sprintf "bad columns `%s': %s"
2484 s (Printexc.to_string exc)
2486 TEswitch ("columns: ", "", None, textentry, ondone)
2488 | 'Z' ->
2489 let ondone s =
2491 let zoom = float (int_of_string s) /. 100.0 in
2492 setzoom zoom
2493 with exc ->
2494 state.text <- Printf.sprintf "bad integer `%s': %s"
2495 s (Printexc.to_string exc)
2497 TEswitch ("zoom: ", "", None, intentry, ondone)
2499 | 't' ->
2500 let ondone s =
2502 conf.thumbw <- bound (int_of_string s) 2 4096;
2503 state.text <-
2504 Printf.sprintf "thumbnail width is set to %d" conf.thumbw;
2505 begin match mode with
2506 | Birdseye beye ->
2507 leavebirdseye beye false;
2508 enterbirdseye ();
2509 | _ -> ();
2511 with exc ->
2512 state.text <- Printf.sprintf "bad integer `%s': %s"
2513 s (Printexc.to_string exc)
2515 TEswitch ("thumbnail width: ", "", None, intentry, ondone)
2517 | 'R' ->
2518 let ondone s =
2519 match try
2520 Some (int_of_string s)
2521 with exc ->
2522 state.text <- Printf.sprintf "bad integer `%s': %s"
2523 s (Printexc.to_string exc);
2524 None
2525 with
2526 | Some angle -> reqlayout angle conf.proportional
2527 | None -> ()
2529 TEswitch ("rotation: ", "", None, intentry, ondone)
2531 | 'i' ->
2532 conf.icase <- not conf.icase;
2533 TEdone ("case insensitive search " ^ (btos conf.icase))
2535 | 'p' ->
2536 conf.preload <- not conf.preload;
2537 gotoy state.y;
2538 TEdone ("preload " ^ (btos conf.preload))
2540 | 'v' ->
2541 conf.verbose <- not conf.verbose;
2542 TEdone ("verbose " ^ (btos conf.verbose))
2544 | 'd' ->
2545 conf.debug <- not conf.debug;
2546 TEdone ("debug " ^ (btos conf.debug))
2548 | 'h' ->
2549 conf.maxhfit <- not conf.maxhfit;
2550 state.maxy <-
2551 state.maxy + (if conf.maxhfit then -conf.winh else conf.winh);
2552 TEdone ("maxhfit " ^ (btos conf.maxhfit))
2554 | 'c' ->
2555 conf.crophack <- not conf.crophack;
2556 TEdone ("crophack " ^ btos conf.crophack)
2558 | 'a' ->
2559 let s =
2560 match conf.maxwait with
2561 | None ->
2562 conf.maxwait <- Some infinity;
2563 "always wait for page to complete"
2564 | Some _ ->
2565 conf.maxwait <- None;
2566 "show placeholder if page is not ready"
2568 TEdone s
2570 | 'f' ->
2571 conf.underinfo <- not conf.underinfo;
2572 TEdone ("underinfo " ^ btos conf.underinfo)
2574 | 'P' ->
2575 conf.savebmarks <- not conf.savebmarks;
2576 TEdone ("persistent bookmarks " ^ btos conf.savebmarks)
2578 | 'S' ->
2579 let ondone s =
2581 let pageno, py =
2582 match state.layout with
2583 | [] -> 0, 0
2584 | l :: _ ->
2585 l.pageno, l.pagey
2587 conf.interpagespace <- int_of_string s;
2588 state.maxy <- calcheight ();
2589 let y = getpagey pageno in
2590 gotoy (y + py)
2591 with exc ->
2592 state.text <- Printf.sprintf "bad integer `%s': %s"
2593 s (Printexc.to_string exc)
2595 TEswitch ("vertical margin: ", "", None, intentry, ondone)
2597 | 'l' ->
2598 reqlayout conf.angle (not conf.proportional);
2599 TEdone ("proportional display " ^ btos conf.proportional)
2601 | 'T' ->
2602 settrim (not conf.trimmargins) conf.trimfuzz;
2603 TEdone ("trim margins " ^ btos conf.trimmargins)
2605 | 'I' ->
2606 conf.invert <- not conf.invert;
2607 TEdone ("invert colors " ^ btos conf.invert)
2609 | 'x' ->
2610 let ondone s =
2611 cbput state.hists.sel s;
2612 conf.selcmd <- s;
2614 TEswitch ("selection command: ", "", Some (onhist state.hists.sel),
2615 textentry, ondone)
2617 | _ ->
2618 state.text <- Printf.sprintf "bad option %d `%c'" key c;
2619 TEstop
2620 else
2621 TEcont state.text
2624 class type lvsource = object
2625 method getitemcount : int
2626 method getitem : int -> (string * int)
2627 method hasaction : int -> bool
2628 method exit :
2629 uioh:uioh ->
2630 cancel:bool ->
2631 active:int ->
2632 first:int ->
2633 pan:int ->
2634 qsearch:string ->
2635 uioh option
2636 method getactive : int
2637 method getfirst : int
2638 method getqsearch : string
2639 method setqsearch : string -> unit
2640 method getpan : int
2641 end;;
2643 class virtual lvsourcebase = object
2644 val mutable m_active = 0
2645 val mutable m_first = 0
2646 val mutable m_qsearch = ""
2647 val mutable m_pan = 0
2648 method getactive = m_active
2649 method getfirst = m_first
2650 method getqsearch = m_qsearch
2651 method getpan = m_pan
2652 method setqsearch s = m_qsearch <- s
2653 end;;
2655 let withoutlastutf8 s =
2656 let len = String.length s in
2657 if len = 0
2658 then s
2659 else
2660 let rec find pos =
2661 if pos = 0
2662 then pos
2663 else
2664 let b = Char.code s.[pos] in
2665 if b land 0b110000 = 0b11000000
2666 then find (pos-1)
2667 else pos-1
2669 let first =
2670 if Char.code s.[len-1] land 0x80 = 0
2671 then len-1
2672 else find (len-1)
2674 String.sub s 0 first;
2677 let textentrykeyboard key _mask ((c, text, opthist, onkey, ondone), onleave) =
2678 let enttext te =
2679 state.mode <- Textentry (te, onleave);
2680 state.text <- "";
2681 enttext ();
2682 G.postRedisplay "textentrykeyboard enttext";
2684 let histaction cmd =
2685 match opthist with
2686 | None -> ()
2687 | Some (action, _) ->
2688 state.mode <- Textentry (
2689 (c, action cmd, opthist, onkey, ondone), onleave
2691 G.postRedisplay "textentry histaction"
2693 match key with
2694 | 0xff08 -> (* backspace *)
2695 let s = withoutlastutf8 text in
2696 let len = String.length s in
2697 if len = 0
2698 then (
2699 onleave Cancel;
2700 G.postRedisplay "textentrykeyboard after cancel";
2702 else (
2703 enttext (c, s, opthist, onkey, ondone)
2706 | 0xff0d ->
2707 ondone text;
2708 onleave Confirm;
2709 G.postRedisplay "textentrykeyboard after confirm"
2711 | 0xff52 -> histaction HCprev
2712 | 0xff54 -> histaction HCnext
2713 | 0xff50 -> histaction HCfirst
2714 | 0xff57 -> histaction HClast
2716 | 0xff1b -> (* escape*)
2717 if String.length text = 0
2718 then (
2719 begin match opthist with
2720 | None -> ()
2721 | Some (_, onhistcancel) -> onhistcancel ()
2722 end;
2723 onleave Cancel;
2724 state.text <- "";
2725 G.postRedisplay "textentrykeyboard after cancel2"
2727 else (
2728 enttext (c, "", opthist, onkey, ondone)
2731 | 0xff9f | 0xffff -> () (* delete *)
2733 | _ when key != 0 && key land 0xff00 != 0xff00 ->
2734 begin match onkey text key with
2735 | TEdone text ->
2736 ondone text;
2737 onleave Confirm;
2738 G.postRedisplay "textentrykeyboard after confirm2";
2740 | TEcont text ->
2741 enttext (c, text, opthist, onkey, ondone);
2743 | TEstop ->
2744 onleave Cancel;
2745 G.postRedisplay "textentrykeyboard after cancel3"
2747 | TEswitch te ->
2748 state.mode <- Textentry (te, onleave);
2749 G.postRedisplay "textentrykeyboard switch";
2750 end;
2752 | _ ->
2753 vlog "unhandled key %s" (Wsi.keyname key)
2756 let firstof first active =
2757 if first > active || abs (first - active) > fstate.maxrows - 1
2758 then max 0 (active - (fstate.maxrows/2))
2759 else first
2762 let calcfirst first active =
2763 if active > first
2764 then
2765 let rows = active - first in
2766 if rows > fstate.maxrows then active - fstate.maxrows else first
2767 else active
2770 let scrollph y maxy =
2771 let sh = (float (maxy + conf.winh) /. float conf.winh) in
2772 let sh = float conf.winh /. sh in
2773 let sh = max sh (float conf.scrollh) in
2775 let percent =
2776 if y = state.maxy
2777 then 1.0
2778 else float y /. float maxy
2780 let position = (float conf.winh -. sh) *. percent in
2782 let position =
2783 if position +. sh > float conf.winh
2784 then float conf.winh -. sh
2785 else position
2787 position, sh;
2790 let coe s = (s :> uioh);;
2792 class listview ~(source:lvsource) ~trusted ~modehash =
2793 object (self)
2794 val m_pan = source#getpan
2795 val m_first = source#getfirst
2796 val m_active = source#getactive
2797 val m_qsearch = source#getqsearch
2798 val m_prev_uioh = state.uioh
2800 method private elemunder y =
2801 let n = y / (fstate.fontsize+1) in
2802 if m_first + n < source#getitemcount
2803 then (
2804 if source#hasaction (m_first + n)
2805 then Some (m_first + n)
2806 else None
2808 else None
2810 method display =
2811 Gl.enable `blend;
2812 GlFunc.blend_func `src_alpha `one_minus_src_alpha;
2813 GlDraw.color (0., 0., 0.) ~alpha:0.85;
2814 GlDraw.rect (0., 0.) (float conf.winw, float conf.winh);
2815 GlDraw.color (1., 1., 1.);
2816 Gl.enable `texture_2d;
2817 let fs = fstate.fontsize in
2818 let nfs = fs + 1 in
2819 let ww = fstate.wwidth in
2820 let tabw = 30.0*.ww in
2821 let itemcount = source#getitemcount in
2822 let rec loop row =
2823 if (row - m_first) * nfs > conf.winh
2824 then ()
2825 else (
2826 if row >= 0 && row < itemcount
2827 then (
2828 let (s, level) = source#getitem row in
2829 let y = (row - m_first) * nfs in
2830 let x = 5.0 +. float (level + m_pan) *. ww in
2831 if row = m_active
2832 then (
2833 Gl.disable `texture_2d;
2834 GlDraw.polygon_mode `both `line;
2835 GlDraw.color (1., 1., 1.) ~alpha:0.9;
2836 GlDraw.rect (1., float (y + 1))
2837 (float (conf.winw - conf.scrollbw - 1), float (y + fs + 3));
2838 GlDraw.polygon_mode `both `fill;
2839 GlDraw.color (1., 1., 1.);
2840 Gl.enable `texture_2d;
2843 let drawtabularstring s =
2844 let drawstr x s = drawstring1 fs (truncate x) (y+nfs) s in
2845 if trusted
2846 then
2847 let tabpos = try String.index s '\t' with Not_found -> -1 in
2848 if tabpos > 0
2849 then
2850 let len = String.length s - tabpos - 1 in
2851 let s1 = String.sub s 0 tabpos
2852 and s2 = String.sub s (tabpos + 1) len in
2853 let nx = drawstr x s1 in
2854 let sw = nx -. x in
2855 let x = x +. (max tabw sw) in
2856 drawstr x s2
2857 else
2858 drawstr x s
2859 else
2860 drawstr x s
2862 let _ = drawtabularstring s in
2863 loop (row+1)
2867 loop m_first;
2868 Gl.disable `blend;
2869 Gl.disable `texture_2d;
2871 method updownlevel incr =
2872 let len = source#getitemcount in
2873 let curlevel =
2874 if m_active >= 0 && m_active < len
2875 then snd (source#getitem m_active)
2876 else -1
2878 let rec flow i =
2879 if i = len then i-1 else if i = -1 then 0 else
2880 let _, l = source#getitem i in
2881 if l != curlevel then i else flow (i+incr)
2883 let active = flow m_active in
2884 let first = calcfirst m_first active in
2885 G.postRedisplay "outline updownlevel";
2886 {< m_active = active; m_first = first >}
2888 method private key1 key mask =
2889 let set1 active first qsearch =
2890 coe {< m_active = active; m_first = first; m_qsearch = qsearch >}
2892 let search active pattern incr =
2893 let dosearch re =
2894 let rec loop n =
2895 if n >= 0 && n < source#getitemcount
2896 then (
2897 let s, _ = source#getitem n in
2899 (try ignore (Str.search_forward re s 0); true
2900 with Not_found -> false)
2901 then Some n
2902 else loop (n + incr)
2904 else None
2906 loop active
2909 let re = Str.regexp_case_fold pattern in
2910 dosearch re
2911 with Failure s ->
2912 state.text <- s;
2913 None
2915 let itemcount = source#getitemcount in
2916 let find start incr =
2917 let rec find i =
2918 if i = -1 || i = itemcount
2919 then -1
2920 else (
2921 if source#hasaction i
2922 then i
2923 else find (i + incr)
2926 find start
2928 let set active first =
2929 let first = bound first 0 (itemcount - fstate.maxrows) in
2930 state.text <- "";
2931 coe {< m_active = active; m_first = first >}
2933 let navigate incr =
2934 let isvisible first n = n >= first && n - first <= fstate.maxrows in
2935 let active, first =
2936 let incr1 = if incr > 0 then 1 else -1 in
2937 if isvisible m_first m_active
2938 then
2939 let next =
2940 let next = m_active + incr in
2941 let next =
2942 if next < 0 || next >= itemcount
2943 then -1
2944 else find next incr1
2946 if next = -1 || abs (m_active - next) > fstate.maxrows
2947 then -1
2948 else next
2950 if next = -1
2951 then
2952 let first = m_first + incr in
2953 let first = bound first 0 (itemcount - 1) in
2954 let next =
2955 let next = m_active + incr in
2956 let next = bound next 0 (itemcount - 1) in
2957 find next ~-incr1
2959 let active = if next = -1 then m_active else next in
2960 active, first
2961 else
2962 let first = min next m_first in
2963 let first =
2964 if abs (next - first) > fstate.maxrows
2965 then first + incr
2966 else first
2968 next, first
2969 else
2970 let first = m_first + incr in
2971 let first = bound first 0 (itemcount - 1) in
2972 let active =
2973 let next = m_active + incr in
2974 let next = bound next 0 (itemcount - 1) in
2975 let next = find next incr1 in
2976 let active =
2977 if next = -1 || abs (m_active - first) > fstate.maxrows
2978 then (
2979 let active = if m_active = -1 then next else m_active in
2980 active
2982 else next
2984 if isvisible first active
2985 then active
2986 else -1
2988 active, first
2990 G.postRedisplay "listview navigate";
2991 set active first;
2993 match key with
2994 | (0x72|0x73) when Wsi.withctrl mask -> (* ctrl-r/ctlr-s *)
2995 let incr = if key = 0x72 then -1 else 1 in
2996 let active, first =
2997 match search (m_active + incr) m_qsearch incr with
2998 | None ->
2999 state.text <- m_qsearch ^ " [not found]";
3000 m_active, m_first
3001 | Some active ->
3002 state.text <- m_qsearch;
3003 active, firstof m_first active
3005 G.postRedisplay "listview ctrl-r/s";
3006 set1 active first m_qsearch;
3008 | 0xff08 -> (* backspace *)
3009 if String.length m_qsearch = 0
3010 then coe self
3011 else (
3012 let qsearch = withoutlastutf8 m_qsearch in
3013 let len = String.length qsearch in
3014 if len = 0
3015 then (
3016 state.text <- "";
3017 G.postRedisplay "listview empty qsearch";
3018 set1 m_active m_first "";
3020 else
3021 let active, first =
3022 match search m_active qsearch ~-1 with
3023 | None ->
3024 state.text <- qsearch ^ " [not found]";
3025 m_active, m_first
3026 | Some active ->
3027 state.text <- qsearch;
3028 active, firstof m_first active
3030 G.postRedisplay "listview backspace qsearch";
3031 set1 active first qsearch
3034 | key when (key != 0 && key land 0xff00 != 0xff00) ->
3035 let pattern = m_qsearch ^ Wsi.toutf8 key in
3036 let active, first =
3037 match search m_active pattern 1 with
3038 | None ->
3039 state.text <- pattern ^ " [not found]";
3040 m_active, m_first
3041 | Some active ->
3042 state.text <- pattern;
3043 active, firstof m_first active
3045 G.postRedisplay "listview qsearch add";
3046 set1 active first pattern;
3048 | 0xff1b -> (* escape *)
3049 state.text <- "";
3050 if String.length m_qsearch = 0
3051 then (
3052 G.postRedisplay "list view escape";
3053 begin
3054 match
3055 source#exit (coe self) true m_active m_first m_pan m_qsearch
3056 with
3057 | None -> m_prev_uioh
3058 | Some uioh -> uioh
3061 else (
3062 G.postRedisplay "list view kill qsearch";
3063 source#setqsearch "";
3064 coe {< m_qsearch = "" >}
3067 | 0xff0d -> (* return *)
3068 state.text <- "";
3069 let self = {< m_qsearch = "" >} in
3070 source#setqsearch "";
3071 let opt =
3072 G.postRedisplay "listview enter";
3073 if m_active >= 0 && m_active < source#getitemcount
3074 then (
3075 source#exit (coe self) false m_active m_first m_pan "";
3077 else (
3078 source#exit (coe self) true m_active m_first m_pan "";
3081 begin match opt with
3082 | None -> m_prev_uioh
3083 | Some uioh -> uioh
3086 | 0xff9f | 0xffff -> (* delete *)
3087 coe self
3089 | 0xff52 -> navigate ~-1 (* up *)
3090 | 0xff54 -> navigate 1 (* down *)
3091 | 0xff55 -> navigate ~-(fstate.maxrows) (* prior *)
3092 | 0xff56 -> navigate fstate.maxrows (* next *)
3094 | 0xff53 -> (* right *)
3095 state.text <- "";
3096 G.postRedisplay "listview right";
3097 coe {< m_pan = m_pan - 1 >}
3099 | 0xff51 -> (* left *)
3100 state.text <- "";
3101 G.postRedisplay "listview left";
3102 coe {< m_pan = m_pan + 1 >}
3104 | 0xff50 -> (* home *)
3105 let active = find 0 1 in
3106 G.postRedisplay "listview home";
3107 set active 0;
3109 | 0xff57 -> (* end *)
3110 let first = max 0 (itemcount - fstate.maxrows) in
3111 let active = find (itemcount - 1) ~-1 in
3112 G.postRedisplay "listview end";
3113 set active first;
3115 | key when (key = 0 || key land 0xff00 = 0xff00) ->
3116 coe self
3118 | _ ->
3119 dolog "listview unknown key %#x" key; coe self
3121 method key key mask =
3122 match state.mode with
3123 | Textentry te -> textentrykeyboard key mask te; coe self
3124 | _ -> self#key1 key mask
3126 method button button down x y _ =
3127 let opt =
3128 match button with
3129 | 1 when x > conf.winw - conf.scrollbw ->
3130 G.postRedisplay "listview scroll";
3131 if down
3132 then
3133 let _, position, sh = self#scrollph in
3134 if y > truncate position && y < truncate (position +. sh)
3135 then (
3136 state.mstate <- Mscrolly;
3137 Some (coe self)
3139 else
3140 let s = float (max 0 (y - conf.scrollh)) /. float conf.winh in
3141 let first = truncate (s *. float source#getitemcount) in
3142 let first = min source#getitemcount first in
3143 Some (coe {< m_first = first; m_active = first >})
3144 else (
3145 state.mstate <- Mnone;
3146 Some (coe self);
3148 | 1 when not down ->
3149 begin match self#elemunder y with
3150 | Some n ->
3151 G.postRedisplay "listview click";
3152 source#exit
3153 (coe {< m_active = n >}) false n m_first m_pan m_qsearch
3154 | _ ->
3155 Some (coe self)
3157 | n when (n == 4 || n == 5) && not down ->
3158 let len = source#getitemcount in
3159 let first =
3160 if n = 5 && m_first + fstate.maxrows >= len
3161 then
3162 m_first
3163 else
3164 let first = m_first + (if n == 4 then -1 else 1) in
3165 bound first 0 (len - 1)
3167 G.postRedisplay "listview wheel";
3168 Some (coe {< m_first = first >})
3169 | _ ->
3170 Some (coe self)
3172 match opt with
3173 | None -> m_prev_uioh
3174 | Some uioh -> uioh
3176 method motion _ y =
3177 match state.mstate with
3178 | Mscrolly ->
3179 let s = float (max 0 (y - conf.scrollh)) /. float conf.winh in
3180 let first = truncate (s *. float source#getitemcount) in
3181 let first = min source#getitemcount first in
3182 G.postRedisplay "listview motion";
3183 coe {< m_first = first; m_active = first >}
3184 | _ -> coe self
3186 method pmotion x y =
3187 if x < conf.winw - conf.scrollbw
3188 then
3189 let n =
3190 match self#elemunder y with
3191 | None -> Wsi.setcursor Wsi.CURSOR_INHERIT; m_active
3192 | Some n -> Wsi.setcursor Wsi.CURSOR_INFO; n
3194 let o =
3195 if n != m_active
3196 then (G.postRedisplay "listview pmotion"; {< m_active = n >})
3197 else self
3199 coe o
3200 else (
3201 Wsi.setcursor Wsi.CURSOR_INHERIT;
3202 coe self
3205 method infochanged _ = ()
3207 method scrollpw = (0, 0.0, 0.0)
3208 method scrollph =
3209 let nfs = fstate.fontsize + 1 in
3210 let y = m_first * nfs in
3211 let itemcount = source#getitemcount in
3212 let maxi = max 0 (itemcount - fstate.maxrows) in
3213 let maxy = maxi * nfs in
3214 let p, h = scrollph y maxy in
3215 conf.scrollbw, p, h
3217 method modehash = modehash
3218 end;;
3220 class outlinelistview ~source =
3221 object (self)
3222 inherit listview
3223 ~source:(source :> lvsource)
3224 ~trusted:false
3225 ~modehash:(findkeyhash conf "outline")
3226 as super
3228 method key key mask =
3229 let calcfirst first active =
3230 if active > first
3231 then
3232 let rows = active - first in
3233 if rows > fstate.maxrows then active - fstate.maxrows else first
3234 else active
3236 let navigate incr =
3237 let active = m_active + incr in
3238 let active = bound active 0 (source#getitemcount - 1) in
3239 let first = calcfirst m_first active in
3240 G.postRedisplay "outline navigate";
3241 coe {< m_active = active; m_first = first >}
3243 let ctrl = Wsi.withctrl mask in
3244 match key with
3245 | 110 when ctrl -> (* ctrl-n *)
3246 source#narrow m_qsearch;
3247 G.postRedisplay "outline ctrl-n";
3248 coe {< m_first = 0; m_active = 0 >}
3250 | 117 when ctrl -> (* ctrl-u *)
3251 source#denarrow;
3252 G.postRedisplay "outline ctrl-u";
3253 state.text <- "";
3254 coe {< m_first = 0; m_active = 0 >}
3256 | 108 when ctrl -> (* ctrl-l *)
3257 let first = m_active - (fstate.maxrows / 2) in
3258 G.postRedisplay "outline ctrl-l";
3259 coe {< m_first = first >}
3261 | 0xff9f | 0xffff -> (* delete *)
3262 source#remove m_active;
3263 G.postRedisplay "outline delete";
3264 let active = max 0 (m_active-1) in
3265 coe {< m_first = firstof m_first active;
3266 m_active = active >}
3268 | 0xff52 -> navigate ~-1 (* up *)
3269 | 0xff54 -> navigate 1 (* down *)
3270 | 0xff55 -> (* prior *)
3271 navigate ~-(fstate.maxrows)
3272 | 0xff56 -> (* next *)
3273 navigate fstate.maxrows
3275 | 0xff53 -> (* [ctrl-]right *)
3276 let o =
3277 if ctrl
3278 then (
3279 G.postRedisplay "outline ctrl right";
3280 {< m_pan = m_pan + 1 >}
3282 else self#updownlevel 1
3284 coe o
3286 | 0xff51 -> (* [ctrl-]left *)
3287 let o =
3288 if ctrl
3289 then (
3290 G.postRedisplay "outline ctrl left";
3291 {< m_pan = m_pan - 1 >}
3293 else self#updownlevel ~-1
3295 coe o
3297 | 0xff50 -> (* home *)
3298 G.postRedisplay "outline home";
3299 coe {< m_first = 0; m_active = 0 >}
3301 | 0xff57 -> (* end *)
3302 let active = source#getitemcount - 1 in
3303 let first = max 0 (active - fstate.maxrows) in
3304 G.postRedisplay "outline end";
3305 coe {< m_active = active; m_first = first >}
3307 | _ -> super#key key mask
3310 let outlinesource usebookmarks =
3311 let empty = [||] in
3312 (object
3313 inherit lvsourcebase
3314 val mutable m_items = empty
3315 val mutable m_orig_items = empty
3316 val mutable m_prev_items = empty
3317 val mutable m_narrow_pattern = ""
3318 val mutable m_hadremovals = false
3320 method getitemcount =
3321 Array.length m_items + (if m_hadremovals then 1 else 0)
3323 method getitem n =
3324 if n == Array.length m_items && m_hadremovals
3325 then
3326 ("[Confirm removal]", 0)
3327 else
3328 let s, n, _ = m_items.(n) in
3329 (s, n)
3331 method exit ~uioh ~cancel ~active ~first ~pan ~qsearch =
3332 ignore (uioh, first, qsearch);
3333 let confrimremoval = m_hadremovals && active = Array.length m_items in
3334 let items =
3335 if String.length m_narrow_pattern = 0
3336 then m_orig_items
3337 else m_items
3339 if not cancel
3340 then (
3341 if not confrimremoval
3342 then(
3343 let _, _, anchor = m_items.(active) in
3344 gotoanchor anchor;
3345 m_items <- items;
3347 else (
3348 state.bookmarks <- Array.to_list m_items;
3349 m_orig_items <- m_items;
3352 else m_items <- items;
3353 m_pan <- pan;
3354 None
3356 method hasaction _ = true
3358 method greetmsg =
3359 if Array.length m_items != Array.length m_orig_items
3360 then "Narrowed to " ^ m_narrow_pattern ^ " (ctrl-u to restore)"
3361 else ""
3363 method narrow pattern =
3364 let reopt = try Some (Str.regexp_case_fold pattern) with _ -> None in
3365 match reopt with
3366 | None -> ()
3367 | Some re ->
3368 let rec loop accu n =
3369 if n = -1
3370 then (
3371 m_narrow_pattern <- pattern;
3372 m_items <- Array.of_list accu
3374 else
3375 let (s, _, _) as o = m_items.(n) in
3376 let accu =
3377 if (try ignore (Str.search_forward re s 0); true
3378 with Not_found -> false)
3379 then o :: accu
3380 else accu
3382 loop accu (n-1)
3384 loop [] (Array.length m_items - 1)
3386 method denarrow =
3387 m_orig_items <- (
3388 if usebookmarks
3389 then Array.of_list state.bookmarks
3390 else state.outlines
3392 m_items <- m_orig_items
3394 method remove m =
3395 if usebookmarks
3396 then
3397 if m >= 0 && m < Array.length m_items
3398 then (
3399 m_hadremovals <- true;
3400 m_items <- Array.init (Array.length m_items - 1) (fun n ->
3401 let n = if n >= m then n+1 else n in
3402 m_items.(n)
3406 method reset anchor items =
3407 m_hadremovals <- false;
3408 if m_orig_items == empty || m_prev_items != items
3409 then (
3410 m_orig_items <- items;
3411 if String.length m_narrow_pattern = 0
3412 then m_items <- items;
3414 m_prev_items <- items;
3415 let rely = getanchory anchor in
3416 let active =
3417 let rec loop n best bestd =
3418 if n = Array.length m_items
3419 then best
3420 else
3421 let (_, _, anchor) = m_items.(n) in
3422 let orely = getanchory anchor in
3423 let d = abs (orely - rely) in
3424 if d < bestd
3425 then loop (n+1) n d
3426 else loop (n+1) best bestd
3428 loop 0 ~-1 max_int
3430 m_active <- active;
3431 m_first <- firstof m_first active
3432 end)
3435 let enterselector usebookmarks =
3436 let source = outlinesource usebookmarks in
3437 fun errmsg ->
3438 let outlines =
3439 if usebookmarks
3440 then Array.of_list state.bookmarks
3441 else state.outlines
3443 if Array.length outlines = 0
3444 then (
3445 showtext ' ' errmsg;
3447 else (
3448 state.text <- source#greetmsg;
3449 Wsi.setcursor Wsi.CURSOR_INHERIT;
3450 let anchor = getanchor () in
3451 source#reset anchor outlines;
3452 state.uioh <- coe (new outlinelistview ~source);
3453 G.postRedisplay "enter selector";
3457 let enteroutlinemode =
3458 let f = enterselector false in
3459 fun ()-> f "Document has no outline";
3462 let enterbookmarkmode =
3463 let f = enterselector true in
3464 fun () -> f "Document has no bookmarks (yet)";
3467 let color_of_string s =
3468 Scanf.sscanf s "%d/%d/%d" (fun r g b ->
3469 (float r /. 256.0, float g /. 256.0, float b /. 256.0)
3473 let color_to_string (r, g, b) =
3474 let r = truncate (r *. 256.0)
3475 and g = truncate (g *. 256.0)
3476 and b = truncate (b *. 256.0) in
3477 Printf.sprintf "%d/%d/%d" r g b
3480 let irect_of_string s =
3481 Scanf.sscanf s "%d/%d/%d/%d" (fun x0 y0 x1 y1 -> (x0,y0,x1,y1))
3484 let irect_to_string (x0,y0,x1,y1) =
3485 Printf.sprintf "%d/%d/%d/%d" x0 y0 x1 y1
3488 let makecheckers () =
3489 (* Appropriated from lablGL-1.04/LablGlut/examples/lablGL/checker.ml which had
3490 following to say:
3491 converted by Issac Trotts. July 25, 2002 *)
3492 let image_height = 64
3493 and image_width = 64 in
3495 let make_image () =
3496 let image =
3497 GlPix.create `ubyte ~format:`rgb ~width:image_width ~height:image_height
3499 for i = 0 to image_width - 1 do
3500 for j = 0 to image_height - 1 do
3501 Raw.sets (GlPix.to_raw image) ~pos:(3*(i*image_height+j))
3502 (if (i land 8 ) lxor (j land 8) = 0
3503 then [|255;255;255|] else [|200;200;200|])
3504 done
3505 done;
3506 image
3508 let image = make_image () in
3509 let id = GlTex.gen_texture () in
3510 GlTex.bind_texture `texture_2d id;
3511 GlPix.store (`unpack_alignment 1);
3512 GlTex.image2d image;
3513 List.iter (GlTex.parameter ~target:`texture_2d)
3514 [ `wrap_s `repeat;
3515 `wrap_t `repeat;
3516 `mag_filter `nearest;
3517 `min_filter `nearest ];
3521 let setcheckers enabled =
3522 match state.texid with
3523 | None ->
3524 if enabled then state.texid <- Some (makecheckers ())
3526 | Some texid ->
3527 if not enabled
3528 then (
3529 GlTex.delete_texture texid;
3530 state.texid <- None;
3534 let int_of_string_with_suffix s =
3535 let l = String.length s in
3536 let s1, shift =
3537 if l > 1
3538 then
3539 let suffix = Char.lowercase s.[l-1] in
3540 match suffix with
3541 | 'k' -> String.sub s 0 (l-1), 10
3542 | 'm' -> String.sub s 0 (l-1), 20
3543 | 'g' -> String.sub s 0 (l-1), 30
3544 | _ -> s, 0
3545 else s, 0
3547 let n = int_of_string s1 in
3548 let m = n lsl shift in
3549 if m < 0 || m < n
3550 then raise (Failure "value too large")
3551 else m
3554 let string_with_suffix_of_int n =
3555 if n = 0
3556 then "0"
3557 else
3558 let n, s =
3559 if n = 0
3560 then 0, ""
3561 else (
3562 if n land ((1 lsl 20) - 1) = 0
3563 then n lsr 20, "M"
3564 else (
3565 if n land ((1 lsl 10) - 1) = 0
3566 then n lsr 10, "K"
3567 else n, ""
3571 let rec loop s n =
3572 let h = n mod 1000 in
3573 let n = n / 1000 in
3574 if n = 0
3575 then string_of_int h ^ s
3576 else (
3577 let s = Printf.sprintf "_%03d%s" h s in
3578 loop s n
3581 loop "" n ^ s;
3584 let defghyllscroll = (40, 8, 32);;
3585 let ghyllscroll_of_string s =
3586 let (n, a, b) as nab =
3587 if s = "default"
3588 then defghyllscroll
3589 else Scanf.sscanf s "%u,%u,%u" (fun n a b -> n, a, b)
3591 if n <= a || n <= b || a >= b
3592 then failwith "invalid ghyll N,A,B (N <= A, A < B, N <= B)";
3593 nab;
3596 let ghyllscroll_to_string ((n, a, b) as nab) =
3597 if nab = defghyllscroll
3598 then "default"
3599 else Printf.sprintf "%d,%d,%d" n a b;
3602 let describe_location () =
3603 let f (fn, _) l =
3604 if fn = -1 then l.pageno, l.pageno else fn, l.pageno
3606 let fn, ln = List.fold_left f (-1, -1) state.layout in
3607 let maxy = state.maxy - (if conf.maxhfit then conf.winh else 0) in
3608 let percent =
3609 if maxy <= 0
3610 then 100.
3611 else (100. *. (float state.y /. float maxy))
3613 if fn = ln
3614 then
3615 Printf.sprintf "page %d of %d [%.2f%%]"
3616 (fn+1) state.pagecount percent
3617 else
3618 Printf.sprintf
3619 "pages %d-%d of %d [%.2f%%]"
3620 (fn+1) (ln+1) state.pagecount percent
3623 let enterinfomode =
3624 let btos b = if b then "\xe2\x88\x9a" else "" in
3625 let showextended = ref false in
3626 let leave mode = function
3627 | Confirm -> state.mode <- mode
3628 | Cancel -> state.mode <- mode in
3629 let src =
3630 (object
3631 val mutable m_first_time = true
3632 val mutable m_l = []
3633 val mutable m_a = [||]
3634 val mutable m_prev_uioh = nouioh
3635 val mutable m_prev_mode = View
3637 inherit lvsourcebase
3639 method reset prev_mode prev_uioh =
3640 m_a <- Array.of_list (List.rev m_l);
3641 m_l <- [];
3642 m_prev_mode <- prev_mode;
3643 m_prev_uioh <- prev_uioh;
3644 if m_first_time
3645 then (
3646 let rec loop n =
3647 if n >= Array.length m_a
3648 then ()
3649 else
3650 match m_a.(n) with
3651 | _, _, _, Action _ -> m_active <- n
3652 | _ -> loop (n+1)
3654 loop 0;
3655 m_first_time <- false;
3658 method int name get set =
3659 m_l <-
3660 (name, `int get, 1, Action (
3661 fun u ->
3662 let ondone s =
3663 try set (int_of_string s)
3664 with exn ->
3665 state.text <- Printf.sprintf "bad integer `%s': %s"
3666 s (Printexc.to_string exn)
3668 state.text <- "";
3669 let te = name ^ ": ", "", None, intentry, ondone in
3670 state.mode <- Textentry (te, leave m_prev_mode);
3672 )) :: m_l
3674 method int_with_suffix name get set =
3675 m_l <-
3676 (name, `intws get, 1, Action (
3677 fun u ->
3678 let ondone s =
3679 try set (int_of_string_with_suffix s)
3680 with exn ->
3681 state.text <- Printf.sprintf "bad integer `%s': %s"
3682 s (Printexc.to_string exn)
3684 state.text <- "";
3685 let te =
3686 name ^ ": ", "", None, intentry_with_suffix, ondone
3688 state.mode <- Textentry (te, leave m_prev_mode);
3690 )) :: m_l
3692 method bool ?(offset=1) ?(btos=btos) name get set =
3693 m_l <-
3694 (name, `bool (btos, get), offset, Action (
3695 fun u ->
3696 let v = get () in
3697 set (not v);
3699 )) :: m_l
3701 method color name get set =
3702 m_l <-
3703 (name, `color get, 1, Action (
3704 fun u ->
3705 let invalid = (nan, nan, nan) in
3706 let ondone s =
3707 let c =
3708 try color_of_string s
3709 with exn ->
3710 state.text <- Printf.sprintf "bad color `%s': %s"
3711 s (Printexc.to_string exn);
3712 invalid
3714 if c <> invalid
3715 then set c;
3717 let te = name ^ ": ", "", None, textentry, ondone in
3718 state.text <- color_to_string (get ());
3719 state.mode <- Textentry (te, leave m_prev_mode);
3721 )) :: m_l
3723 method string name get set =
3724 m_l <-
3725 (name, `string get, 1, Action (
3726 fun u ->
3727 let ondone s = set s in
3728 let te = name ^ ": ", "", None, textentry, ondone in
3729 state.mode <- Textentry (te, leave m_prev_mode);
3731 )) :: m_l
3733 method colorspace name get set =
3734 m_l <-
3735 (name, `string get, 1, Action (
3736 fun _ ->
3737 let source =
3738 let vals = [| "rgb"; "bgr"; "gray" |] in
3739 (object
3740 inherit lvsourcebase
3742 initializer
3743 m_active <- int_of_colorspace conf.colorspace;
3744 m_first <- 0;
3746 method getitemcount = Array.length vals
3747 method getitem n = (vals.(n), 0)
3748 method exit ~uioh ~cancel ~active ~first ~pan ~qsearch =
3749 ignore (uioh, first, pan, qsearch);
3750 if not cancel then set active;
3751 None
3752 method hasaction _ = true
3753 end)
3755 state.text <- "";
3756 let modehash = findkeyhash conf "info" in
3757 coe (new listview ~source ~trusted:true ~modehash)
3758 )) :: m_l
3760 method caption s offset =
3761 m_l <- (s, `empty, offset, Noaction) :: m_l
3763 method caption2 s f offset =
3764 m_l <- (s, `string f, offset, Noaction) :: m_l
3766 method getitemcount = Array.length m_a
3768 method getitem n =
3769 let tostr = function
3770 | `int f -> string_of_int (f ())
3771 | `intws f -> string_with_suffix_of_int (f ())
3772 | `string f -> f ()
3773 | `color f -> color_to_string (f ())
3774 | `bool (btos, f) -> btos (f ())
3775 | `empty -> ""
3777 let name, t, offset, _ = m_a.(n) in
3778 ((let s = tostr t in
3779 if String.length s > 0
3780 then Printf.sprintf "%s\t%s" name s
3781 else name),
3782 offset)
3784 method exit ~uioh ~cancel ~active ~first ~pan ~qsearch =
3785 let uiohopt =
3786 if not cancel
3787 then (
3788 m_qsearch <- qsearch;
3789 let uioh =
3790 match m_a.(active) with
3791 | _, _, _, Action f -> f uioh
3792 | _ -> uioh
3794 Some uioh
3796 else None
3798 m_active <- active;
3799 m_first <- first;
3800 m_pan <- pan;
3801 uiohopt
3803 method hasaction n =
3804 match m_a.(n) with
3805 | _, _, _, Action _ -> true
3806 | _ -> false
3807 end)
3809 let rec fillsrc prevmode prevuioh =
3810 let sep () = src#caption "" 0 in
3811 let colorp name get set =
3812 src#string name
3813 (fun () -> color_to_string (get ()))
3814 (fun v ->
3816 let c = color_of_string v in
3817 set c
3818 with exn ->
3819 state.text <- Printf.sprintf "bad color `%s': %s"
3820 v (Printexc.to_string exn);
3823 let oldmode = state.mode in
3824 let birdseye = isbirdseye state.mode in
3826 src#caption (if birdseye then "Setup (Bird's eye)" else "Setup") 0;
3828 src#bool "presentation mode"
3829 (fun () -> conf.presentation)
3830 (fun v ->
3831 conf.presentation <- v;
3832 state.anchor <- getanchor ();
3833 represent ());
3835 src#bool "ignore case in searches"
3836 (fun () -> conf.icase)
3837 (fun v -> conf.icase <- v);
3839 src#bool "preload"
3840 (fun () -> conf.preload)
3841 (fun v -> conf.preload <- v);
3843 src#bool "highlight links"
3844 (fun () -> conf.hlinks)
3845 (fun v -> conf.hlinks <- v);
3847 src#bool "under info"
3848 (fun () -> conf.underinfo)
3849 (fun v -> conf.underinfo <- v);
3851 src#bool "persistent bookmarks"
3852 (fun () -> conf.savebmarks)
3853 (fun v -> conf.savebmarks <- v);
3855 src#bool "proportional display"
3856 (fun () -> conf.proportional)
3857 (fun v -> reqlayout conf.angle v);
3859 src#bool "trim margins"
3860 (fun () -> conf.trimmargins)
3861 (fun v -> settrim v conf.trimfuzz; fillsrc prevmode prevuioh);
3863 src#bool "persistent location"
3864 (fun () -> conf.jumpback)
3865 (fun v -> conf.jumpback <- v);
3867 sep ();
3868 src#int "inter-page space"
3869 (fun () -> conf.interpagespace)
3870 (fun n ->
3871 conf.interpagespace <- n;
3872 let pageno, py =
3873 match state.layout with
3874 | [] -> 0, 0
3875 | l :: _ ->
3876 l.pageno, l.pagey
3878 state.maxy <- calcheight ();
3879 let y = getpagey pageno in
3880 gotoy (y + py)
3883 src#int "page bias"
3884 (fun () -> conf.pagebias)
3885 (fun v -> conf.pagebias <- v);
3887 src#int "scroll step"
3888 (fun () -> conf.scrollstep)
3889 (fun n -> conf.scrollstep <- n);
3891 src#int "auto scroll step"
3892 (fun () ->
3893 match state.autoscroll with
3894 | Some step -> step
3895 | _ -> conf.autoscrollstep)
3896 (fun n ->
3897 if state.autoscroll <> None
3898 then state.autoscroll <- Some n;
3899 conf.autoscrollstep <- n);
3901 src#int "zoom"
3902 (fun () -> truncate (conf.zoom *. 100.))
3903 (fun v -> setzoom ((float v) /. 100.));
3905 src#int "rotation"
3906 (fun () -> conf.angle)
3907 (fun v -> reqlayout v conf.proportional);
3909 src#int "scroll bar width"
3910 (fun () -> state.scrollw)
3911 (fun v ->
3912 state.scrollw <- v;
3913 conf.scrollbw <- v;
3914 reshape conf.winw conf.winh;
3917 src#int "scroll handle height"
3918 (fun () -> conf.scrollh)
3919 (fun v -> conf.scrollh <- v;);
3921 src#int "thumbnail width"
3922 (fun () -> conf.thumbw)
3923 (fun v ->
3924 conf.thumbw <- min 4096 v;
3925 match oldmode with
3926 | Birdseye beye ->
3927 leavebirdseye beye false;
3928 enterbirdseye ()
3929 | _ -> ()
3932 src#string "columns"
3933 (fun () ->
3934 match conf.columns with
3935 | None -> "1"
3936 | Some (multicol, _) -> columns_to_string multicol)
3937 (fun v ->
3938 let n, a, b = columns_of_string v in
3939 setcolumns n a b);
3941 sep ();
3942 src#caption "Presentation mode" 0;
3943 src#bool "scrollbar visible"
3944 (fun () -> conf.scrollbarinpm)
3945 (fun v ->
3946 if v != conf.scrollbarinpm
3947 then (
3948 conf.scrollbarinpm <- v;
3949 if conf.presentation
3950 then (
3951 state.scrollw <- if v then conf.scrollbw else 0;
3952 reshape conf.winw conf.winh;
3957 sep ();
3958 src#caption "Pixmap cache" 0;
3959 src#int_with_suffix "size (advisory)"
3960 (fun () -> conf.memlimit)
3961 (fun v -> conf.memlimit <- v);
3963 src#caption2 "used"
3964 (fun () -> Printf.sprintf "%s bytes, %d tiles"
3965 (string_with_suffix_of_int state.memused)
3966 (Hashtbl.length state.tilemap)) 1;
3968 sep ();
3969 src#caption "Layout" 0;
3970 src#caption2 "Dimension"
3971 (fun () ->
3972 Printf.sprintf "%dx%d (virtual %dx%d)"
3973 conf.winw conf.winh
3974 state.w state.maxy)
3976 if conf.debug
3977 then
3978 src#caption2 "Position" (fun () ->
3979 Printf.sprintf "%dx%d" state.x state.y
3981 else
3982 src#caption2 "Visible" (fun () -> describe_location ()) 1
3985 sep ();
3986 src#bool ~offset:0 ~btos:(fun v -> if v then "(on)" else "(off)")
3987 "Save these parameters as global defaults at exit"
3988 (fun () -> conf.bedefault)
3989 (fun v -> conf.bedefault <- v)
3992 sep ();
3993 let btos b = if b then "\xc2\xab" else "\xc2\xbb" in
3994 src#bool ~offset:0 ~btos "Extended parameters"
3995 (fun () -> !showextended)
3996 (fun v -> showextended := v; fillsrc prevmode prevuioh);
3997 if !showextended
3998 then (
3999 src#bool "checkers"
4000 (fun () -> conf.checkers)
4001 (fun v -> conf.checkers <- v; setcheckers v);
4002 src#bool "update cursor"
4003 (fun () -> conf.updatecurs)
4004 (fun v -> conf.updatecurs <- v);
4005 src#bool "verbose"
4006 (fun () -> conf.verbose)
4007 (fun v -> conf.verbose <- v);
4008 src#bool "invert colors"
4009 (fun () -> conf.invert)
4010 (fun v -> conf.invert <- v);
4011 src#bool "max fit"
4012 (fun () -> conf.maxhfit)
4013 (fun v -> conf.maxhfit <- v);
4014 src#bool "redirect stderr"
4015 (fun () -> conf.redirectstderr)
4016 (fun v -> conf.redirectstderr <- v; redirectstderr ());
4017 src#string "uri launcher"
4018 (fun () -> conf.urilauncher)
4019 (fun v -> conf.urilauncher <- v);
4020 src#string "path launcher"
4021 (fun () -> conf.pathlauncher)
4022 (fun v -> conf.pathlauncher <- v);
4023 src#string "tile size"
4024 (fun () -> Printf.sprintf "%dx%d" conf.tilew conf.tileh)
4025 (fun v ->
4027 let w, h = Scanf.sscanf v "%dx%d" (fun w h -> w, h) in
4028 conf.tileh <- max 64 w;
4029 conf.tilew <- max 64 h;
4030 flushtiles ();
4031 with exn ->
4032 state.text <- Printf.sprintf "bad tile size `%s': %s"
4033 v (Printexc.to_string exn));
4034 src#int "texture count"
4035 (fun () -> conf.texcount)
4036 (fun v ->
4037 if realloctexts v
4038 then conf.texcount <- v
4039 else showtext '!' " Failed to set texture count please retry later"
4041 src#int "slice height"
4042 (fun () -> conf.sliceheight)
4043 (fun v ->
4044 conf.sliceheight <- v;
4045 wcmd "sliceh %d" conf.sliceheight;
4047 src#int "anti-aliasing level"
4048 (fun () -> conf.aalevel)
4049 (fun v ->
4050 conf.aalevel <- bound v 0 8;
4051 state.anchor <- getanchor ();
4052 opendoc state.path state.password;
4054 src#int "ui font size"
4055 (fun () -> fstate.fontsize)
4056 (fun v -> setfontsize (bound v 5 100));
4057 colorp "background color"
4058 (fun () -> conf.bgcolor)
4059 (fun v -> conf.bgcolor <- v);
4060 src#bool "crop hack"
4061 (fun () -> conf.crophack)
4062 (fun v -> conf.crophack <- v);
4063 src#string "trim fuzz"
4064 (fun () -> irect_to_string conf.trimfuzz)
4065 (fun v ->
4067 conf.trimfuzz <- irect_of_string v;
4068 if conf.trimmargins
4069 then settrim true conf.trimfuzz;
4070 with exn ->
4071 state.text <- Printf.sprintf "bad irect `%s': %s"
4072 v (Printexc.to_string exn)
4074 src#string "throttle"
4075 (fun () ->
4076 match conf.maxwait with
4077 | None -> "show place holder if page is not ready"
4078 | Some time ->
4079 if time = infinity
4080 then "wait for page to fully render"
4081 else
4082 "wait " ^ string_of_float time
4083 ^ " seconds before showing placeholder"
4085 (fun v ->
4087 let f = float_of_string v in
4088 if f <= 0.0
4089 then conf.maxwait <- None
4090 else conf.maxwait <- Some f
4091 with exn ->
4092 state.text <- Printf.sprintf "bad time `%s': %s"
4093 v (Printexc.to_string exn)
4095 src#string "ghyll scroll"
4096 (fun () ->
4097 match conf.ghyllscroll with
4098 | None -> ""
4099 | Some nab -> ghyllscroll_to_string nab
4101 (fun v ->
4103 let gs =
4104 if String.length v = 0
4105 then None
4106 else Some (ghyllscroll_of_string v)
4108 conf.ghyllscroll <- gs
4109 with exn ->
4110 state.text <- Printf.sprintf "bad ghyll `%s': %s"
4111 v (Printexc.to_string exn)
4113 src#string "selection command"
4114 (fun () -> conf.selcmd)
4115 (fun v -> conf.selcmd <- v);
4116 src#colorspace "color space"
4117 (fun () -> colorspace_to_string conf.colorspace)
4118 (fun v ->
4119 conf.colorspace <- colorspace_of_int v;
4120 wcmd "cs %d" v;
4121 load state.layout;
4125 sep ();
4126 src#caption "Document" 0;
4127 List.iter (fun (_, s) -> src#caption s 1) state.docinfo;
4128 src#caption2 "Pages"
4129 (fun () -> string_of_int state.pagecount) 1;
4130 src#caption2 "Dimensions"
4131 (fun () -> string_of_int (List.length state.pdims)) 1;
4132 if conf.trimmargins
4133 then (
4134 sep ();
4135 src#caption "Trimmed margins" 0;
4136 src#caption2 "Dimensions"
4137 (fun () -> string_of_int (List.length state.pdims)) 1;
4140 src#reset prevmode prevuioh;
4142 fun () ->
4143 state.text <- "";
4144 let prevmode = state.mode
4145 and prevuioh = state.uioh in
4146 fillsrc prevmode prevuioh;
4147 let source = (src :> lvsource) in
4148 let modehash = findkeyhash conf "info" in
4149 state.uioh <- coe (object (self)
4150 inherit listview ~source ~trusted:true ~modehash as super
4151 val mutable m_prevmemused = 0
4152 method infochanged = function
4153 | Memused ->
4154 if m_prevmemused != state.memused
4155 then (
4156 m_prevmemused <- state.memused;
4157 G.postRedisplay "memusedchanged";
4159 | Pdim -> G.postRedisplay "pdimchanged"
4160 | Docinfo -> fillsrc prevmode prevuioh
4162 method key key mask =
4163 if not (Wsi.withctrl mask)
4164 then
4165 match key with
4166 | 0xff51 -> coe (self#updownlevel ~-1)
4167 | 0xff53 -> coe (self#updownlevel 1)
4168 | _ -> super#key key mask
4169 else super#key key mask
4170 end);
4171 G.postRedisplay "info";
4174 let enterhelpmode =
4175 let source =
4176 (object
4177 inherit lvsourcebase
4178 method getitemcount = Array.length state.help
4179 method getitem n =
4180 let s, n, _ = state.help.(n) in
4181 (s, n)
4183 method exit ~uioh ~cancel ~active ~first ~pan ~qsearch =
4184 let optuioh =
4185 if not cancel
4186 then (
4187 m_qsearch <- qsearch;
4188 match state.help.(active) with
4189 | _, _, Action f -> Some (f uioh)
4190 | _ -> Some (uioh)
4192 else None
4194 m_active <- active;
4195 m_first <- first;
4196 m_pan <- pan;
4197 optuioh
4199 method hasaction n =
4200 match state.help.(n) with
4201 | _, _, Action _ -> true
4202 | _ -> false
4204 initializer
4205 m_active <- -1
4206 end)
4207 in fun () ->
4208 let modehash = findkeyhash conf "help" in
4209 state.uioh <- coe (new listview ~source ~trusted:true ~modehash);
4210 G.postRedisplay "help";
4213 let entermsgsmode =
4214 let msgsource =
4215 let re = Str.regexp "[\r\n]" in
4216 (object
4217 inherit lvsourcebase
4218 val mutable m_items = [||]
4220 method getitemcount = 1 + Array.length m_items
4222 method getitem n =
4223 if n = 0
4224 then "[Clear]", 0
4225 else m_items.(n-1), 0
4227 method exit ~uioh ~cancel ~active ~first ~pan ~qsearch =
4228 ignore uioh;
4229 if not cancel
4230 then (
4231 if active = 0
4232 then Buffer.clear state.errmsgs;
4233 m_qsearch <- qsearch;
4235 m_active <- active;
4236 m_first <- first;
4237 m_pan <- pan;
4238 None
4240 method hasaction n =
4241 n = 0
4243 method reset =
4244 state.newerrmsgs <- false;
4245 let l = Str.split re (Buffer.contents state.errmsgs) in
4246 m_items <- Array.of_list l
4248 initializer
4249 m_active <- 0
4250 end)
4251 in fun () ->
4252 state.text <- "";
4253 msgsource#reset;
4254 let source = (msgsource :> lvsource) in
4255 let modehash = findkeyhash conf "listview" in
4256 state.uioh <- coe (object
4257 inherit listview ~source ~trusted:false ~modehash as super
4258 method display =
4259 if state.newerrmsgs
4260 then msgsource#reset;
4261 super#display
4262 end);
4263 G.postRedisplay "msgs";
4266 let quickbookmark ?title () =
4267 match state.layout with
4268 | [] -> ()
4269 | l :: _ ->
4270 let title =
4271 match title with
4272 | None ->
4273 let sec = Unix.gettimeofday () in
4274 let tm = Unix.localtime sec in
4275 Printf.sprintf "Quick (page %d) (bookmarked at %d/%d/%d %d:%d)"
4276 (l.pageno+1)
4277 tm.Unix.tm_mday
4278 tm.Unix.tm_mon
4279 (tm.Unix.tm_year + 1900)
4280 tm.Unix.tm_hour
4281 tm.Unix.tm_min
4282 | Some title -> title
4284 state.bookmarks <-
4285 (title, 0, (l.pageno, float l.pagey /. float l.pageh))
4286 :: state.bookmarks
4289 let doreshape w h =
4290 state.fullscreen <- None;
4291 Wsi.reshape w h;
4294 let setautoscrollspeed step goingdown =
4295 let incr = max 1 ((abs step) / 2) in
4296 let incr = if goingdown then incr else -incr in
4297 let astep = step + incr in
4298 state.autoscroll <- Some astep;
4301 let viewkeyboard key mask =
4302 let enttext te =
4303 let mode = state.mode in
4304 state.mode <- Textentry (te, fun _ -> state.mode <- mode);
4305 state.text <- "";
4306 enttext ();
4307 G.postRedisplay "view:enttext"
4309 let ctrl = Wsi.withctrl mask in
4310 match key with
4311 | 81 -> (* Q *)
4312 exit 0
4314 | 0xff63 -> (* insert *)
4315 if conf.angle mod 360 = 0
4316 then (
4317 state.mode <- LinkNav (Ltgendir 0);
4318 gotoy state.y;
4320 else showtext '!' "Keyboard link naviagtion does not work under rotation"
4322 | 0xff1b | 113 -> (* escape / q *)
4323 begin match state.mstate with
4324 | Mzoomrect _ ->
4325 state.mstate <- Mnone;
4326 Wsi.setcursor Wsi.CURSOR_INHERIT;
4327 G.postRedisplay "kill zoom rect";
4328 | _ ->
4329 match state.ranchors with
4330 | [] -> raise Quit
4331 | (path, password, anchor) :: rest ->
4332 state.ranchors <- rest;
4333 state.anchor <- anchor;
4334 opendoc path password
4335 end;
4337 | 0xff08 -> (* backspace *)
4338 let y = getnav ~-1 in
4339 gotoy_and_clear_text y
4341 | 111 -> (* o *)
4342 enteroutlinemode ()
4344 | 117 -> (* u *)
4345 state.rects <- [];
4346 state.text <- "";
4347 G.postRedisplay "dehighlight";
4349 | 47 | 63 -> (* / ? *)
4350 let ondone isforw s =
4351 cbput state.hists.pat s;
4352 state.searchpattern <- s;
4353 search s isforw
4355 let s = String.create 1 in
4356 s.[0] <- Char.chr key;
4357 enttext (s, "", Some (onhist state.hists.pat),
4358 textentry, ondone (key = 47))
4360 | 43 | 0xffab when ctrl -> (* ctrl-+ *)
4361 let incr = if conf.zoom +. 0.01 > 0.1 then 0.1 else 0.01 in
4362 setzoom (conf.zoom +. incr)
4364 | 43 | 0xffab -> (* + *)
4365 let ondone s =
4366 let n =
4367 try int_of_string s with exc ->
4368 state.text <- Printf.sprintf "bad integer `%s': %s"
4369 s (Printexc.to_string exc);
4370 max_int
4372 if n != max_int
4373 then (
4374 conf.pagebias <- n;
4375 state.text <- "page bias is now " ^ string_of_int n;
4378 enttext ("page bias: ", "", None, intentry, ondone)
4380 | 45 | 0xffad when ctrl -> (* ctrl-- *)
4381 let decr = if conf.zoom -. 0.1 < 0.1 then 0.01 else 0.1 in
4382 setzoom (max 0.01 (conf.zoom -. decr))
4384 | 45 | 0xffad -> (* - *)
4385 let ondone msg = state.text <- msg in
4386 enttext (
4387 "option [acfhilpstvxACPRSZTIS]: ", "", None,
4388 optentry state.mode, ondone
4391 | 48 when ctrl -> (* ctrl-0 *)
4392 setzoom 1.0
4394 | 49 when ctrl -> (* 1 *)
4395 let zoom = zoomforh conf.winw conf.winh state.scrollw in
4396 if zoom < 1.0
4397 then setzoom zoom
4399 | 0xffc6 -> (* f9 *)
4400 togglebirdseye ()
4402 | 57 when ctrl -> (* ctrl-9 *)
4403 togglebirdseye ()
4405 | (48 | 49 | 50 | 51 | 52 | 53 | 54 | 55 | 56 | 57)
4406 when not ctrl -> (* 0..9 *)
4407 let ondone s =
4408 let n =
4409 try int_of_string s with exc ->
4410 state.text <- Printf.sprintf "bad integer `%s': %s"
4411 s (Printexc.to_string exc);
4414 if n >= 0
4415 then (
4416 addnav ();
4417 cbput state.hists.pag (string_of_int n);
4418 gotopage1 (n + conf.pagebias - 1) 0;
4421 let pageentry text key =
4422 match Char.unsafe_chr key with
4423 | 'g' -> TEdone text
4424 | _ -> intentry text key
4426 let text = "x" in text.[0] <- Char.chr key;
4427 enttext (":", text, Some (onhist state.hists.pag), pageentry, ondone)
4429 | 98 -> (* b *)
4430 state.scrollw <- if state.scrollw > 0 then 0 else conf.scrollbw;
4431 reshape conf.winw conf.winh;
4433 | 108 -> (* l *)
4434 conf.hlinks <- not conf.hlinks;
4435 state.text <- "highlightlinks " ^ if conf.hlinks then "on" else "off";
4436 G.postRedisplay "toggle highlightlinks";
4438 | 97 -> (* a *)
4439 begin match state.autoscroll with
4440 | Some step ->
4441 conf.autoscrollstep <- step;
4442 state.autoscroll <- None
4443 | None ->
4444 if conf.autoscrollstep = 0
4445 then state.autoscroll <- Some 1
4446 else state.autoscroll <- Some conf.autoscrollstep
4449 | 80 -> (* P *)
4450 conf.presentation <- not conf.presentation;
4451 if conf.presentation
4452 then (
4453 if not conf.scrollbarinpm
4454 then state.scrollw <- 0;
4456 else
4457 state.scrollw <- conf.scrollbw;
4459 showtext ' ' ("presentation mode " ^
4460 if conf.presentation then "on" else "off");
4461 state.anchor <- getanchor ();
4462 represent ()
4464 | 102 -> (* f *)
4465 begin match state.fullscreen with
4466 | None ->
4467 state.fullscreen <- Some (conf.winw, conf.winh);
4468 Wsi.fullscreen ()
4469 | Some (w, h) ->
4470 state.fullscreen <- None;
4471 doreshape w h
4474 | 103 -> (* g *)
4475 gotoy_and_clear_text 0
4477 | 71 -> (* G *)
4478 gotopage1 (state.pagecount - 1) 0
4480 | 112 | 78 -> (* p|N *)
4481 search state.searchpattern false
4483 | 110 | 0xffc0 -> (* n|F3 *)
4484 search state.searchpattern true
4486 | 116 -> (* t *)
4487 begin match state.layout with
4488 | [] -> ()
4489 | l :: _ ->
4490 gotoy_and_clear_text (getpagey l.pageno)
4493 | 32 -> (* ' ' *)
4494 begin match List.rev state.layout with
4495 | [] -> ()
4496 | l :: _ ->
4497 let pageno = min (l.pageno+1) (state.pagecount-1) in
4498 gotoy_and_clear_text (getpagey pageno)
4501 | 0xff9f | 0xffff -> (* delete *)
4502 begin match state.layout with
4503 | [] -> ()
4504 | l :: _ ->
4505 let pageno = max 0 (l.pageno-1) in
4506 gotoy_and_clear_text (getpagey pageno)
4509 | 61 -> (* = *)
4510 showtext ' ' (describe_location ());
4512 | 119 -> (* w *)
4513 begin match state.layout with
4514 | [] -> ()
4515 | l :: _ ->
4516 doreshape (l.pagew + state.scrollw) l.pageh;
4517 G.postRedisplay "w"
4520 | 39 -> (* ' *)
4521 enterbookmarkmode ()
4523 | 104 | 0xffbe -> (* h|F1 *)
4524 enterhelpmode ()
4526 | 105 -> (* i *)
4527 enterinfomode ()
4529 | 101 when conf.redirectstderr -> (* e *)
4530 entermsgsmode ()
4532 | 109 -> (* m *)
4533 let ondone s =
4534 match state.layout with
4535 | l :: _ ->
4536 state.bookmarks <-
4537 (s, 0, (l.pageno, float l.pagey /. float l.pageh))
4538 :: state.bookmarks
4539 | _ -> ()
4541 enttext ("bookmark: ", "", None, textentry, ondone)
4543 | 126 -> (* ~ *)
4544 quickbookmark ();
4545 showtext ' ' "Quick bookmark added";
4547 | 122 -> (* z *)
4548 begin match state.layout with
4549 | l :: _ ->
4550 let rect = getpdimrect l.pagedimno in
4551 let w, h =
4552 if conf.crophack
4553 then
4554 (truncate (1.8 *. (rect.(1) -. rect.(0))),
4555 truncate (1.2 *. (rect.(3) -. rect.(0))))
4556 else
4557 (truncate (rect.(1) -. rect.(0)),
4558 truncate (rect.(3) -. rect.(0)))
4560 let w = truncate ((float w)*.conf.zoom)
4561 and h = truncate ((float h)*.conf.zoom) in
4562 if w != 0 && h != 0
4563 then (
4564 state.anchor <- getanchor ();
4565 doreshape (w + state.scrollw) (h + conf.interpagespace)
4567 G.postRedisplay "z";
4569 | [] -> ()
4572 | 50 when ctrl -> (* ctrl-2 *)
4573 let maxw = getmaxw () in
4574 if maxw > 0.0
4575 then setzoom (maxw /. float conf.winw)
4577 | 60 | 62 -> (* < > *)
4578 reqlayout (conf.angle + (if key = 62 then 30 else -30)) conf.proportional
4580 | 91 | 93 -> (* [ ] *)
4581 conf.colorscale <-
4582 bound (conf.colorscale +. (if key = 93 then 0.1 else -0.1)) 0.0 1.0
4584 G.postRedisplay "brightness";
4586 | 0xff54 | 0xff52 when ctrl && Wsi.withshift mask ->
4587 setzoom state.prevzoom
4589 | 107 | 0xff52 -> (* k up *)
4590 begin match state.autoscroll with
4591 | None ->
4592 begin match state.mode with
4593 | Birdseye beye -> upbirdseye 1 beye
4594 | _ ->
4595 if ctrl
4596 then gotoy_and_clear_text (clamp ~-(conf.winh/2))
4597 else gotoy_and_clear_text (clamp (-conf.scrollstep))
4599 | Some n ->
4600 setautoscrollspeed n false
4603 | 106 | 0xff54 -> (* j down *)
4604 begin match state.autoscroll with
4605 | None ->
4606 begin match state.mode with
4607 | Birdseye beye -> downbirdseye 1 beye
4608 | _ ->
4609 if ctrl
4610 then gotoy_and_clear_text (clamp (conf.winh/2))
4611 else gotoy_and_clear_text (clamp conf.scrollstep)
4613 | Some n ->
4614 setautoscrollspeed n true
4617 | 0xff51 | 0xff53 when not (Wsi.withalt mask) -> (* left / right *)
4618 if conf.zoom > 1.0
4619 then
4620 let dx =
4621 if ctrl
4622 then conf.winw / 2
4623 else 10
4625 let dx = if key = 0xff51 then dx else -dx in
4626 state.x <- state.x + dx;
4627 gotoy_and_clear_text state.y
4628 else (
4629 state.text <- "";
4630 G.postRedisplay "lef/right"
4633 | 0xff55 -> (* prior *)
4634 let y =
4635 if ctrl
4636 then
4637 match state.layout with
4638 | [] -> state.y
4639 | l :: _ -> state.y - l.pagey
4640 else
4641 clamp (-conf.winh)
4643 gotoghyll y
4645 | 0xff56 -> (* next *)
4646 let y =
4647 if ctrl
4648 then
4649 match List.rev state.layout with
4650 | [] -> state.y
4651 | l :: _ -> getpagey l.pageno
4652 else
4653 clamp conf.winh
4655 gotoghyll y
4657 | 0xff50 -> gotoghyll 0
4658 | 0xff57 -> gotoghyll (clamp state.maxy)
4659 | 0xff53 when Wsi.withalt mask ->
4660 gotoghyll (getnav ~-1)
4661 | 0xff51 when Wsi.withalt mask ->
4662 gotoghyll (getnav 1)
4664 | 114 -> (* r *)
4665 state.anchor <- getanchor ();
4666 opendoc state.path state.password
4668 | 76 -> (* L *)
4669 launchpath ()
4671 | 118 when conf.debug -> (* v *)
4672 state.rects <- [];
4673 List.iter (fun l ->
4674 match getopaque l.pageno with
4675 | None -> ()
4676 | Some opaque ->
4677 let x0, y0, x1, y1 = pagebbox opaque in
4678 let a,b = float x0, float y0 in
4679 let c,d = float x1, float y0 in
4680 let e,f = float x1, float y1 in
4681 let h,j = float x0, float y1 in
4682 let rect = (a,b,c,d,e,f,h,j) in
4683 debugrect rect;
4684 state.rects <- (l.pageno, l.pageno mod 3, rect) :: state.rects;
4685 ) state.layout;
4686 G.postRedisplay "v";
4688 | _ ->
4689 vlog "huh? %s" (Wsi.keyname key)
4692 let gotounder = function
4693 | Ulinkgoto (pageno, top) ->
4694 if pageno >= 0
4695 then (
4696 addnav ();
4697 gotopage1 pageno top;
4700 | Ulinkuri s ->
4701 gotouri s
4703 | Uremote (filename, pageno) ->
4704 let path =
4705 if Sys.file_exists filename
4706 then filename
4707 else
4708 let dir = Filename.dirname state.path in
4709 let path = Filename.concat dir filename in
4710 if Sys.file_exists path
4711 then path
4712 else ""
4714 if String.length path > 0
4715 then (
4716 let anchor = getanchor () in
4717 let ranchor = state.path, state.password, anchor in
4718 state.anchor <- (pageno, 0.0);
4719 state.ranchors <- ranchor :: state.ranchors;
4720 opendoc path "";
4722 else showtext '!' ("Could not find " ^ filename)
4724 | Uunexpected _ | Ulaunch _ | Unamed _ | Utext _ | Unone -> ()
4727 let linknavkeyboard key mask linknav =
4728 let getpage pageno =
4729 let rec loop = function
4730 | [] -> None
4731 | l :: _ when l.pageno = pageno -> Some l
4732 | _ :: rest -> loop rest
4733 in loop state.layout
4735 let doexact (pageno, n) =
4736 match getopaque pageno, getpage pageno with
4737 | Some opaque, Some l ->
4738 if key = 0xff0d
4739 then
4740 let under = getlink opaque n in
4741 G.postRedisplay "link gotounder";
4742 gotounder under;
4743 state.mode <- View;
4744 else
4745 let opt, dir =
4746 match key with
4747 | 0xff50 -> (* home *)
4748 Some (findlink opaque LDfirst), -1
4750 | 0xff57 -> (* end *)
4751 Some (findlink opaque LDlast), 1
4753 | 0xff51 -> (* left *)
4754 Some (findlink opaque (LDleft n)), -1
4756 | 0xff53 -> (* right *)
4757 Some (findlink opaque (LDright n)), 1
4759 | 0xff52 -> (* up *)
4760 Some (findlink opaque (LDup n)), -1
4762 | 0xff54 -> (* down *)
4763 Some (findlink opaque (LDdown n)), 1
4765 | _ -> None, 0
4767 let pwl l dir =
4768 begin match findpwl l.pageno dir with
4769 | Pwlnotfound -> ()
4770 | Pwl pageno ->
4771 let notfound dir =
4772 state.mode <- LinkNav (Ltgendir dir);
4773 let y, h = getpageyh pageno in
4774 let y =
4775 if dir < 0
4776 then y + h - conf.winh
4777 else y
4779 gotoy y
4781 begin match getopaque pageno, getpage pageno with
4782 | Some opaque, Some _ ->
4783 let link =
4784 let ld = if dir > 0 then LDfirst else LDlast in
4785 findlink opaque ld
4787 begin match link with
4788 | Lfound m ->
4789 showlinktype (getlink opaque m);
4790 state.mode <- LinkNav (Ltexact (pageno, m));
4791 G.postRedisplay "linknav jpage";
4792 | _ -> notfound dir
4793 end;
4794 | _ -> notfound dir
4795 end;
4796 end;
4798 begin match opt with
4799 | Some Lnotfound -> pwl l dir;
4800 | Some (Lfound m) ->
4801 if m = n
4802 then pwl l dir
4803 else (
4804 let _, y0, _, y1 = getlinkrect opaque m in
4805 if y0 < l.pagey
4806 then gotopage1 l.pageno y0
4807 else (
4808 let d = fstate.fontsize + 1 in
4809 if y1 - l.pagey > l.pagevh - d
4810 then gotopage1 l.pageno (y1 - conf.winh - state.hscrollh + d)
4811 else G.postRedisplay "linknav";
4813 showlinktype (getlink opaque m);
4814 state.mode <- LinkNav (Ltexact (l.pageno, m));
4817 | None ->
4818 state.mode <- LinkNav (Ltgendir 0);
4819 viewkeyboard key mask
4820 end;
4821 | _ -> viewkeyboard key mask
4823 if key = 0xff63
4824 then (
4825 state.mode <- View;
4826 G.postRedisplay "leave linknav"
4828 else
4829 match linknav with
4830 | Ltgendir _ -> viewkeyboard key mask
4831 | Ltexact exact -> doexact exact
4834 let keyboard key mask =
4835 if (key = 103 && Wsi.withctrl mask) && not (istextentry state.mode)
4836 then wcmd "interrupt"
4837 else state.uioh <- state.uioh#key key mask
4840 let birdseyekeyboard key mask
4841 ((oconf, leftx, pageno, hooverpageno, anchor) as beye) =
4842 let incr =
4843 match conf.columns with
4844 | None -> 1
4845 | Some ((c, _, _), _) -> c
4847 match key with
4848 | 108 when Wsi.withctrl mask -> (* ctrl-l *)
4849 let y, h = getpageyh pageno in
4850 let top = (conf.winh - h) / 2 in
4851 gotoy (max 0 (y - top))
4852 | 0xff0d -> leavebirdseye beye false
4853 | 0xff1b -> leavebirdseye beye true (* escape *)
4854 | 0xff52 -> upbirdseye incr beye (* prior *)
4855 | 0xff54 -> downbirdseye incr beye (* next *)
4856 | 0xff51 -> upbirdseye 1 beye (* up *)
4857 | 0xff53 -> downbirdseye 1 beye (* down *)
4859 | 0xff55 ->
4860 begin match state.layout with
4861 | l :: _ ->
4862 if l.pagey != 0
4863 then (
4864 state.mode <- Birdseye (
4865 oconf, leftx, l.pageno, hooverpageno, anchor
4867 gotopage1 l.pageno 0;
4869 else (
4870 let layout = layout (state.y-conf.winh) conf.winh in
4871 match layout with
4872 | [] -> gotoy (clamp (-conf.winh))
4873 | l :: _ ->
4874 state.mode <- Birdseye (
4875 oconf, leftx, l.pageno, hooverpageno, anchor
4877 gotopage1 l.pageno 0
4880 | [] -> gotoy (clamp (-conf.winh))
4881 end;
4883 | 0xff56 ->
4884 begin match List.rev state.layout with
4885 | l :: _ ->
4886 let layout = layout (state.y + conf.winh) conf.winh in
4887 begin match layout with
4888 | [] ->
4889 let incr = l.pageh - l.pagevh in
4890 if incr = 0
4891 then (
4892 state.mode <-
4893 Birdseye (
4894 oconf, leftx, state.pagecount - 1, hooverpageno, anchor
4896 G.postRedisplay "birdseye pagedown";
4898 else gotoy (clamp (incr + conf.interpagespace*2));
4900 | l :: _ ->
4901 state.mode <-
4902 Birdseye (oconf, leftx, l.pageno, hooverpageno, anchor);
4903 gotopage1 l.pageno 0;
4906 | [] -> gotoy (clamp conf.winh)
4907 end;
4909 | 0xff50 ->
4910 state.mode <- Birdseye (oconf, leftx, 0, hooverpageno, anchor);
4911 gotopage1 0 0
4913 | 0xff57 ->
4914 let pageno = state.pagecount - 1 in
4915 state.mode <- Birdseye (oconf, leftx, pageno, hooverpageno, anchor);
4916 if not (pagevisible state.layout pageno)
4917 then
4918 let h =
4919 match List.rev state.pdims with
4920 | [] -> conf.winh
4921 | (_, _, h, _) :: _ -> h
4923 gotoy (max 0 (getpagey pageno - (conf.winh - h - conf.interpagespace)))
4924 else G.postRedisplay "birdseye end";
4925 | _ -> viewkeyboard key mask
4928 let drawpage l =
4929 let color =
4930 match state.mode with
4931 | Textentry _ -> scalecolor 0.4
4932 | LinkNav _
4933 | View -> scalecolor 1.0
4934 | Birdseye (_, _, pageno, hooverpageno, _) ->
4935 if l.pageno = hooverpageno
4936 then scalecolor 0.9
4937 else (
4938 if l.pageno = pageno
4939 then scalecolor 1.0
4940 else scalecolor 0.8
4943 drawtiles l color;
4944 begin match getopaque l.pageno with
4945 | Some opaque ->
4946 if tileready l l.pagex l.pagey
4947 then
4948 let x = l.pagedispx - l.pagex
4949 and y = l.pagedispy - l.pagey in
4950 postprocess opaque conf.hlinks x y;
4952 | _ -> ()
4953 end;
4956 let scrollindicator () =
4957 let sbw, ph, sh = state.uioh#scrollph in
4958 let sbh, pw, sw = state.uioh#scrollpw in
4960 GlDraw.color (0.64, 0.64, 0.64);
4961 GlDraw.rect
4962 (float (conf.winw - sbw), 0.)
4963 (float conf.winw, float conf.winh)
4965 GlDraw.rect
4966 (0., float (conf.winh - sbh))
4967 (float (conf.winw - state.scrollw - 1), float conf.winh)
4969 GlDraw.color (0.0, 0.0, 0.0);
4971 GlDraw.rect
4972 (float (conf.winw - sbw), ph)
4973 (float conf.winw, ph +. sh)
4975 GlDraw.rect
4976 (pw, float (conf.winh - sbh))
4977 (pw +. sw, float conf.winh)
4981 let showsel () =
4982 match state.mstate with
4983 | Mnone | Mscrolly | Mscrollx | Mpan _ | Mzoom _ | Mzoomrect _ ->
4986 | Msel ((x0, y0), (x1, y1)) ->
4987 let rec loop = function
4988 | l :: ls ->
4989 if ((y0 >= l.pagedispy && y0 <= (l.pagedispy + l.pagevh))
4990 || ((y1 >= l.pagedispy && y1 <= (l.pagedispy + l.pagevh))))
4991 && ((x0 >= l.pagedispx && x0 <= (l.pagedispx + l.pagevw))
4992 || ((x1 >= l.pagedispx && x1 <= (l.pagedispx + l.pagevw))))
4993 then
4994 match getopaque l.pageno with
4995 | Some opaque ->
4996 let x0, y0 = pagetranslatepoint l x0 y0 in
4997 let x1, y1 = pagetranslatepoint l x1 y1 in
4998 seltext opaque (x0, y0, x1, y1);
4999 | _ -> ()
5000 else loop ls
5001 | [] -> ()
5003 loop state.layout
5006 let showrects rects =
5007 Gl.enable `blend;
5008 GlDraw.color (0.0, 0.0, 1.0) ~alpha:0.5;
5009 GlDraw.polygon_mode `both `fill;
5010 GlFunc.blend_func `src_alpha `one_minus_src_alpha;
5011 List.iter
5012 (fun (pageno, c, (x0, y0, x1, y1, x2, y2, x3, y3)) ->
5013 List.iter (fun l ->
5014 if l.pageno = pageno
5015 then (
5016 let dx = float (l.pagedispx - l.pagex) in
5017 let dy = float (l.pagedispy - l.pagey) in
5018 GlDraw.color (0.0, 0.0, 1.0 /. float c) ~alpha:0.5;
5019 GlDraw.begins `quads;
5021 GlDraw.vertex2 (x0+.dx, y0+.dy);
5022 GlDraw.vertex2 (x1+.dx, y1+.dy);
5023 GlDraw.vertex2 (x2+.dx, y2+.dy);
5024 GlDraw.vertex2 (x3+.dx, y3+.dy);
5026 GlDraw.ends ();
5028 ) state.layout
5029 ) rects
5031 Gl.disable `blend;
5034 let display () =
5035 GlClear.color (scalecolor2 conf.bgcolor);
5036 GlClear.clear [`color];
5037 List.iter drawpage state.layout;
5038 let rects =
5039 match state.mode with
5040 | LinkNav (Ltexact (pageno, linkno)) ->
5041 begin match getopaque pageno with
5042 | Some opaque ->
5043 let x0, y0, x1, y1 = getlinkrect opaque linkno in
5044 (pageno, 5, (
5045 float x0, float y0,
5046 float x1, float y0,
5047 float x1, float y1,
5048 float x0, float y1)
5049 ) :: state.rects
5050 | None -> state.rects
5052 | _ -> state.rects
5054 showrects rects;
5055 showsel ();
5056 state.uioh#display;
5057 begin match state.mstate with
5058 | Mzoomrect ((x0, y0), (x1, y1)) ->
5059 Gl.enable `blend;
5060 GlDraw.color (0.3, 0.3, 0.3) ~alpha:0.5;
5061 GlFunc.blend_func `src_alpha `one_minus_src_alpha;
5062 GlDraw.rect (float x0, float y0)
5063 (float x1, float y1);
5064 Gl.disable `blend;
5065 | _ -> ()
5066 end;
5067 enttext ();
5068 scrollindicator ();
5069 Wsi.swapb ();
5072 let zoomrect x y x1 y1 =
5073 let x0 = min x x1
5074 and x1 = max x x1
5075 and y0 = min y y1 in
5076 gotoy (state.y + y0);
5077 state.anchor <- getanchor ();
5078 let zoom = (float conf.winw *. conf.zoom) /. float (x1 - x0) in
5079 let margin =
5080 if state.w < conf.winw - state.scrollw
5081 then (conf.winw - state.scrollw - state.w) / 2
5082 else 0
5084 state.x <- (state.x + margin) - x0;
5085 setzoom zoom;
5086 Wsi.setcursor Wsi.CURSOR_INHERIT;
5087 state.mstate <- Mnone;
5090 let scrollx x =
5091 let winw = conf.winw - state.scrollw - 1 in
5092 let s = float x /. float winw in
5093 let destx = truncate (float (state.w + winw) *. s) in
5094 state.x <- winw - destx;
5095 gotoy_and_clear_text state.y;
5096 state.mstate <- Mscrollx;
5099 let scrolly y =
5100 let s = float y /. float conf.winh in
5101 let desty = truncate (float (state.maxy - conf.winh) *. s) in
5102 gotoy_and_clear_text desty;
5103 state.mstate <- Mscrolly;
5106 let viewmouse button down x y mask =
5107 match button with
5108 | n when (n == 4 || n == 5) && not down ->
5109 if Wsi.withctrl mask
5110 then (
5111 match state.mstate with
5112 | Mzoom (oldn, i) ->
5113 if oldn = n
5114 then (
5115 if i = 2
5116 then
5117 let incr =
5118 match n with
5119 | 5 ->
5120 if conf.zoom +. 0.01 > 0.1 then 0.1 else 0.01
5121 | _ ->
5122 if conf.zoom -. 0.1 < 0.1 then -0.01 else -0.1
5124 let zoom = conf.zoom -. incr in
5125 setzoom zoom;
5126 state.mstate <- Mzoom (n, 0);
5127 else
5128 state.mstate <- Mzoom (n, i+1);
5130 else state.mstate <- Mzoom (n, 0)
5132 | _ -> state.mstate <- Mzoom (n, 0)
5134 else (
5135 match state.autoscroll with
5136 | Some step -> setautoscrollspeed step (n=4)
5137 | None ->
5138 let incr =
5139 if n = 4
5140 then -conf.scrollstep
5141 else conf.scrollstep
5143 let incr = incr * 2 in
5144 let y = clamp incr in
5145 gotoy_and_clear_text y
5148 | 1 when Wsi.withctrl mask ->
5149 if down
5150 then (
5151 Wsi.setcursor Wsi.CURSOR_CROSSHAIR;
5152 state.mstate <- Mpan (x, y)
5154 else
5155 state.mstate <- Mnone
5157 | 3 ->
5158 if down
5159 then (
5160 Wsi.setcursor Wsi.CURSOR_CYCLE;
5161 let p = (x, y) in
5162 state.mstate <- Mzoomrect (p, p)
5164 else (
5165 match state.mstate with
5166 | Mzoomrect ((x0, y0), _) ->
5167 if abs (x-x0) > 10 && abs (y - y0) > 10
5168 then zoomrect x0 y0 x y
5169 else (
5170 state.mstate <- Mnone;
5171 Wsi.setcursor Wsi.CURSOR_INHERIT;
5172 G.postRedisplay "kill accidental zoom rect";
5174 | _ ->
5175 Wsi.setcursor Wsi.CURSOR_INHERIT;
5176 state.mstate <- Mnone
5179 | 1 when x > conf.winw - state.scrollw ->
5180 if down
5181 then
5182 let _, position, sh = state.uioh#scrollph in
5183 if y > truncate position && y < truncate (position +. sh)
5184 then state.mstate <- Mscrolly
5185 else scrolly y
5186 else
5187 state.mstate <- Mnone
5189 | 1 when y > conf.winh - state.hscrollh ->
5190 if down
5191 then
5192 let _, position, sw = state.uioh#scrollpw in
5193 if x > truncate position && x < truncate (position +. sw)
5194 then state.mstate <- Mscrollx
5195 else scrollx x
5196 else
5197 state.mstate <- Mnone
5199 | 1 ->
5200 let dest = if down then getunder x y else Unone in
5201 begin match dest with
5202 | Ulinkgoto (pageno, top) ->
5203 if pageno >= 0
5204 then (
5205 addnav ();
5206 gotopage1 pageno top;
5209 | Ulinkuri s ->
5210 gotouri s
5212 | Uremote (filename, pageno) ->
5213 let path =
5214 if Sys.file_exists filename
5215 then filename
5216 else
5217 let dir = Filename.dirname state.path in
5218 let path = Filename.concat dir filename in
5219 if Sys.file_exists path
5220 then path
5221 else ""
5223 if String.length path > 0
5224 then (
5225 let anchor = getanchor () in
5226 let ranchor = state.path, state.password, anchor in
5227 state.anchor <- (pageno, 0.0);
5228 state.ranchors <- ranchor :: state.ranchors;
5229 opendoc path "";
5231 else showtext '!' ("Could not find " ^ filename)
5233 | Uunexpected _ | Ulaunch _ | Unamed _ -> ()
5235 | Unone when down ->
5236 Wsi.setcursor Wsi.CURSOR_CROSSHAIR;
5237 state.mstate <- Mpan (x, y);
5239 | Unone | Utext _ ->
5240 if down
5241 then (
5242 if conf.angle mod 360 = 0
5243 then (
5244 state.mstate <- Msel ((x, y), (x, y));
5245 G.postRedisplay "mouse select";
5248 else (
5249 match state.mstate with
5250 | Mnone -> ()
5252 | Mzoom _ | Mscrollx | Mscrolly ->
5253 state.mstate <- Mnone
5255 | Mzoomrect ((x0, y0), _) ->
5256 zoomrect x0 y0 x y
5258 | Mpan _ ->
5259 Wsi.setcursor Wsi.CURSOR_INHERIT;
5260 state.mstate <- Mnone
5262 | Msel ((_, y0), (_, y1)) ->
5263 let rec loop = function
5264 | [] -> ()
5265 | l :: rest ->
5266 if (y0 >= l.pagedispy && y0 <= (l.pagedispy + l.pagevh))
5267 || ((y1 >= l.pagedispy
5268 && y1 <= (l.pagedispy + l.pagevh)))
5269 then
5270 match getopaque l.pageno with
5271 | Some opaque ->
5272 copysel conf.selcmd opaque;
5273 G.postRedisplay "copysel"
5274 | _ -> ()
5275 else loop rest
5277 loop state.layout;
5278 Wsi.setcursor Wsi.CURSOR_INHERIT;
5279 state.mstate <- Mnone;
5283 | _ -> ()
5286 let birdseyemouse button down x y mask
5287 (conf, leftx, _, hooverpageno, anchor) =
5288 match button with
5289 | 1 when down ->
5290 let rec loop = function
5291 | [] -> ()
5292 | l :: rest ->
5293 if y > l.pagedispy && y < l.pagedispy + l.pagevh
5294 && x > l.pagedispx && x < l.pagedispx + l.pagevw
5295 then (
5296 leavebirdseye (conf, leftx, l.pageno, hooverpageno, anchor) false;
5298 else loop rest
5300 loop state.layout
5301 | 3 -> ()
5302 | _ -> viewmouse button down x y mask
5305 let mouse button down x y mask =
5306 state.uioh <- state.uioh#button button down x y mask;
5309 let motion ~x ~y =
5310 state.uioh <- state.uioh#motion x y
5313 let pmotion ~x ~y =
5314 state.uioh <- state.uioh#pmotion x y;
5317 let uioh = object
5318 method display = ()
5320 method key key mask =
5321 begin match state.mode with
5322 | Textentry textentry -> textentrykeyboard key mask textentry
5323 | Birdseye birdseye -> birdseyekeyboard key mask birdseye
5324 | View -> viewkeyboard key mask
5325 | LinkNav linknav -> linknavkeyboard key mask linknav
5326 end;
5327 state.uioh
5329 method button button bstate x y mask =
5330 begin match state.mode with
5331 | LinkNav _
5332 | View -> viewmouse button bstate x y mask
5333 | Birdseye beye -> birdseyemouse button bstate x y mask beye
5334 | Textentry _ -> ()
5335 end;
5336 state.uioh
5338 method motion x y =
5339 begin match state.mode with
5340 | Textentry _ -> ()
5341 | View | Birdseye _ | LinkNav _ ->
5342 match state.mstate with
5343 | Mzoom _ | Mnone -> ()
5345 | Mpan (x0, y0) ->
5346 let dx = x - x0
5347 and dy = y0 - y in
5348 state.mstate <- Mpan (x, y);
5349 if conf.zoom > 1.0 then state.x <- state.x + dx;
5350 let y = clamp dy in
5351 gotoy_and_clear_text y
5353 | Msel (a, _) ->
5354 state.mstate <- Msel (a, (x, y));
5355 G.postRedisplay "motion select";
5357 | Mscrolly ->
5358 let y = min conf.winh (max 0 y) in
5359 scrolly y
5361 | Mscrollx ->
5362 let x = min conf.winw (max 0 x) in
5363 scrollx x
5365 | Mzoomrect (p0, _) ->
5366 state.mstate <- Mzoomrect (p0, (x, y));
5367 G.postRedisplay "motion zoomrect";
5368 end;
5369 state.uioh
5371 method pmotion x y =
5372 begin match state.mode with
5373 | Birdseye (conf, leftx, pageno, hooverpageno, anchor) ->
5374 let rec loop = function
5375 | [] ->
5376 if hooverpageno != -1
5377 then (
5378 state.mode <- Birdseye (conf, leftx, pageno, -1, anchor);
5379 G.postRedisplay "pmotion birdseye no hoover";
5381 | l :: rest ->
5382 if y > l.pagedispy && y < l.pagedispy + l.pagevh
5383 && x > l.pagedispx && x < l.pagedispx + l.pagevw
5384 then (
5385 state.mode <- Birdseye (conf, leftx, pageno, l.pageno, anchor);
5386 G.postRedisplay "pmotion birdseye hoover";
5388 else loop rest
5390 loop state.layout
5392 | Textentry _ -> ()
5394 | LinkNav _
5395 | View ->
5396 match state.mstate with
5397 | Mnone -> updateunder x y
5398 | Mpan _ | Msel _ | Mzoom _ | Mscrolly | Mscrollx | Mzoomrect _ ->
5400 end;
5401 state.uioh
5403 method infochanged _ = ()
5405 method scrollph =
5406 let maxy = state.maxy - (if conf.maxhfit then conf.winh else 0) in
5407 let p, h = scrollph state.y maxy in
5408 state.scrollw, p, h
5410 method scrollpw =
5411 let winw = conf.winw - state.scrollw - 1 in
5412 let fwinw = float winw in
5413 let sw =
5414 let sw = fwinw /. float state.w in
5415 let sw = fwinw *. sw in
5416 max sw (float conf.scrollh)
5418 let position, sw =
5419 let f = state.w+winw in
5420 let r = float (winw-state.x) /. float f in
5421 let p = fwinw *. r in
5422 p-.sw/.2., sw
5424 let sw =
5425 if position +. sw > fwinw
5426 then fwinw -. position
5427 else sw
5429 state.hscrollh, position, sw
5431 method modehash =
5432 let modename =
5433 match state.mode with
5434 | LinkNav _ -> "links"
5435 | Textentry _ -> "textentry"
5436 | Birdseye _ -> "birdseye"
5437 | View -> "global"
5439 findkeyhash conf modename
5440 end;;
5442 module Config =
5443 struct
5444 open Parser
5446 let fontpath = ref "";;
5448 module KeyMap =
5449 Map.Make (struct type t = (int * int) let compare = compare end);;
5451 let unent s =
5452 let l = String.length s in
5453 let b = Buffer.create l in
5454 unent b s 0 l;
5455 Buffer.contents b;
5458 let home =
5459 try Sys.getenv "HOME"
5460 with exn ->
5461 prerr_endline
5462 ("Can not determine home directory location: " ^
5463 Printexc.to_string exn);
5467 let modifier_of_string = function
5468 | "alt" -> Wsi.altmask
5469 | "shift" -> Wsi.shiftmask
5470 | "ctrl" | "control" -> Wsi.ctrlmask
5471 | "meta" -> Wsi.metamask
5472 | _ -> 0
5475 let key_of_string =
5476 let r = Str.regexp "-" in
5477 fun s ->
5478 let elems = Str.full_split r s in
5479 let f n k m =
5480 let g s =
5481 let m1 = modifier_of_string s in
5482 if m1 = 0
5483 then (Wsi.namekey s, m)
5484 else (k, m lor m1)
5485 in function
5486 | Str.Delim s when n land 1 = 0 -> g s
5487 | Str.Text s -> g s
5488 | Str.Delim _ -> (k, m)
5490 let rec loop n k m = function
5491 | [] -> (k, m)
5492 | x :: xs ->
5493 let k, m = f n k m x in
5494 loop (n+1) k m xs
5496 loop 0 0 0 elems
5499 let keys_of_string =
5500 let r = Str.regexp "[ \t]" in
5501 fun s ->
5502 let elems = Str.split r s in
5503 List.map key_of_string elems
5506 let copykeyhashes c =
5507 List.map (fun (k, v) -> k, Hashtbl.copy v) c.keyhashes;
5510 let config_of c attrs =
5511 let apply c k v =
5513 match k with
5514 | "scroll-bar-width" -> { c with scrollbw = max 0 (int_of_string v) }
5515 | "scroll-handle-height" -> { c with scrollh = max 0 (int_of_string v) }
5516 | "case-insensitive-search" -> { c with icase = bool_of_string v }
5517 | "preload" -> { c with preload = bool_of_string v }
5518 | "page-bias" -> { c with pagebias = int_of_string v }
5519 | "scroll-step" -> { c with scrollstep = max 1 (int_of_string v) }
5520 | "auto-scroll-step" ->
5521 { c with autoscrollstep = max 0 (int_of_string v) }
5522 | "max-height-fit" -> { c with maxhfit = bool_of_string v }
5523 | "crop-hack" -> { c with crophack = bool_of_string v }
5524 | "throttle" ->
5525 let mw =
5526 match String.lowercase v with
5527 | "true" -> Some infinity
5528 | "false" -> None
5529 | f -> Some (float_of_string f)
5531 { c with maxwait = mw}
5532 | "highlight-links" -> { c with hlinks = bool_of_string v }
5533 | "under-cursor-info" -> { c with underinfo = bool_of_string v }
5534 | "vertical-margin" ->
5535 { c with interpagespace = max 0 (int_of_string v) }
5536 | "zoom" ->
5537 let zoom = float_of_string v /. 100. in
5538 let zoom = max zoom 0.0 in
5539 { c with zoom = zoom }
5540 | "presentation" -> { c with presentation = bool_of_string v }
5541 | "rotation-angle" -> { c with angle = int_of_string v }
5542 | "width" -> { c with winw = max 20 (int_of_string v) }
5543 | "height" -> { c with winh = max 20 (int_of_string v) }
5544 | "persistent-bookmarks" -> { c with savebmarks = bool_of_string v }
5545 | "proportional-display" -> { c with proportional = bool_of_string v }
5546 | "pixmap-cache-size" ->
5547 { c with memlimit = max 2 (int_of_string_with_suffix v) }
5548 | "tex-count" -> { c with texcount = max 1 (int_of_string v) }
5549 | "slice-height" -> { c with sliceheight = max 2 (int_of_string v) }
5550 | "thumbnail-width" -> { c with thumbw = max 2 (int_of_string v) }
5551 | "persistent-location" -> { c with jumpback = bool_of_string v }
5552 | "background-color" -> { c with bgcolor = color_of_string v }
5553 | "scrollbar-in-presentation" ->
5554 { c with scrollbarinpm = bool_of_string v }
5555 | "tile-width" -> { c with tilew = max 2 (int_of_string v) }
5556 | "tile-height" -> { c with tileh = max 2 (int_of_string v) }
5557 | "mupdf-store-size" ->
5558 { c with mustoresize = max 1024 (int_of_string_with_suffix v) }
5559 | "checkers" -> { c with checkers = bool_of_string v }
5560 | "aalevel" -> { c with aalevel = max 0 (int_of_string v) }
5561 | "trim-margins" -> { c with trimmargins = bool_of_string v }
5562 | "trim-fuzz" -> { c with trimfuzz = irect_of_string v }
5563 | "uri-launcher" -> { c with urilauncher = unent v }
5564 | "path-launcher" -> { c with pathlauncher = unent v }
5565 | "color-space" -> { c with colorspace = colorspace_of_string v }
5566 | "invert-colors" -> { c with invert = bool_of_string v }
5567 | "brightness" -> { c with colorscale = float_of_string v }
5568 | "redirectstderr" -> { c with redirectstderr = bool_of_string v }
5569 | "ghyllscroll" ->
5570 { c with ghyllscroll = Some (ghyllscroll_of_string v) }
5571 | "columns" ->
5572 let nab = columns_of_string v in
5573 { c with columns = Some (nab, [||]) }
5574 | "birds-eye-columns" ->
5575 { c with beyecolumns = Some (max (int_of_string v) 2) }
5576 | "selection-command" -> { c with selcmd = unent v }
5577 | "update-cursor" -> { c with updatecurs = bool_of_string v }
5578 | _ -> c
5579 with exn ->
5580 prerr_endline ("Error processing attribute (`" ^
5581 k ^ "'=`" ^ v ^ "'): " ^ Printexc.to_string exn);
5584 let rec fold c = function
5585 | [] -> c
5586 | (k, v) :: rest ->
5587 let c = apply c k v in
5588 fold c rest
5590 fold { c with keyhashes = copykeyhashes c } attrs;
5593 let fromstring f pos n v d =
5594 try f v
5595 with exn ->
5596 dolog "Error processing attribute (%S=%S) at %d\n%s"
5597 n v pos (Printexc.to_string exn)
5602 let bookmark_of attrs =
5603 let rec fold title page rely = function
5604 | ("title", v) :: rest -> fold v page rely rest
5605 | ("page", v) :: rest -> fold title v rely rest
5606 | ("rely", v) :: rest -> fold title page v rest
5607 | _ :: rest -> fold title page rely rest
5608 | [] -> title, page, rely
5610 fold "invalid" "0" "0" attrs
5613 let doc_of attrs =
5614 let rec fold path page rely pan = function
5615 | ("path", v) :: rest -> fold v page rely pan rest
5616 | ("page", v) :: rest -> fold path v rely pan rest
5617 | ("rely", v) :: rest -> fold path page v pan rest
5618 | ("pan", v) :: rest -> fold path page rely v rest
5619 | _ :: rest -> fold path page rely pan rest
5620 | [] -> path, page, rely, pan
5622 fold "" "0" "0" "0" attrs
5625 let map_of attrs =
5626 let rec fold rs ls = function
5627 | ("out", v) :: rest -> fold v ls rest
5628 | ("in", v) :: rest -> fold rs v rest
5629 | _ :: rest -> fold ls rs rest
5630 | [] -> ls, rs
5632 fold "" "" attrs
5635 let setconf dst src =
5636 dst.scrollbw <- src.scrollbw;
5637 dst.scrollh <- src.scrollh;
5638 dst.icase <- src.icase;
5639 dst.preload <- src.preload;
5640 dst.pagebias <- src.pagebias;
5641 dst.verbose <- src.verbose;
5642 dst.scrollstep <- src.scrollstep;
5643 dst.maxhfit <- src.maxhfit;
5644 dst.crophack <- src.crophack;
5645 dst.autoscrollstep <- src.autoscrollstep;
5646 dst.maxwait <- src.maxwait;
5647 dst.hlinks <- src.hlinks;
5648 dst.underinfo <- src.underinfo;
5649 dst.interpagespace <- src.interpagespace;
5650 dst.zoom <- src.zoom;
5651 dst.presentation <- src.presentation;
5652 dst.angle <- src.angle;
5653 dst.winw <- src.winw;
5654 dst.winh <- src.winh;
5655 dst.savebmarks <- src.savebmarks;
5656 dst.memlimit <- src.memlimit;
5657 dst.proportional <- src.proportional;
5658 dst.texcount <- src.texcount;
5659 dst.sliceheight <- src.sliceheight;
5660 dst.thumbw <- src.thumbw;
5661 dst.jumpback <- src.jumpback;
5662 dst.bgcolor <- src.bgcolor;
5663 dst.scrollbarinpm <- src.scrollbarinpm;
5664 dst.tilew <- src.tilew;
5665 dst.tileh <- src.tileh;
5666 dst.mustoresize <- src.mustoresize;
5667 dst.checkers <- src.checkers;
5668 dst.aalevel <- src.aalevel;
5669 dst.trimmargins <- src.trimmargins;
5670 dst.trimfuzz <- src.trimfuzz;
5671 dst.urilauncher <- src.urilauncher;
5672 dst.colorspace <- src.colorspace;
5673 dst.invert <- src.invert;
5674 dst.colorscale <- src.colorscale;
5675 dst.redirectstderr <- src.redirectstderr;
5676 dst.ghyllscroll <- src.ghyllscroll;
5677 dst.columns <- src.columns;
5678 dst.beyecolumns <- src.beyecolumns;
5679 dst.selcmd <- src.selcmd;
5680 dst.updatecurs <- src.updatecurs;
5681 dst.pathlauncher <- src.pathlauncher;
5682 dst.keyhashes <- copykeyhashes src;
5685 let get s =
5686 let h = Hashtbl.create 10 in
5687 let dc = { defconf with angle = defconf.angle } in
5688 let rec toplevel v t spos _ =
5689 match t with
5690 | Vdata | Vcdata | Vend -> v
5691 | Vopen ("llppconfig", _, closed) ->
5692 if closed
5693 then v
5694 else { v with f = llppconfig }
5695 | Vopen _ ->
5696 error "unexpected subelement at top level" s spos
5697 | Vclose _ -> error "unexpected close at top level" s spos
5699 and llppconfig v t spos _ =
5700 match t with
5701 | Vdata | Vcdata -> v
5702 | Vend -> error "unexpected end of input in llppconfig" s spos
5703 | Vopen ("defaults", attrs, closed) ->
5704 let c = config_of dc attrs in
5705 setconf dc c;
5706 if closed
5707 then v
5708 else { v with f = defaults }
5710 | Vopen ("ui-font", attrs, closed) ->
5711 let rec getsize size = function
5712 | [] -> size
5713 | ("size", v) :: rest ->
5714 let size =
5715 fromstring int_of_string spos "size" v fstate.fontsize in
5716 getsize size rest
5717 | l -> getsize size l
5719 fstate.fontsize <- getsize fstate.fontsize attrs;
5720 if closed
5721 then v
5722 else { v with f = uifont (Buffer.create 10) }
5724 | Vopen ("doc", attrs, closed) ->
5725 let pathent, spage, srely, span = doc_of attrs in
5726 let path = unent pathent
5727 and pageno = fromstring int_of_string spos "page" spage 0
5728 and rely = fromstring float_of_string spos "rely" srely 0.0
5729 and pan = fromstring int_of_string spos "pan" span 0 in
5730 let c = config_of dc attrs in
5731 let anchor = (pageno, rely) in
5732 if closed
5733 then (Hashtbl.add h path (c, [], pan, anchor); v)
5734 else { v with f = doc path pan anchor c [] }
5736 | Vopen _ ->
5737 error "unexpected subelement in llppconfig" s spos
5739 | Vclose "llppconfig" -> { v with f = toplevel }
5740 | Vclose _ -> error "unexpected close in llppconfig" s spos
5742 and defaults v t spos _ =
5743 match t with
5744 | Vdata | Vcdata -> v
5745 | Vend -> error "unexpected end of input in defaults" s spos
5746 | Vopen ("keymap", attrs, closed) ->
5747 let modename =
5748 try List.assoc "mode" attrs
5749 with Not_found -> "global" in
5750 if closed
5751 then v
5752 else
5753 let ret keymap =
5754 let h = findkeyhash dc modename in
5755 KeyMap.iter (Hashtbl.replace h) keymap;
5756 defaults
5758 { v with f = pkeymap ret KeyMap.empty }
5760 | Vopen (_, _, _) ->
5761 error "unexpected subelement in defaults" s spos
5763 | Vclose "defaults" ->
5764 { v with f = llppconfig }
5766 | Vclose _ -> error "unexpected close in defaults" s spos
5768 and uifont b v t spos epos =
5769 match t with
5770 | Vdata | Vcdata ->
5771 Buffer.add_substring b s spos (epos - spos);
5773 | Vopen (_, _, _) ->
5774 error "unexpected subelement in ui-font" s spos
5775 | Vclose "ui-font" ->
5776 if String.length !fontpath = 0
5777 then fontpath := Buffer.contents b;
5778 { v with f = llppconfig }
5779 | Vclose _ -> error "unexpected close in ui-font" s spos
5780 | Vend -> error "unexpected end of input in ui-font" s spos
5782 and doc path pan anchor c bookmarks v t spos _ =
5783 match t with
5784 | Vdata | Vcdata -> v
5785 | Vend -> error "unexpected end of input in doc" s spos
5786 | Vopen ("bookmarks", _, closed) ->
5787 if closed
5788 then v
5789 else { v with f = pbookmarks path pan anchor c bookmarks }
5791 | Vopen ("keymap", attrs, closed) ->
5792 let modename =
5793 try List.assoc "mode" attrs
5794 with Not_found -> "global"
5796 if closed
5797 then v
5798 else
5799 let ret keymap =
5800 let h = findkeyhash c modename in
5801 KeyMap.iter (Hashtbl.replace h) keymap;
5802 doc path pan anchor c bookmarks
5804 { v with f = pkeymap ret KeyMap.empty }
5806 | Vopen (_, _, _) ->
5807 error "unexpected subelement in doc" s spos
5809 | Vclose "doc" ->
5810 Hashtbl.add h path (c, List.rev bookmarks, pan, anchor);
5811 { v with f = llppconfig }
5813 | Vclose _ -> error "unexpected close in doc" s spos
5815 and pkeymap ret keymap v t spos _ =
5816 match t with
5817 | Vdata | Vcdata -> v
5818 | Vend -> error "unexpected end of input in keymap" s spos
5819 | Vopen ("map", attrs, closed) ->
5820 let r, l = map_of attrs in
5821 let kss = fromstring keys_of_string spos "in" r [] in
5822 let lss = fromstring keys_of_string spos "out" l [] in
5823 let keymap =
5824 match kss with
5825 | [] -> keymap
5826 | ks :: [] -> KeyMap.add ks (KMinsrl lss) keymap
5827 | ks :: rest -> KeyMap.add ks (KMmulti (rest, lss)) keymap
5829 if closed
5830 then { v with f = pkeymap ret keymap }
5831 else
5832 let f () = v in
5833 { v with f = skip "map" f }
5835 | Vopen _ ->
5836 error "unexpected subelement in keymap" s spos
5838 | Vclose "keymap" ->
5839 { v with f = ret keymap }
5841 | Vclose _ -> error "unexpected close in keymap" s spos
5843 and pbookmarks path pan anchor c bookmarks v t spos _ =
5844 match t with
5845 | Vdata | Vcdata -> v
5846 | Vend -> error "unexpected end of input in bookmarks" s spos
5847 | Vopen ("item", attrs, closed) ->
5848 let titleent, spage, srely = bookmark_of attrs in
5849 let page = fromstring int_of_string spos "page" spage 0
5850 and rely = fromstring float_of_string spos "rely" srely 0.0 in
5851 let bookmarks = (unent titleent, 0, (page, rely)) :: bookmarks in
5852 if closed
5853 then { v with f = pbookmarks path pan anchor c bookmarks }
5854 else
5855 let f () = v in
5856 { v with f = skip "item" f }
5858 | Vopen _ ->
5859 error "unexpected subelement in bookmarks" s spos
5861 | Vclose "bookmarks" ->
5862 { v with f = doc path pan anchor c bookmarks }
5864 | Vclose _ -> error "unexpected close in bookmarks" s spos
5866 and skip tag f v t spos _ =
5867 match t with
5868 | Vdata | Vcdata -> v
5869 | Vend ->
5870 error ("unexpected end of input in skipped " ^ tag) s spos
5871 | Vopen (tag', _, closed) ->
5872 if closed
5873 then v
5874 else
5875 let f' () = { v with f = skip tag f } in
5876 { v with f = skip tag' f' }
5877 | Vclose ctag ->
5878 if tag = ctag
5879 then f ()
5880 else error ("unexpected close in skipped " ^ tag) s spos
5883 parse { f = toplevel; accu = () } s;
5884 h, dc;
5887 let do_load f ic =
5889 let len = in_channel_length ic in
5890 let s = String.create len in
5891 really_input ic s 0 len;
5892 f s;
5893 with
5894 | Parse_error (msg, s, pos) ->
5895 let subs = subs s pos in
5896 let s = Printf.sprintf "%s: at %d [..%s..]" msg pos subs in
5897 failwith ("parse error: " ^ s)
5899 | exn ->
5900 failwith ("config load error: " ^ Printexc.to_string exn)
5903 let defconfpath =
5904 let dir =
5906 let dir = Filename.concat home ".config" in
5907 if Sys.is_directory dir then dir else home
5908 with _ -> home
5910 Filename.concat dir "llpp.conf"
5913 let confpath = ref defconfpath;;
5915 let load1 f =
5916 if Sys.file_exists !confpath
5917 then
5918 match
5919 (try Some (open_in_bin !confpath)
5920 with exn ->
5921 prerr_endline
5922 ("Error opening configuation file `" ^ !confpath ^ "': " ^
5923 Printexc.to_string exn);
5924 None
5926 with
5927 | Some ic ->
5928 begin try
5929 f (do_load get ic)
5930 with exn ->
5931 prerr_endline
5932 ("Error loading configuation from `" ^ !confpath ^ "': " ^
5933 Printexc.to_string exn);
5934 end;
5935 close_in ic;
5937 | None -> ()
5938 else
5939 f (Hashtbl.create 0, defconf)
5942 let load () =
5943 let f (h, dc) =
5944 let pc, pb, px, pa =
5946 Hashtbl.find h (Filename.basename state.path)
5947 with Not_found -> dc, [], 0, (0, 0.0)
5949 setconf defconf dc;
5950 setconf conf pc;
5951 state.bookmarks <- pb;
5952 state.x <- px;
5953 state.scrollw <- conf.scrollbw;
5954 if conf.jumpback
5955 then state.anchor <- pa;
5956 cbput state.hists.nav pa;
5958 load1 f
5961 let add_attrs bb always dc c =
5962 let ob s a b =
5963 if always || a != b
5964 then Printf.bprintf bb "\n %s='%b'" s a
5965 and oi s a b =
5966 if always || a != b
5967 then Printf.bprintf bb "\n %s='%d'" s a
5968 and oI s a b =
5969 if always || a != b
5970 then Printf.bprintf bb "\n %s='%s'" s (string_with_suffix_of_int a)
5971 and oz s a b =
5972 if always || a <> b
5973 then Printf.bprintf bb "\n %s='%d'" s (truncate (a*.100.))
5974 and oF s a b =
5975 if always || a <> b
5976 then Printf.bprintf bb "\n %s='%f'" s a
5977 and oc s a b =
5978 if always || a <> b
5979 then
5980 Printf.bprintf bb "\n %s='%s'" s (color_to_string a)
5981 and oC s a b =
5982 if always || a <> b
5983 then
5984 Printf.bprintf bb "\n %s='%s'" s (colorspace_to_string a)
5985 and oR s a b =
5986 if always || a <> b
5987 then
5988 Printf.bprintf bb "\n %s='%s'" s (irect_to_string a)
5989 and os s a b =
5990 if always || a <> b
5991 then
5992 Printf.bprintf bb "\n %s='%s'" s (enent a 0 (String.length a))
5993 and og s a b =
5994 if always || a <> b
5995 then
5996 match a with
5997 | None -> ()
5998 | Some (_N, _A, _B) ->
5999 Printf.bprintf bb "\n %s='%u,%u,%u'" s _N _A _B
6000 and oW s a b =
6001 if always || a <> b
6002 then
6003 let v =
6004 match a with
6005 | None -> "false"
6006 | Some f ->
6007 if f = infinity
6008 then "true"
6009 else string_of_float f
6011 Printf.bprintf bb "\n %s='%s'" s v
6012 and oco s a b =
6013 if always || a <> b
6014 then
6015 match a with
6016 | Some ((n, a, b), _) when n > 1 ->
6017 Printf.bprintf bb "\n %s='%d,%d,%d'" s n a b
6018 | _ -> ()
6019 and obeco s a b =
6020 if always || a <> b
6021 then
6022 match a with
6023 | Some c when c > 1 -> Printf.bprintf bb "\n %s='%d'" s c
6024 | _ -> ()
6026 let w, h =
6027 if always
6028 then dc.winw, dc.winh
6029 else
6030 match state.fullscreen with
6031 | Some wh -> wh
6032 | None -> c.winw, c.winh
6034 let zoom, presentation, interpagespace, maxwait =
6035 if always
6036 then dc.zoom, dc.presentation, dc.interpagespace, dc.maxwait
6037 else
6038 match state.mode with
6039 | Birdseye (bc, _, _, _, _) ->
6040 bc.zoom, bc.presentation, bc.interpagespace, bc.maxwait
6041 | _ -> c.zoom, c.presentation, c.interpagespace, c.maxwait
6043 oi "width" w dc.winw;
6044 oi "height" h dc.winh;
6045 oi "scroll-bar-width" c.scrollbw dc.scrollbw;
6046 oi "scroll-handle-height" c.scrollh dc.scrollh;
6047 ob "case-insensitive-search" c.icase dc.icase;
6048 ob "preload" c.preload dc.preload;
6049 oi "page-bias" c.pagebias dc.pagebias;
6050 oi "scroll-step" c.scrollstep dc.scrollstep;
6051 oi "auto-scroll-step" c.autoscrollstep dc.autoscrollstep;
6052 ob "max-height-fit" c.maxhfit dc.maxhfit;
6053 ob "crop-hack" c.crophack dc.crophack;
6054 oW "throttle" maxwait dc.maxwait;
6055 ob "highlight-links" c.hlinks dc.hlinks;
6056 ob "under-cursor-info" c.underinfo dc.underinfo;
6057 oi "vertical-margin" interpagespace dc.interpagespace;
6058 oz "zoom" zoom dc.zoom;
6059 ob "presentation" presentation dc.presentation;
6060 oi "rotation-angle" c.angle dc.angle;
6061 ob "persistent-bookmarks" c.savebmarks dc.savebmarks;
6062 ob "proportional-display" c.proportional dc.proportional;
6063 oI "pixmap-cache-size" c.memlimit dc.memlimit;
6064 oi "tex-count" c.texcount dc.texcount;
6065 oi "slice-height" c.sliceheight dc.sliceheight;
6066 oi "thumbnail-width" c.thumbw dc.thumbw;
6067 ob "persistent-location" c.jumpback dc.jumpback;
6068 oc "background-color" c.bgcolor dc.bgcolor;
6069 ob "scrollbar-in-presentation" c.scrollbarinpm dc.scrollbarinpm;
6070 oi "tile-width" c.tilew dc.tilew;
6071 oi "tile-height" c.tileh dc.tileh;
6072 oI "mupdf-store-size" c.mustoresize dc.mustoresize;
6073 ob "checkers" c.checkers dc.checkers;
6074 oi "aalevel" c.aalevel dc.aalevel;
6075 ob "trim-margins" c.trimmargins dc.trimmargins;
6076 oR "trim-fuzz" c.trimfuzz dc.trimfuzz;
6077 os "uri-launcher" c.urilauncher dc.urilauncher;
6078 os "path-launcher" c.pathlauncher dc.pathlauncher;
6079 oC "color-space" c.colorspace dc.colorspace;
6080 ob "invert-colors" c.invert dc.invert;
6081 oF "brightness" c.colorscale dc.colorscale;
6082 ob "redirectstderr" c.redirectstderr dc.redirectstderr;
6083 og "ghyllscroll" c.ghyllscroll dc.ghyllscroll;
6084 oco "columns" c.columns dc.columns;
6085 obeco "birds-eye-columns" c.beyecolumns dc.beyecolumns;
6086 os "selection-command" c.selcmd dc.selcmd;
6087 ob "update-cursor" c.updatecurs dc.updatecurs;
6090 let keymapsbuf always dc c =
6091 let bb = Buffer.create 16 in
6092 let rec loop = function
6093 | [] -> ()
6094 | (modename, h) :: rest ->
6095 let dh = findkeyhash dc modename in
6096 if always || h <> dh
6097 then (
6098 if Hashtbl.length h > 0
6099 then (
6100 if Buffer.length bb > 0
6101 then Buffer.add_char bb '\n';
6102 Printf.bprintf bb "<keymap mode='%s'>\n" modename;
6103 Hashtbl.iter (fun i o ->
6104 let isdifferent = always ||
6106 let dO = Hashtbl.find dh i in
6107 dO <> o
6108 with Not_found -> true
6110 if isdifferent
6111 then
6112 let addkm (k, m) =
6113 if Wsi.withctrl m then Buffer.add_string bb "ctrl-";
6114 if Wsi.withalt m then Buffer.add_string bb "alt-";
6115 if Wsi.withshift m then Buffer.add_string bb "shift-";
6116 if Wsi.withmeta m then Buffer.add_string bb "meta-";
6117 Buffer.add_string bb (Wsi.keyname k);
6119 let addkms l =
6120 let rec loop = function
6121 | [] -> ()
6122 | km :: [] -> addkm km
6123 | km :: rest -> addkm km; Buffer.add_char bb ' '; loop rest
6125 loop l
6127 Buffer.add_string bb "<map in='";
6128 addkm i;
6129 match o with
6130 | KMinsrt km ->
6131 Buffer.add_string bb "' out='";
6132 addkm km;
6133 Buffer.add_string bb "'/>\n"
6135 | KMinsrl kms ->
6136 Buffer.add_string bb "' out='";
6137 addkms kms;
6138 Buffer.add_string bb "'/>\n"
6140 | KMmulti (ins, kms) ->
6141 Buffer.add_char bb ' ';
6142 addkms ins;
6143 Buffer.add_string bb "' out='";
6144 addkms kms;
6145 Buffer.add_string bb "'/>\n"
6146 ) h;
6147 Buffer.add_string bb "</keymap>";
6150 loop rest
6152 loop c.keyhashes;
6156 let save () =
6157 let uifontsize = fstate.fontsize in
6158 let bb = Buffer.create 32768 in
6159 let f (h, dc) =
6160 let dc = if conf.bedefault then conf else dc in
6161 Buffer.add_string bb "<llppconfig>\n";
6163 if String.length !fontpath > 0
6164 then
6165 Printf.bprintf bb "<ui-font size='%d'><![CDATA[%s]]></ui-font>\n"
6166 uifontsize
6167 !fontpath
6168 else (
6169 if uifontsize <> 14
6170 then
6171 Printf.bprintf bb "<ui-font size='%d'/>\n" uifontsize
6174 Buffer.add_string bb "<defaults ";
6175 add_attrs bb true dc dc;
6176 let kb = keymapsbuf true dc dc in
6177 if Buffer.length kb > 0
6178 then (
6179 Buffer.add_string bb ">\n";
6180 Buffer.add_buffer bb kb;
6181 Buffer.add_string bb "\n</defaults>\n";
6183 else Buffer.add_string bb "/>\n";
6185 let adddoc path pan anchor c bookmarks =
6186 if bookmarks == [] && c = dc && anchor = emptyanchor
6187 then ()
6188 else (
6189 Printf.bprintf bb "<doc path='%s'"
6190 (enent path 0 (String.length path));
6192 if anchor <> emptyanchor
6193 then (
6194 let n, y = anchor in
6195 Printf.bprintf bb " page='%d'" n;
6196 if y > 1e-6
6197 then
6198 Printf.bprintf bb " rely='%f'" y
6202 if pan != 0
6203 then Printf.bprintf bb " pan='%d'" pan;
6205 add_attrs bb false dc c;
6206 let kb = keymapsbuf false dc c in
6208 begin match bookmarks with
6209 | [] ->
6210 if Buffer.length kb > 0
6211 then (
6212 Buffer.add_string bb ">\n";
6213 Buffer.add_buffer bb kb;
6214 Buffer.add_string bb "</doc>\n";
6216 else Buffer.add_string bb "/>\n"
6217 | _ ->
6218 Buffer.add_string bb ">\n<bookmarks>\n";
6219 List.iter (fun (title, _level, (page, rely)) ->
6220 Printf.bprintf bb
6221 "<item title='%s' page='%d'"
6222 (enent title 0 (String.length title))
6223 page
6225 if rely > 1e-6
6226 then
6227 Printf.bprintf bb " rely='%f'" rely
6229 Buffer.add_string bb "/>\n";
6230 ) bookmarks;
6231 Buffer.add_string bb "</bookmarks>";
6232 if Buffer.length kb > 0
6233 then (
6234 Buffer.add_string bb "\n";
6235 Buffer.add_buffer bb kb;
6237 Buffer.add_string bb "\n</doc>\n";
6238 end;
6242 let pan, conf =
6243 match state.mode with
6244 | Birdseye (c, pan, _, _, _) ->
6245 let beyecolumns =
6246 match conf.columns with
6247 | Some ((c, _, _), _) -> Some c
6248 | None -> None
6249 and columns =
6250 match c.columns with
6251 | Some (c, _) -> Some (c, [||])
6252 | None -> None
6254 pan, { c with beyecolumns = beyecolumns; columns = columns }
6255 | _ -> state.x, conf
6257 let basename = Filename.basename state.path in
6258 adddoc basename pan (getanchor ())
6259 { conf with
6260 autoscrollstep =
6261 match state.autoscroll with
6262 | Some step -> step
6263 | None -> conf.autoscrollstep }
6264 (if conf.savebmarks then state.bookmarks else []);
6266 Hashtbl.iter (fun path (c, bookmarks, x, y) ->
6267 if basename <> path
6268 then adddoc path x y c bookmarks
6269 ) h;
6270 Buffer.add_string bb "</llppconfig>";
6272 load1 f;
6273 if Buffer.length bb > 0
6274 then
6276 let tmp = !confpath ^ ".tmp" in
6277 let oc = open_out_bin tmp in
6278 Buffer.output_buffer oc bb;
6279 close_out oc;
6280 Unix.rename tmp !confpath;
6281 with exn ->
6282 prerr_endline
6283 ("error while saving configuration: " ^ Printexc.to_string exn)
6285 end;;
6287 let () =
6288 Arg.parse
6289 (Arg.align
6290 [("-p", Arg.String (fun s -> state.password <- s) ,
6291 "<password> Set password");
6293 ("-f", Arg.String (fun s -> Config.fontpath := s),
6294 "<path> Set path to the user interface font");
6296 ("-c", Arg.String (fun s -> Config.confpath := s),
6297 "<path> Set path to the configuration file");
6299 ("-v", Arg.Unit (fun () ->
6300 Printf.printf
6301 "%s\nconfiguration path: %s\n"
6302 (version ())
6303 Config.defconfpath
6305 exit 0), " Print version and exit");
6308 (fun s -> state.path <- s)
6309 ("Usage: " ^ Sys.argv.(0) ^ " [options] some.pdf\nOptions:")
6311 if String.length state.path = 0
6312 then (prerr_endline "file name missing"; exit 1);
6314 Config.load ();
6316 let globalkeyhash = findkeyhash conf "global" in
6317 let wsfd, winw, winh = Wsi.init (object
6318 method expose =
6319 if nogeomcmds state.geomcmds
6320 then display ()
6321 method display = display ()
6322 method reshape w h = reshape w h
6323 method mouse b d x y m = mouse b d x y m
6324 method motion x y = state.mpos <- (x, y); motion x y
6325 method pmotion x y = state.mpos <- (x, y); pmotion x y
6326 method key k m =
6327 let mascm = m land (
6328 Wsi.altmask + Wsi.shiftmask + Wsi.ctrlmask + Wsi.metamask
6329 ) in
6330 match state.keystate with
6331 | KSnone ->
6332 let km = k, mascm in
6333 begin
6334 match
6335 try Hashtbl.find globalkeyhash km
6336 with Not_found ->
6337 let modehash = state.uioh#modehash in
6338 try Hashtbl.find modehash km
6339 with Not_found -> KMinsrt (k, m)
6340 with
6341 | KMinsrt (k, m) -> keyboard k m
6342 | KMinsrl l -> List.iter (fun (k, m) -> keyboard k m) l
6343 | KMmulti (l, r) -> state.keystate <- KSinto (l, r)
6345 | KSinto ((k', m') :: [], insrt) when k'=k && m' land mascm = m' ->
6346 List.iter (fun (k, m) -> keyboard k m) insrt;
6347 state.keystate <- KSnone
6348 | KSinto ((k', m') :: keys, insrt) when k'=k && m' land mascm = m' ->
6349 state.keystate <- KSinto (keys, insrt)
6350 | _ ->
6351 state.keystate <- KSnone
6353 method enter x y = state.mpos <- (x, y); pmotion x y
6354 method leave = state.mpos <- (-1, -1)
6355 method quit = raise Quit
6356 end) conf.winw conf.winh in
6358 state.wsfd <- wsfd;
6360 if not (
6361 List.exists GlMisc.check_extension
6362 [ "GL_ARB_texture_rectangle"
6363 ; "GL_EXT_texture_recangle"
6364 ; "GL_NV_texture_rectangle" ]
6366 then (prerr_endline "OpenGL does not suppport rectangular textures"; exit 1);
6368 let cr, sw = Unix.pipe ()
6369 and sr, cw = Unix.pipe () in
6371 cloexec cr;
6372 cloexec sw;
6373 cloexec sr;
6374 cloexec cw;
6376 setcheckers conf.checkers;
6377 redirectstderr ();
6379 init (cr, cw) (
6380 conf.angle, conf.proportional, (conf.trimmargins, conf.trimfuzz),
6381 conf.texcount, conf.sliceheight, conf.mustoresize, conf.colorspace,
6382 !Config.fontpath
6384 state.sr <- sr;
6385 state.sw <- sw;
6386 state.text <- "Opening " ^ state.path;
6387 opendoc state.path state.password;
6388 state.uioh <- uioh;
6389 setfontsize fstate.fontsize;
6390 reshape winw winh;
6392 let rec loop deadline =
6393 let r =
6394 match state.errfd with
6395 | None -> [state.sr; state.wsfd]
6396 | Some fd -> [state.sr; state.wsfd; fd]
6398 if state.redisplay
6399 then (
6400 state.redisplay <- false;
6401 display ();
6403 let timeout =
6404 let now = now () in
6405 if deadline > now
6406 then (
6407 if deadline = infinity
6408 then ~-.1.0
6409 else max 0.0 (deadline -. now)
6411 else 0.0
6413 let r, _, _ =
6414 try Unix.select r [] [] timeout
6415 with Unix.Unix_error (Unix.EINTR, _, _) -> [], [], []
6417 begin match r with
6418 | [] ->
6419 state.ghyll None;
6420 let newdeadline =
6421 if state.ghyll == noghyll
6422 then
6423 match state.autoscroll with
6424 | Some step when step != 0 ->
6425 let y = state.y + step in
6426 let y =
6427 if y < 0
6428 then state.maxy
6429 else if y >= state.maxy then 0 else y
6431 gotoy y;
6432 if state.mode = View
6433 then state.text <- "";
6434 deadline +. 0.01
6435 | _ -> infinity
6436 else deadline +. 0.01
6438 loop newdeadline
6440 | l ->
6441 let rec checkfds = function
6442 | [] -> ()
6443 | fd :: rest when fd = state.sr ->
6444 let cmd = readcmd state.sr in
6445 act cmd;
6446 checkfds rest
6448 | fd :: rest when fd = state.wsfd ->
6449 Wsi.readresp fd;
6450 checkfds rest
6452 | fd :: rest ->
6453 let s = String.create 80 in
6454 let n = Unix.read fd s 0 80 in
6455 if conf.redirectstderr
6456 then (
6457 Buffer.add_substring state.errmsgs s 0 n;
6458 state.newerrmsgs <- true;
6459 state.redisplay <- true;
6461 else (
6462 prerr_string (String.sub s 0 n);
6463 flush stderr;
6465 checkfds rest
6467 checkfds l;
6468 let newdeadline =
6469 let deadline1 =
6470 if deadline = infinity
6471 then now () +. 0.01
6472 else deadline
6474 match state.autoscroll with
6475 | Some step when step != 0 -> deadline1
6476 | _ -> if state.ghyll == noghyll then infinity else deadline1
6478 loop newdeadline
6479 end;
6482 loop infinity;
6483 with Quit ->
6484 wcmd "quit";
6485 Config.save ();
6486 exit 0;