d0374198c5a25103fb288fbfe8c3b2ac85e2c6fc
[llpp.git] / main.ml
blobd0374198c5a25103fb288fbfe8c3b2ac85e2c6fc
1 open Utils;;
3 exception Quit;;
5 type under =
6 | Unone
7 | Ulinkuri of string
8 | Ulinkgoto of (int * int)
9 | Utext of facename
10 | Uunexpected of string
11 | Ulaunch of string
12 | Unamed of string
13 | Uremote of (string * int)
14 and facename = string;;
16 type params = (angle * proportional * trimparams
17 * texcount * sliceheight * memsize
18 * colorspace * fontpath * trimcachepath
19 * haspbo)
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 dtop = float
36 and fontpath = string
37 and trimcachepath = string
38 and memsize = int
39 and aalevel = int
40 and irect = (int * int * int * int)
41 and trimparams = (trimmargins * irect)
42 and colorspace = | Rgb | Bgr | Gray
43 and haspbo = bool
46 type x = int
47 and y = int
48 and tilex = int
49 and tiley = int
50 and tileparams = (x * y * width * height * tilex * tiley)
53 type link =
54 | Lnotfound
55 | Lfound of int
56 and linkdir =
57 | LDfirst
58 | LDlast
59 | LDfirstvisible of (int * int * int)
60 | LDleft of int
61 | LDright of int
62 | LDdown of int
63 | LDup of int
66 type pagewithlinks =
67 | Pwlnotfound
68 | Pwl of int
71 type keymap =
72 | KMinsrt of key
73 | KMinsrl of key list
74 | KMmulti of key list * key list
75 and key = int * int
76 and keyhash = (key, keymap) Hashtbl.t
77 and keystate =
78 | KSnone
79 | KSinto of (key list * key list)
82 type platform = | Punknown | Plinux | Posx | Psun | Pfreebsd
83 | Pdragonflybsd | Popenbsd | Pnetbsd | Pcygwin;;
85 type pipe = (Unix.file_descr * Unix.file_descr);;
87 external init : pipe -> params -> unit = "ml_init";;
88 external seltext : string -> (int * int * int * int) -> unit = "ml_seltext";;
89 external copysel : Unix.file_descr -> opaque -> unit = "ml_copysel";;
90 external getpdimrect : int -> float array = "ml_getpdimrect";;
91 external whatsunder : string -> int -> int -> under = "ml_whatsunder";;
92 external zoomforh : int -> int -> int -> int -> float = "ml_zoom_for_height";;
93 external drawstr : int -> int -> int -> string -> float = "ml_draw_string";;
94 external measurestr : int -> string -> float = "ml_measure_string";;
95 external getmaxw : unit -> float = "ml_getmaxw";;
96 external postprocess :
97 opaque -> int -> int -> int -> (int * string * int) -> int
98 = "ml_postprocess";;
99 external pagebbox : opaque -> (int * int * int * int) = "ml_getpagebox";;
100 external platform : unit -> platform = "ml_platform";;
101 external setaalevel : int -> unit = "ml_setaalevel";;
102 external realloctexts : int -> bool = "ml_realloctexts";;
103 external findlink : opaque -> linkdir -> link = "ml_findlink";;
104 external getlink : opaque -> int -> under = "ml_getlink";;
105 external getlinkrect : opaque -> int -> irect = "ml_getlinkrect";;
106 external getlinkcount : opaque -> int = "ml_getlinkcount";;
107 external findpwl : int -> int -> pagewithlinks = "ml_find_page_with_links"
108 external popen : string -> (Unix.file_descr * int) list -> unit = "ml_popen";;
109 external getpbo : width -> height -> colorspace -> string = "ml_getpbo";;
110 external freepbo : string -> unit = "ml_freepbo";;
111 external unmappbo : string -> unit = "ml_unmappbo";;
112 external pbousable : unit -> bool = "ml_pbo_usable";;
113 external unproject : opaque -> int -> int -> (int * int) option
114 = "ml_unproject";;
115 external drawtile : tileparams -> opaque -> unit = "ml_drawtile";;
117 let platform_to_string = function
118 | Punknown -> "unknown"
119 | Plinux -> "Linux"
120 | Posx -> "OSX"
121 | Psun -> "Sun"
122 | Pfreebsd -> "FreeBSD"
123 | Pdragonflybsd -> "DragonflyBSD"
124 | Popenbsd -> "OpenBSD"
125 | Pnetbsd -> "NetBSD"
126 | Pcygwin -> "Cygwin"
129 let platform = platform ();;
131 let now = Unix.gettimeofday;;
133 let popen cmd fda =
134 if platform = Pcygwin
135 then (
136 let sh = "/bin/sh" in
137 let args = [|sh; "-c"; cmd|] in
138 let rec std si so se = function
139 | [] -> si, so, se
140 | (fd, 0) :: rest -> std fd so se rest
141 | (fd, -1) :: rest ->
142 Unix.set_close_on_exec fd;
143 std si so se rest
144 | (_, n) :: _ ->
145 failwith ("unexpected fdn in cygwin popen " ^ string_of_int n)
147 let si, so, se = std Unix.stdin Unix.stdout Unix.stderr fda in
148 ignore (Unix.create_process sh args si so se)
150 else popen cmd fda;
153 type mpos = int * int
154 and mstate =
155 | Msel of (mpos * mpos)
156 | Mpan of mpos
157 | Mscrolly | Mscrollx
158 | Mzoom of (int * int)
159 | Mzoomrect of (mpos * mpos)
160 | Mnone
163 type textentry = string * string * onhist option * onkey * ondone * cancelonempty
164 and onkey = string -> int -> te
165 and ondone = string -> unit
166 and histcancel = unit -> unit
167 and onhist = ((histcmd -> string) * histcancel)
168 and histcmd = HCnext | HCprev | HCfirst | HClast
169 and cancelonempty = bool
170 and te =
171 | TEstop
172 | TEdone of string
173 | TEcont of string
174 | TEswitch of textentry
177 type 'a circbuf =
178 { store : 'a array
179 ; mutable rc : int
180 ; mutable wc : int
181 ; mutable len : int
185 let bound v minv maxv =
186 max minv (min maxv v);
189 let cbnew n v =
190 { store = Array.create n v
191 ; rc = 0
192 ; wc = 0
193 ; len = 0
197 let cbcap b = Array.length b.store;;
199 let cbput b v =
200 let cap = cbcap b in
201 b.store.(b.wc) <- v;
202 b.wc <- (b.wc + 1) mod cap;
203 b.rc <- b.wc;
204 b.len <- min (b.len + 1) cap;
207 let cbempty b = b.len = 0;;
209 let cbgetg b circular dir =
210 if cbempty b
211 then b.store.(0)
212 else
213 let rc = b.rc + dir in
214 let rc =
215 if circular
216 then (
217 if rc = -1
218 then b.len-1
219 else (
220 if rc >= b.len
221 then 0
222 else rc
225 else bound rc 0 (b.len-1)
227 b.rc <- rc;
228 b.store.(rc);
231 let cbget b = cbgetg b false;;
232 let cbgetc b = cbgetg b true;;
234 let drawstring size x y s =
235 Gl.enable `blend;
236 Gl.enable `texture_2d;
237 GlFunc.blend_func `src_alpha `one_minus_src_alpha;
238 ignore (drawstr size x y s);
239 Gl.disable `blend;
240 Gl.disable `texture_2d;
243 let drawstring1 size x y s =
244 drawstr size x y s;
247 let drawstring2 size x y fmt =
248 Printf.kprintf (drawstring size (x+1) (y+size+1)) fmt
251 type page =
252 { pageno : int
253 ; pagedimno : int
254 ; pagew : int
255 ; pageh : int
256 ; pagex : int
257 ; pagey : int
258 ; pagevw : int
259 ; pagevh : int
260 ; pagedispx : int
261 ; pagedispy : int
262 ; pagecol : int
266 let debugl l =
267 dolog "l %d dim=%d {" l.pageno l.pagedimno;
268 dolog " WxH %dx%d" l.pagew l.pageh;
269 dolog " vWxH %dx%d" l.pagevw l.pagevh;
270 dolog " pagex,y %d,%d" l.pagex l.pagey;
271 dolog " dispx,y %d,%d" l.pagedispx l.pagedispy;
272 dolog " column %d" l.pagecol;
273 dolog "}";
276 let debugrect (x0, y0, x1, y1, x2, y2, x3, y3) =
277 dolog "rect {";
278 dolog " x0,y0=(% f, % f)" x0 y0;
279 dolog " x1,y1=(% f, % f)" x1 y1;
280 dolog " x2,y2=(% f, % f)" x2 y2;
281 dolog " x3,y3=(% f, % f)" x3 y3;
282 dolog "}";
285 type multicolumns = multicol * pagegeom
286 and singlecolumn = pagegeom
287 and splitcolumns = columncount * pagegeom
288 and pagegeom = ((pdimno * x * y * (pageno * width * height * leftx)) array)
289 and multicol = columncount * covercount * covercount
290 and pdimno = int
291 and columncount = int
292 and covercount = int;;
294 type conf =
295 { mutable scrollbw : int
296 ; mutable scrollh : int
297 ; mutable icase : bool
298 ; mutable preload : bool
299 ; mutable pagebias : int
300 ; mutable verbose : bool
301 ; mutable debug : bool
302 ; mutable scrollstep : int
303 ; mutable hscrollstep : int
304 ; mutable maxhfit : bool
305 ; mutable crophack : bool
306 ; mutable autoscrollstep : int
307 ; mutable maxwait : float option
308 ; mutable hlinks : bool
309 ; mutable underinfo : bool
310 ; mutable interpagespace : interpagespace
311 ; mutable zoom : float
312 ; mutable presentation : bool
313 ; mutable angle : angle
314 ; mutable cwinw : int
315 ; mutable cwinh : int
316 ; mutable savebmarks : bool
317 ; mutable proportional : proportional
318 ; mutable trimmargins : trimmargins
319 ; mutable trimfuzz : irect
320 ; mutable memlimit : memsize
321 ; mutable texcount : texcount
322 ; mutable sliceheight : sliceheight
323 ; mutable thumbw : width
324 ; mutable jumpback : bool
325 ; mutable bgcolor : float * float * float
326 ; mutable bedefault : bool
327 ; mutable scrollbarinpm : bool
328 ; mutable tilew : int
329 ; mutable tileh : int
330 ; mutable mustoresize : memsize
331 ; mutable checkers : bool
332 ; mutable aalevel : int
333 ; mutable urilauncher : string
334 ; mutable pathlauncher : string
335 ; mutable colorspace : colorspace
336 ; mutable invert : bool
337 ; mutable colorscale : float
338 ; mutable redirectstderr : bool
339 ; mutable ghyllscroll : (int * int * int) option
340 ; mutable columns : columns
341 ; mutable beyecolumns : columncount option
342 ; mutable selcmd : string
343 ; mutable updatecurs : bool
344 ; mutable keyhashes : (string * keyhash) list
345 ; mutable hfsize : int
346 ; mutable pgscale : float
347 ; mutable usepbo : bool
348 ; mutable wheelbypage : bool
349 ; mutable stcmd : string
351 and columns =
352 | Csingle of singlecolumn
353 | Cmulti of multicolumns
354 | Csplit of splitcolumns
357 type anchor = pageno * top * dtop;;
359 type outline = string * int * anchor;;
361 type rect = float * float * float * float * float * float * float * float;;
363 type tile = opaque * pixmapsize * elapsed
364 and elapsed = float;;
365 type pagemapkey = pageno * gen;;
366 type tilemapkey = pageno * gen * colorspace * angle * width * height * col * row
367 and row = int
368 and col = int;;
370 let emptyanchor = (0, 0.0, 0.0);;
372 type infochange = | Memused | Docinfo | Pdim;;
374 class type uioh = object
375 method display : unit
376 method key : int -> int -> uioh
377 method button : int -> bool -> int -> int -> int -> uioh
378 method motion : int -> int -> uioh
379 method pmotion : int -> int -> uioh
380 method infochanged : infochange -> unit
381 method scrollpw : (int * float * float)
382 method scrollph : (int * float * float)
383 method modehash : keyhash
384 end;;
386 type mode =
387 | Birdseye of (conf * leftx * pageno * pageno * anchor)
388 | Textentry of (textentry * onleave)
389 | View
390 | LinkNav of linktarget
391 and onleave = leavetextentrystatus -> unit
392 and leavetextentrystatus = | Cancel | Confirm
393 and helpitem = string * int * action
394 and action =
395 | Noaction
396 | Action of (uioh -> uioh)
397 and linktarget =
398 | Ltexact of (pageno * int)
399 | Ltgendir of int
402 let isbirdseye = function Birdseye _ -> true | _ -> false;;
403 let istextentry = function Textentry _ -> true | _ -> false;;
405 type currently =
406 | Idle
407 | Loading of (page * gen)
408 | Tiling of (
409 page * opaque * colorspace * angle * gen * col * row * width * height
411 | Outlining of outline list
414 let emptykeyhash = Hashtbl.create 0;;
415 let nouioh : uioh = object (self)
416 method display = ()
417 method key _ _ = self
418 method button _ _ _ _ _ = self
419 method motion _ _ = self
420 method pmotion _ _ = self
421 method infochanged _ = ()
422 method scrollpw = (0, nan, nan)
423 method scrollph = (0, nan, nan)
424 method modehash = emptykeyhash
425 end;;
427 type state =
428 { mutable sr : Unix.file_descr
429 ; mutable sw : Unix.file_descr
430 ; mutable wsfd : Unix.file_descr
431 ; mutable errfd : Unix.file_descr option
432 ; mutable stderr : Unix.file_descr
433 ; mutable errmsgs : Buffer.t
434 ; mutable newerrmsgs : bool
435 ; mutable w : int
436 ; mutable x : int
437 ; mutable y : int
438 ; mutable scrollw : int
439 ; mutable hscrollh : int
440 ; mutable anchor : anchor
441 ; mutable ranchors : (string * string * anchor) list
442 ; mutable maxy : int
443 ; mutable layout : page list
444 ; pagemap : (pagemapkey, opaque) Hashtbl.t
445 ; tilemap : (tilemapkey, tile) Hashtbl.t
446 ; tilelru : (tilemapkey * opaque * pixmapsize) Queue.t
447 ; mutable pdims : (pageno * width * height * leftx) list
448 ; mutable pagecount : int
449 ; mutable currently : currently
450 ; mutable mstate : mstate
451 ; mutable searchpattern : string
452 ; mutable rects : (pageno * recttype * rect) list
453 ; mutable rects1 : (pageno * recttype * rect) list
454 ; mutable text : string
455 ; mutable winstate : Wsi.winstate list
456 ; mutable mode : mode
457 ; mutable uioh : uioh
458 ; mutable outlines : outline array
459 ; mutable bookmarks : outline list
460 ; mutable path : string
461 ; mutable password : string
462 ; mutable nameddest : string
463 ; mutable geomcmds : (string * ((string * (unit -> unit)) list))
464 ; mutable memused : memsize
465 ; mutable gen : gen
466 ; mutable throttle : (page list * int * float) option
467 ; mutable autoscroll : int option
468 ; mutable ghyll : (int option -> unit)
469 ; mutable help : helpitem array
470 ; mutable docinfo : (int * string) list
471 ; mutable texid : GlTex.texture_id option
472 ; hists : hists
473 ; mutable prevzoom : float
474 ; mutable progress : float
475 ; mutable redisplay : bool
476 ; mutable mpos : mpos
477 ; mutable keystate : keystate
478 ; mutable glinks : bool
479 ; mutable prevcolumns : (columns * float) option
480 ; mutable wthack : bool
481 ; mutable winw : int
482 ; mutable winh : int
483 ; mutable reprf : (unit -> unit)
485 and hists =
486 { pat : string circbuf
487 ; pag : string circbuf
488 ; nav : anchor circbuf
489 ; sel : string circbuf
493 let defconf =
494 { scrollbw = 7
495 ; scrollh = 12
496 ; icase = true
497 ; preload = true
498 ; pagebias = 0
499 ; verbose = false
500 ; debug = false
501 ; scrollstep = 24
502 ; hscrollstep = 24
503 ; maxhfit = true
504 ; crophack = false
505 ; autoscrollstep = 2
506 ; maxwait = None
507 ; hlinks = false
508 ; underinfo = false
509 ; interpagespace = 2
510 ; zoom = 1.0
511 ; presentation = false
512 ; angle = 0
513 ; cwinw = 900
514 ; cwinh = 900
515 ; savebmarks = true
516 ; proportional = true
517 ; trimmargins = false
518 ; trimfuzz = (0,0,0,0)
519 ; memlimit = 32 lsl 20
520 ; texcount = 256
521 ; sliceheight = 24
522 ; thumbw = 76
523 ; jumpback = true
524 ; bgcolor = (0.5, 0.5, 0.5)
525 ; bedefault = false
526 ; scrollbarinpm = true
527 ; tilew = 2048
528 ; tileh = 2048
529 ; mustoresize = 256 lsl 20
530 ; checkers = true
531 ; aalevel = 8
532 ; urilauncher =
533 (match platform with
534 | Plinux | Pfreebsd | Pdragonflybsd
535 | Popenbsd | Pnetbsd | Psun -> "xdg-open \"%s\""
536 | Posx -> "open \"%s\""
537 | Pcygwin -> "cygstart \"%s\""
538 | Punknown -> "echo %s")
539 ; pathlauncher = "lp \"%s\""
540 ; selcmd =
541 (match platform with
542 | Plinux | Pfreebsd | Pdragonflybsd
543 | Popenbsd | Pnetbsd | Psun -> "xsel -i"
544 | Posx -> "pbcopy"
545 | Pcygwin -> "wsel"
546 | Punknown -> "cat")
547 ; colorspace = Rgb
548 ; invert = false
549 ; colorscale = 1.0
550 ; redirectstderr = false
551 ; ghyllscroll = None
552 ; columns = Csingle [||]
553 ; beyecolumns = None
554 ; updatecurs = false
555 ; hfsize = 12
556 ; pgscale = 1.0
557 ; usepbo = false
558 ; wheelbypage = false
559 ; stcmd = "echo SyncTex"
560 ; keyhashes =
561 let mk n = (n, Hashtbl.create 1) in
562 [ mk "global"
563 ; mk "info"
564 ; mk "help"
565 ; mk "outline"
566 ; mk "listview"
567 ; mk "birdseye"
568 ; mk "textentry"
569 ; mk "links"
570 ; mk "view"
575 let wtmode = ref false;;
577 let findkeyhash c name =
578 try List.assoc name c.keyhashes
579 with Not_found -> failwith ("invalid mode name `" ^ name ^ "'")
582 let conf = { defconf with angle = defconf.angle };;
584 let pgscale h = truncate (float h *. conf.pgscale);;
586 type fontstate =
587 { mutable fontsize : int
588 ; mutable wwidth : float
589 ; mutable maxrows : int
593 let fstate =
594 { fontsize = 14
595 ; wwidth = nan
596 ; maxrows = -1
600 let geturl s =
601 let colonpos = try String.index s ':' with Not_found -> -1 in
602 let len = String.length s in
603 if colonpos >= 0 && colonpos + 3 < len
604 then (
605 if s.[colonpos+1] = '/' && s.[colonpos+2] = '/'
606 then
607 let schemestartpos =
608 try String.rindex_from s colonpos ' '
609 with Not_found -> -1
611 let scheme =
612 String.sub s (schemestartpos+1) (colonpos-1-schemestartpos)
614 match scheme with
615 | "http" | "ftp" | "mailto" ->
616 let epos =
617 try String.index_from s colonpos ' '
618 with Not_found -> len
620 String.sub s (schemestartpos+1) (epos-1-schemestartpos)
621 | _ -> ""
622 else ""
624 else ""
627 let gotouri uri =
628 if String.length conf.urilauncher = 0
629 then print_endline uri
630 else (
631 let url = geturl uri in
632 if String.length url = 0
633 then print_endline uri
634 else
635 let re = Str.regexp "%s" in
636 let command = Str.global_replace re url conf.urilauncher in
637 try popen command []
638 with exn ->
639 Printf.eprintf
640 "failed to execute `%s': %s\n" command (exntos exn);
641 flush stderr;
645 let version () =
646 Printf.sprintf "llpp version %s (%s/%dbit, ocaml %s)" Help.version
647 (platform_to_string platform) Sys.word_size Sys.ocaml_version
650 let makehelp () =
651 let strings = version () :: "" :: Help.keys in
652 Array.of_list (
653 List.map (fun s ->
654 let url = geturl s in
655 if String.length url > 0
656 then (s, 0, Action (fun u -> gotouri url; u))
657 else (s, 0, Noaction)
658 ) strings);
661 let noghyll _ = ();;
662 let firstgeomcmds = "", [];;
663 let noreprf () = ();;
665 let state =
666 { sr = Unix.stdin
667 ; sw = Unix.stdin
668 ; wsfd = Unix.stdin
669 ; errfd = None
670 ; stderr = Unix.stderr
671 ; errmsgs = Buffer.create 0
672 ; newerrmsgs = false
673 ; x = 0
674 ; y = 0
675 ; w = 0
676 ; scrollw = 0
677 ; hscrollh = 0
678 ; anchor = emptyanchor
679 ; ranchors = []
680 ; layout = []
681 ; maxy = max_int
682 ; tilelru = Queue.create ()
683 ; pagemap = Hashtbl.create 10
684 ; tilemap = Hashtbl.create 10
685 ; pdims = []
686 ; pagecount = 0
687 ; currently = Idle
688 ; mstate = Mnone
689 ; rects = []
690 ; rects1 = []
691 ; text = ""
692 ; mode = View
693 ; winstate = []
694 ; searchpattern = ""
695 ; outlines = [||]
696 ; bookmarks = []
697 ; path = ""
698 ; password = ""
699 ; nameddest = ""
700 ; geomcmds = firstgeomcmds
701 ; hists =
702 { nav = cbnew 10 emptyanchor
703 ; pat = cbnew 10 ""
704 ; pag = cbnew 10 ""
705 ; sel = cbnew 10 ""
707 ; memused = 0
708 ; gen = 0
709 ; throttle = None
710 ; autoscroll = None
711 ; ghyll = noghyll
712 ; help = makehelp ()
713 ; docinfo = []
714 ; texid = None
715 ; prevzoom = 1.0
716 ; progress = -1.0
717 ; uioh = nouioh
718 ; redisplay = true
719 ; mpos = (-1, -1)
720 ; keystate = KSnone
721 ; glinks = false
722 ; prevcolumns = None
723 ; wthack = false
724 ; winw = -1
725 ; winh = -1
726 ; reprf = noreprf
730 let setfontsize n =
731 fstate.fontsize <- n;
732 fstate.wwidth <- measurestr fstate.fontsize "w";
733 fstate.maxrows <- (state.winh - fstate.fontsize - 1) / (fstate.fontsize + 1);
736 let vlog fmt =
737 if conf.verbose
738 then
739 Printf.kprintf prerr_endline fmt
740 else
741 Printf.kprintf ignore fmt
744 let launchpath () =
745 if String.length conf.pathlauncher = 0
746 then print_endline state.path
747 else (
748 let re = Str.regexp "%s" in
749 let command = Str.global_replace re state.path conf.pathlauncher in
750 try popen command []
751 with exn ->
752 Printf.eprintf "failed to execute `%s': %s\n" command (exntos exn);
753 flush stderr;
757 module Ne = struct
758 type 'a t = | Res of 'a | Exn of exn;;
760 let pipe () =
761 try Res (Unix.pipe ())
762 with exn -> Exn exn
765 let clo fd f =
766 try tempfailureretry Unix.close fd
767 with exn -> f (exntos exn)
770 let dup fd =
771 try Res (tempfailureretry Unix.dup fd)
772 with exn -> Exn exn
775 let dup2 fd1 fd2 =
776 try Res (tempfailureretry (Unix.dup2 fd1) fd2)
777 with exn -> Exn exn
779 end;;
781 let redirectstderr () =
782 let clofail what errmsg = dolog "failed to close %s: %s" what errmsg in
783 if conf.redirectstderr
784 then
785 match Ne.pipe () with
786 | Ne.Exn exn ->
787 dolog "failed to create stderr redirection pipes: %s" (exntos exn)
789 | Ne.Res (r, w) ->
790 begin match Ne.dup Unix.stderr with
791 | Ne.Exn exn ->
792 dolog "failed to dup stderr: %s" (exntos exn);
793 Ne.clo r (clofail "pipe/r");
794 Ne.clo w (clofail "pipe/w");
796 | Ne.Res dupstderr ->
797 begin match Ne.dup2 w Unix.stderr with
798 | Ne.Exn exn ->
799 dolog "failed to dup2 to stderr: %s" (exntos exn);
800 Ne.clo dupstderr (clofail "stderr duplicate");
801 Ne.clo r (clofail "redir pipe/r");
802 Ne.clo w (clofail "redir pipe/w");
804 | Ne.Res () ->
805 state.stderr <- dupstderr;
806 state.errfd <- Some r;
807 end;
809 else (
810 state.newerrmsgs <- false;
811 begin match state.errfd with
812 | Some fd ->
813 begin match Ne.dup2 state.stderr Unix.stderr with
814 | Ne.Exn exn ->
815 dolog "failed to dup2 original stderr: %s" (exntos exn)
816 | Ne.Res () ->
817 Ne.clo fd (clofail "dup of stderr");
818 state.errfd <- None;
819 end;
820 | None -> ()
821 end;
822 prerr_string (Buffer.contents state.errmsgs);
823 flush stderr;
824 Buffer.clear state.errmsgs;
828 module G =
829 struct
830 let postRedisplay who =
831 if conf.verbose
832 then prerr_endline ("redisplay for " ^ who);
833 state.redisplay <- true;
835 end;;
837 let getopaque pageno =
838 try Some (Hashtbl.find state.pagemap (pageno, state.gen))
839 with Not_found -> None
842 let putopaque pageno opaque =
843 Hashtbl.replace state.pagemap (pageno, state.gen) opaque
846 let pagetranslatepoint l x y =
847 let dy = y - l.pagedispy in
848 let y = dy + l.pagey in
849 let dx = x - l.pagedispx in
850 let x = dx + l.pagex in
851 (x, y);
854 let onppundermouse g x y d =
855 let rec f = function
856 | l :: rest ->
857 begin match getopaque l.pageno with
858 | Some opaque ->
859 let x0 = l.pagedispx in
860 let x1 = x0 + l.pagevw in
861 let y0 = l.pagedispy in
862 let y1 = y0 + l.pagevh in
863 if y >= y0 && y <= y1 && x >= x0 && x <= x1
864 then
865 let px, py = pagetranslatepoint l x y in
866 match g opaque l px py with
867 | Some res -> res
868 | None -> f rest
869 else f rest
870 | _ ->
871 f rest
873 | [] -> d
875 f state.layout
878 let getunder x y =
879 let g opaque _ px py =
880 match whatsunder opaque px py with
881 | Unone -> None
882 | under -> Some under
884 onppundermouse g x y Unone
887 let unproject x y =
888 let g opaque l x y =
889 match unproject opaque x y with
890 | Some (x, y) -> Some (Some (l.pageno, x, y))
891 | None -> None
893 onppundermouse g x y None;
896 let showtext c s =
897 state.text <- Printf.sprintf "%c%s" c s;
898 G.postRedisplay "showtext";
901 let undertext = function
902 | Unone -> "none"
903 | Ulinkuri s -> s
904 | Ulinkgoto (pageno, _) -> Printf.sprintf "%s: page %d" state.path (pageno+1)
905 | Utext s -> "font: " ^ s
906 | Uunexpected s -> "unexpected: " ^ s
907 | Ulaunch s -> "launch: " ^ s
908 | Unamed s -> "named: " ^ s
909 | Uremote (filename, pageno) ->
910 Printf.sprintf "%s: page %d" filename (pageno+1)
913 let updateunder x y =
914 match getunder x y with
915 | Unone -> Wsi.setcursor Wsi.CURSOR_INHERIT
916 | Ulinkuri uri ->
917 if conf.underinfo then showtext 'u' ("ri: " ^ uri);
918 Wsi.setcursor Wsi.CURSOR_INFO
919 | Ulinkgoto (pageno, _) ->
920 if conf.underinfo
921 then showtext 'p' ("age: " ^ string_of_int (pageno+1));
922 Wsi.setcursor Wsi.CURSOR_INFO
923 | Utext s ->
924 if conf.underinfo then showtext 'f' ("ont: " ^ s);
925 Wsi.setcursor Wsi.CURSOR_TEXT
926 | Uunexpected s ->
927 if conf.underinfo then showtext 'u' ("nexpected: " ^ s);
928 Wsi.setcursor Wsi.CURSOR_INHERIT
929 | Ulaunch s ->
930 if conf.underinfo then showtext 'l' ("aunch: " ^ s);
931 Wsi.setcursor Wsi.CURSOR_INHERIT
932 | Unamed s ->
933 if conf.underinfo then showtext 'n' ("amed: " ^ s);
934 Wsi.setcursor Wsi.CURSOR_INHERIT
935 | Uremote (filename, pageno) ->
936 if conf.underinfo then showtext 'r'
937 (Printf.sprintf "emote: %s (%d)" filename (pageno+1));
938 Wsi.setcursor Wsi.CURSOR_INFO
941 let showlinktype under =
942 if conf.underinfo
943 then
944 match under with
945 | Unone -> ()
946 | under ->
947 let s = undertext under in
948 showtext ' ' s
951 let addchar s c =
952 let b = Buffer.create (String.length s + 1) in
953 Buffer.add_string b s;
954 Buffer.add_char b c;
955 Buffer.contents b;
958 let colorspace_of_string s =
959 match String.lowercase s with
960 | "rgb" -> Rgb
961 | "bgr" -> Bgr
962 | "gray" -> Gray
963 | _ -> failwith "invalid colorspace"
966 let int_of_colorspace = function
967 | Rgb -> 0
968 | Bgr -> 1
969 | Gray -> 2
972 let colorspace_of_int = function
973 | 0 -> Rgb
974 | 1 -> Bgr
975 | 2 -> Gray
976 | n -> failwith ("invalid colorspace index " ^ string_of_int n)
979 let colorspace_to_string = function
980 | Rgb -> "rgb"
981 | Bgr -> "bgr"
982 | Gray -> "gray"
985 let intentry_with_suffix text key =
986 let c =
987 if key >= 32 && key < 127
988 then Char.chr key
989 else '\000'
991 match Char.lowercase c with
992 | '0' .. '9' ->
993 let text = addchar text c in
994 TEcont text
996 | 'k' | 'm' | 'g' ->
997 let text = addchar text c in
998 TEcont text
1000 | _ ->
1001 state.text <- Printf.sprintf "invalid char (%d, `%c')" key c;
1002 TEcont text
1005 let multicolumns_to_string (n, a, b) =
1006 if a = 0 && b = 0
1007 then Printf.sprintf "%d" n
1008 else Printf.sprintf "%d,%d,%d" n a b;
1011 let multicolumns_of_string s =
1013 (int_of_string s, 0, 0)
1014 with _ ->
1015 Scanf.sscanf s "%u,%u,%u" (fun n a b ->
1016 if a > 1 || b > 1
1017 then failwith "subtly broken"; (n, a, b)
1021 let readcmd fd =
1022 let s = "xxxx" in
1023 let n = tempfailureretry (Unix.read fd s 0) 4 in
1024 if n != 4 then failwith "incomplete read(len)";
1025 let len = 0
1026 lor (Char.code s.[0] lsl 24)
1027 lor (Char.code s.[1] lsl 16)
1028 lor (Char.code s.[2] lsl 8)
1029 lor (Char.code s.[3] lsl 0)
1031 let s = String.create len in
1032 let n = tempfailureretry (Unix.read fd s 0) len in
1033 if n != len then failwith "incomplete read(data)";
1037 let btod b = if b then 1 else 0;;
1039 let wcmd fmt =
1040 let b = Buffer.create 16 in
1041 Buffer.add_string b "llll";
1042 Printf.kbprintf
1043 (fun b ->
1044 let s = Buffer.contents b in
1045 let n = String.length s in
1046 let len = n - 4 in
1047 (* dolog "wcmd %S" (String.sub s 4 len); *)
1048 s.[0] <- Char.chr ((len lsr 24) land 0xff);
1049 s.[1] <- Char.chr ((len lsr 16) land 0xff);
1050 s.[2] <- Char.chr ((len lsr 8) land 0xff);
1051 s.[3] <- Char.chr (len land 0xff);
1052 let n' = tempfailureretry (Unix.write state.sw s 0) n in
1053 if n' != n then failwith "write failed";
1054 ) b fmt;
1057 let calcips h =
1058 let d = state.winh - h in
1059 max conf.interpagespace ((d + 1) / 2)
1062 let rowyh (c, coverA, coverB) b n =
1063 if c = 1 || (n < coverA || n >= state.pagecount - coverB)
1064 then
1065 let _, _, vy, (_, _, h, _) = b.(n) in
1066 (vy, h)
1067 else
1068 let n' = n - coverA in
1069 let d = n' mod c in
1070 let s = n - d in
1071 let e = min state.pagecount (s + c) in
1072 let rec find m miny maxh = if m = e then miny, maxh else
1073 let _, _, y, (_, _, h, _) = b.(m) in
1074 let miny = min miny y in
1075 let maxh = max maxh h in
1076 find (m+1) miny maxh
1077 in find s max_int 0
1080 let calcheight () =
1081 match conf.columns with
1082 | Cmulti ((_, _, _) as cl, b) ->
1083 if Array.length b > 0
1084 then
1085 let y, h = rowyh cl b (Array.length b - 1) in
1086 y + h + (if conf.presentation then calcips h else 0)
1087 else 0
1088 | Csingle b ->
1089 if Array.length b > 0
1090 then
1091 let (_, _, y, (_, _, h, _)) = b.(Array.length b - 1) in
1092 y + h + (if conf.presentation then calcips h else 0)
1093 else 0
1094 | Csplit (_, b) ->
1095 if Array.length b > 0
1096 then
1097 let (_, _, y, (_, _, h, _)) = b.(Array.length b - 1) in
1098 y + h
1099 else 0
1102 let getpageyh pageno =
1103 let pageno = bound pageno 0 (state.pagecount-1) in
1104 match conf.columns with
1105 | Csingle b ->
1106 if Array.length b = 0
1107 then 0, 0
1108 else
1109 let (_, _, y, (_, _, h, _)) = b.(pageno) in
1110 let y =
1111 if conf.presentation
1112 then y - calcips h
1113 else y
1115 y, h
1116 | Cmulti (cl, b) ->
1117 if Array.length b = 0
1118 then 0, 0
1119 else
1120 let y, h = rowyh cl b pageno in
1121 let y =
1122 if conf.presentation
1123 then y - calcips h
1124 else y
1126 y, h
1127 | Csplit (c, b) ->
1128 if Array.length b = 0
1129 then 0, 0
1130 else
1131 let n = pageno*c in
1132 let (_, _, y, (_, _, h, _)) = b.(n) in
1133 y, h
1136 let getpagedim pageno =
1137 let rec f ppdim l =
1138 match l with
1139 | (n, _, _, _) as pdim :: rest ->
1140 if n >= pageno
1141 then (if n = pageno then pdim else ppdim)
1142 else f pdim rest
1144 | [] -> ppdim
1146 f (-1, -1, -1, -1) state.pdims
1149 let getpagey pageno = fst (getpageyh pageno);;
1151 let nogeomcmds cmds =
1152 match cmds with
1153 | s, [] -> String.length s = 0
1154 | _ -> false
1157 let page_of_y y =
1158 let ((c, coverA, coverB) as cl), b =
1159 match conf.columns with
1160 | Csingle b -> (1, 0, 0), b
1161 | Cmulti (c, b) -> c, b
1162 | Csplit (_, b) -> (1, 0, 0), b
1164 if Array.length b = 0
1165 then -1
1166 else
1167 let rec bsearch nmin nmax =
1168 if nmin > nmax
1169 then bound nmin 0 (state.pagecount-1)
1170 else
1171 let n = (nmax + nmin) / 2 in
1172 let vy, h = rowyh cl b n in
1173 let y0, y1 =
1174 if conf.presentation
1175 then
1176 let ips = calcips h in
1177 let y0 = vy - ips in
1178 let y1 = vy + h + ips in
1179 y0, y1
1180 else (
1181 if n = 0
1182 then 0, vy + h + conf.interpagespace
1183 else
1184 let y0 = vy - conf.interpagespace in
1185 y0, y0 + h + conf.interpagespace
1188 if y >= y0 && y < y1
1189 then (
1190 if c = 1
1191 then n
1192 else (
1193 if n > coverA
1194 then
1195 if n < state.pagecount - coverB
1196 then ((n-coverA)/c)*c + coverA
1197 else n
1198 else n
1201 else (
1202 if y > y0
1203 then bsearch (n+1) nmax
1204 else bsearch nmin (n-1)
1207 let r = bsearch 0 (state.pagecount-1) in
1211 let layoutN ((columns, coverA, coverB), b) y sh =
1212 let sh = sh - state.hscrollh in
1213 let rec fold accu n =
1214 if n = Array.length b
1215 then accu
1216 else
1217 let pdimno, dx, vy, (_, w, h, xoff) = b.(n) in
1218 if (vy - y) > sh &&
1219 (n = coverA - 1
1220 || n = state.pagecount - coverB
1221 || (n - coverA) mod columns = columns - 1)
1222 then accu
1223 else
1224 let accu =
1225 if vy + h > y
1226 then
1227 let pagey = max 0 (y - vy) in
1228 let pagedispy = if pagey > 0 then 0 else vy - y in
1229 let pagedispx, pagex =
1230 let pdx =
1231 if n = coverA - 1 || n = state.pagecount - coverB
1232 then state.x + (state.winw - state.scrollw - w) / 2
1233 else dx + xoff + state.x
1235 if pdx < 0
1236 then 0, -pdx
1237 else pdx, 0
1239 let pagevw =
1240 let vw = state.winw - state.scrollw - pagedispx in
1241 let pw = w - pagex in
1242 min vw pw
1244 let pagevh = min (h - pagey) (sh - pagedispy) in
1245 if pagevw > 0 && pagevh > 0
1246 then
1247 let e =
1248 { pageno = n
1249 ; pagedimno = pdimno
1250 ; pagew = w
1251 ; pageh = h
1252 ; pagex = pagex
1253 ; pagey = pagey
1254 ; pagevw = pagevw
1255 ; pagevh = pagevh
1256 ; pagedispx = pagedispx
1257 ; pagedispy = pagedispy
1258 ; pagecol = 0
1261 e :: accu
1262 else
1263 accu
1264 else
1265 accu
1267 fold accu (n+1)
1269 List.rev (fold [] (page_of_y y));
1272 let layoutS (columns, b) y sh =
1273 let sh = sh - state.hscrollh in
1274 let rec fold accu n =
1275 if n = Array.length b
1276 then accu
1277 else
1278 let pdimno, px, vy, (_, pagew, pageh, xoff) = b.(n) in
1279 if (vy - y) > sh
1280 then accu
1281 else
1282 let accu =
1283 if vy + pageh > y
1284 then
1285 let x = xoff + state.x in
1286 let pagey = max 0 (y - vy) in
1287 let pagedispy = if pagey > 0 then 0 else vy - y in
1288 let pagedispx, pagex =
1289 if px = 0
1290 then (
1291 if x < 0
1292 then 0, -x
1293 else x, 0
1295 else (
1296 let px = px - x in
1297 if px < 0
1298 then -px, 0
1299 else 0, px
1302 let pagecolw = pagew/columns in
1303 let pagedispx =
1304 if pagecolw < state.winw
1305 then pagedispx + ((state.winw - state.scrollw - pagecolw) / 2)
1306 else pagedispx
1308 let pagevw =
1309 let vw = state.winw - pagedispx - state.scrollw in
1310 let pw = pagew - pagex in
1311 min vw pw
1313 let pagevw = min pagevw pagecolw in
1314 let pagevh = min (pageh - pagey) (sh - pagedispy) in
1315 if pagevw > 0 && pagevh > 0
1316 then
1317 let e =
1318 { pageno = n/columns
1319 ; pagedimno = pdimno
1320 ; pagew = pagew
1321 ; pageh = pageh
1322 ; pagex = pagex
1323 ; pagey = pagey
1324 ; pagevw = pagevw
1325 ; pagevh = pagevh
1326 ; pagedispx = pagedispx
1327 ; pagedispy = pagedispy
1328 ; pagecol = n mod columns
1331 e :: accu
1332 else
1333 accu
1334 else
1335 accu
1337 fold accu (n+1)
1339 List.rev (fold [] 0)
1342 let layout y sh =
1343 if nogeomcmds state.geomcmds
1344 then
1345 match conf.columns with
1346 | Csingle b -> layoutN ((1, 0, 0), b) y sh
1347 | Cmulti c -> layoutN c y sh
1348 | Csplit s -> layoutS s y sh
1349 else []
1352 let clamp incr =
1353 let y = state.y + incr in
1354 let y = max 0 y in
1355 let y = min y (state.maxy - (if conf.maxhfit then state.winh else 0)) in
1359 let itertiles l f =
1360 let tilex = l.pagex mod conf.tilew in
1361 let tiley = l.pagey mod conf.tileh in
1363 let col = l.pagex / conf.tilew in
1364 let row = l.pagey / conf.tileh in
1366 let rec rowloop row y0 dispy h =
1367 if h = 0
1368 then ()
1369 else (
1370 let dh = conf.tileh - y0 in
1371 let dh = min h dh in
1372 let rec colloop col x0 dispx w =
1373 if w = 0
1374 then ()
1375 else (
1376 let dw = conf.tilew - x0 in
1377 let dw = min w dw in
1379 f col row dispx dispy x0 y0 dw dh;
1380 colloop (col+1) 0 (dispx+dw) (w-dw)
1383 colloop col tilex l.pagedispx l.pagevw;
1384 rowloop (row+1) 0 (dispy+dh) (h-dh)
1387 if l.pagevw > 0 && l.pagevh > 0
1388 then rowloop row tiley l.pagedispy l.pagevh;
1391 let gettileopaque l col row =
1392 let key =
1393 l.pageno, state.gen, conf.colorspace, conf.angle, l.pagew, l.pageh, col, row
1395 try Some (Hashtbl.find state.tilemap key)
1396 with Not_found -> None
1399 let puttileopaque l col row gen colorspace angle opaque size elapsed =
1400 let key = l.pageno, gen, colorspace, angle, l.pagew, l.pageh, col, row in
1401 Hashtbl.add state.tilemap key (opaque, size, elapsed)
1404 let drawtiles l color =
1405 GlDraw.color color;
1406 let f col row x y tilex tiley w h =
1407 match gettileopaque l col row with
1408 | Some (opaque, _, t) ->
1409 let params = x, y, w, h, tilex, tiley in
1410 if conf.invert
1411 then (
1412 Gl.enable `blend;
1413 GlFunc.blend_func `zero `one_minus_src_color;
1415 drawtile params opaque;
1416 if conf.invert
1417 then Gl.disable `blend;
1418 if conf.debug
1419 then (
1420 let s = Printf.sprintf
1421 "%d[%d,%d] %f sec"
1422 l.pageno col row t
1424 let w = measurestr fstate.fontsize s in
1425 GlMisc.push_attrib [`current];
1426 GlDraw.color (0.0, 0.0, 0.0);
1427 GlDraw.rect
1428 (float (x-2), float (y-2))
1429 (float (x+2) +. w, float (y + fstate.fontsize + 2));
1430 GlDraw.color (1.0, 1.0, 1.0);
1431 drawstring fstate.fontsize x (y + fstate.fontsize - 1) s;
1432 GlMisc.pop_attrib ();
1435 | _ ->
1436 let w =
1437 let lw = state.winw - state.scrollw - x in
1438 min lw w
1439 and h =
1440 let lh = state.winh - y in
1441 min lh h
1443 begin match state.texid with
1444 | Some id ->
1445 Gl.enable `texture_2d;
1446 GlTex.bind_texture `texture_2d id;
1447 let x0 = float x
1448 and y0 = float y
1449 and x1 = float (x+w)
1450 and y1 = float (y+h) in
1452 let tw = float w /. 16.0
1453 and th = float h /. 16.0 in
1454 let tx0 = float tilex /. 16.0
1455 and ty0 = float tiley /. 16.0 in
1456 let tx1 = tx0 +. tw
1457 and ty1 = ty0 +. th in
1458 GlDraw.begins `quads;
1459 GlTex.coord2 (tx0, ty0); GlDraw.vertex2 (x0, y0);
1460 GlTex.coord2 (tx0, ty1); GlDraw.vertex2 (x0, y1);
1461 GlTex.coord2 (tx1, ty1); GlDraw.vertex2 (x1, y1);
1462 GlTex.coord2 (tx1, ty0); GlDraw.vertex2 (x1, y0);
1463 GlDraw.ends ();
1465 Gl.disable `texture_2d;
1466 | None ->
1467 GlDraw.color (1.0, 1.0, 1.0);
1468 GlDraw.rect
1469 (float x, float y)
1470 (float (x+w), float (y+h));
1471 end;
1472 if w > 128 && h > fstate.fontsize + 10
1473 then (
1474 GlDraw.color (0.0, 0.0, 0.0);
1475 let c, r =
1476 if conf.verbose
1477 then (col*conf.tilew, row*conf.tileh)
1478 else col, row
1480 drawstring2 fstate.fontsize x y "Loading %d [%d,%d]" l.pageno c r;
1482 GlDraw.color color;
1484 itertiles l f
1487 let pagevisible layout n = List.exists (fun l -> l.pageno = n) layout;;
1489 let tilevisible1 l x y =
1490 let ax0 = l.pagex
1491 and ax1 = l.pagex + l.pagevw
1492 and ay0 = l.pagey
1493 and ay1 = l.pagey + l.pagevh in
1495 let bx0 = x
1496 and by0 = y in
1497 let bx1 = min (bx0 + conf.tilew) l.pagew
1498 and by1 = min (by0 + conf.tileh) l.pageh in
1500 let rx0 = max ax0 bx0
1501 and ry0 = max ay0 by0
1502 and rx1 = min ax1 bx1
1503 and ry1 = min ay1 by1 in
1505 let nonemptyintersection = rx1 > rx0 && ry1 > ry0 in
1506 nonemptyintersection
1509 let tilevisible layout n x y =
1510 let rec findpageinlayout m = function
1511 | l :: rest when l.pageno = n ->
1512 tilevisible1 l x y || (
1513 match conf.columns with
1514 | Csplit (c, _) when c > m -> findpageinlayout (m+1) rest
1515 | _ -> false
1517 | _ :: rest -> findpageinlayout 0 rest
1518 | [] -> false
1520 findpageinlayout 0 layout;
1523 let tileready l x y =
1524 tilevisible1 l x y &&
1525 gettileopaque l (x/conf.tilew) (y/conf.tileh) != None
1528 let tilepage n p layout =
1529 let rec loop = function
1530 | l :: rest ->
1531 if l.pageno = n
1532 then
1533 let f col row _ _ _ _ _ _ =
1534 if state.currently = Idle
1535 then
1536 match gettileopaque l col row with
1537 | Some _ -> ()
1538 | None ->
1539 let x = col*conf.tilew
1540 and y = row*conf.tileh in
1541 let w =
1542 let w = l.pagew - x in
1543 min w conf.tilew
1545 let h =
1546 let h = l.pageh - y in
1547 min h conf.tileh
1549 let pbo =
1550 if conf.usepbo
1551 then getpbo w h conf.colorspace
1552 else "0"
1554 wcmd "tile %s %d %d %d %d %s" p x y w h pbo;
1555 state.currently <-
1556 Tiling (
1557 l, p, conf.colorspace, conf.angle, state.gen, col, row,
1558 conf.tilew, conf.tileh
1561 itertiles l f;
1562 else
1563 loop rest
1565 | [] -> ()
1567 if nogeomcmds state.geomcmds
1568 then loop layout;
1571 let preloadlayout y =
1572 let y = if y < state.winh then 0 else y - state.winh in
1573 let h = state.winh*3 in
1574 layout y h;
1577 let load pages =
1578 let rec loop pages =
1579 if state.currently != Idle
1580 then ()
1581 else
1582 match pages with
1583 | l :: rest ->
1584 begin match getopaque l.pageno with
1585 | None ->
1586 wcmd "page %d %d" l.pageno l.pagedimno;
1587 state.currently <- Loading (l, state.gen);
1588 | Some opaque ->
1589 tilepage l.pageno opaque pages;
1590 loop rest
1591 end;
1592 | _ -> ()
1594 if nogeomcmds state.geomcmds
1595 then loop pages
1598 let preload pages =
1599 load pages;
1600 if conf.preload && state.currently = Idle
1601 then load (preloadlayout state.y);
1604 let layoutready layout =
1605 let rec fold all ls =
1606 all && match ls with
1607 | l :: rest ->
1608 let seen = ref false in
1609 let allvisible = ref true in
1610 let foo col row _ _ _ _ _ _ =
1611 seen := true;
1612 allvisible := !allvisible &&
1613 begin match gettileopaque l col row with
1614 | Some _ -> true
1615 | None -> false
1618 itertiles l foo;
1619 fold (!seen && !allvisible) rest
1620 | [] -> true
1622 let alltilesvisible = fold true layout in
1623 alltilesvisible;
1626 let gotoy y =
1627 state.wthack <- false;
1628 let y = bound y 0 state.maxy in
1629 let y, layout, proceed =
1630 match conf.maxwait with
1631 | Some time when state.ghyll == noghyll ->
1632 begin match state.throttle with
1633 | None ->
1634 let layout = layout y state.winh in
1635 let ready = layoutready layout in
1636 if not ready
1637 then (
1638 load layout;
1639 state.throttle <- Some (layout, y, now ());
1641 else G.postRedisplay "gotoy showall (None)";
1642 y, layout, ready
1643 | Some (_, _, started) ->
1644 let dt = now () -. started in
1645 if dt > time
1646 then (
1647 state.throttle <- None;
1648 let layout = layout y state.winh in
1649 load layout;
1650 G.postRedisplay "maxwait";
1651 y, layout, true
1653 else -1, [], false
1656 | _ ->
1657 let layout = layout y state.winh in
1658 G.postRedisplay "gotoy ready";
1659 y, layout, true
1661 if proceed
1662 then (
1663 state.y <- y;
1664 state.layout <- layout;
1665 begin match state.mode with
1666 | LinkNav (Ltexact (pageno, linkno)) ->
1667 let rec loop = function
1668 | [] ->
1669 state.mode <- LinkNav (Ltgendir 0)
1670 | l :: _ when l.pageno = pageno ->
1671 begin match getopaque pageno with
1672 | None ->
1673 state.mode <- LinkNav (Ltgendir 0)
1674 | Some opaque ->
1675 let x0, y0, x1, y1 = getlinkrect opaque linkno in
1676 if not (x0 >= l.pagex && x1 <= l.pagex + l.pagevw
1677 && y0 >= l.pagey && y1 <= l.pagey + l.pagevh)
1678 then state.mode <- LinkNav (Ltgendir 0)
1680 | _ :: rest -> loop rest
1682 loop layout
1683 | _ -> ()
1684 end;
1685 begin match state.mode with
1686 | Birdseye (conf, leftx, pageno, hooverpageno, anchor) ->
1687 if not (pagevisible layout pageno)
1688 then (
1689 match state.layout with
1690 | [] -> ()
1691 | l :: _ ->
1692 state.mode <- Birdseye (
1693 conf, leftx, l.pageno, hooverpageno, anchor
1696 | LinkNav (Ltgendir dir as lt) ->
1697 let linknav =
1698 let rec loop = function
1699 | [] -> lt
1700 | l :: rest ->
1701 match getopaque l.pageno with
1702 | None -> loop rest
1703 | Some opaque ->
1704 let link =
1705 let ld =
1706 if dir = 0
1707 then LDfirstvisible (l.pagex, l.pagey, dir)
1708 else (
1709 if dir > 0 then LDfirst else LDlast
1712 findlink opaque ld
1714 match link with
1715 | Lnotfound -> loop rest
1716 | Lfound n ->
1717 showlinktype (getlink opaque n);
1718 Ltexact (l.pageno, n)
1720 loop state.layout
1722 state.mode <- LinkNav linknav
1723 | _ -> ()
1724 end;
1725 preload layout;
1727 state.ghyll <- noghyll;
1728 if conf.updatecurs
1729 then (
1730 let mx, my = state.mpos in
1731 updateunder mx my;
1735 let conttiling pageno opaque =
1736 tilepage pageno opaque
1737 (if conf.preload then preloadlayout state.y else state.layout)
1740 let gotoy_and_clear_text y =
1741 if not conf.verbose then state.text <- "";
1742 gotoy y;
1745 let getanchor1 l =
1746 let top =
1747 let coloff = l.pagecol * l.pageh in
1748 float (l.pagey + coloff) /. float l.pageh
1750 let dtop =
1751 if l.pagedispy = 0
1752 then
1754 else
1755 if conf.presentation
1756 then float l.pagedispy /. float (calcips l.pageh)
1757 else float l.pagedispy /. float conf.interpagespace
1759 (l.pageno, top, dtop)
1762 let getanchor () =
1763 match state.layout with
1764 | l :: _ -> getanchor1 l
1765 | [] ->
1766 let n = page_of_y state.y in
1767 if n = -1
1768 then state.anchor
1769 else
1770 let y, h = getpageyh n in
1771 let dy = y - state.y in
1772 let dtop =
1773 if conf.presentation
1774 then
1775 let ips = calcips h in
1776 float (dy + ips) /. float ips
1777 else
1778 float dy /. float conf.interpagespace
1780 (n, 0.0, dtop)
1783 let getanchory (n, top, dtop) =
1784 let y, h = getpageyh n in
1785 if conf.presentation
1786 then
1787 let ips = calcips h in
1788 y + truncate (top*.float h -. dtop*.float ips) + ips;
1789 else
1790 y + truncate (top*.float h -. dtop*.float conf.interpagespace)
1793 let gotoanchor anchor =
1794 gotoy (getanchory anchor);
1797 let addnav () =
1798 cbput state.hists.nav (getanchor ());
1801 let getnav dir =
1802 let anchor = cbgetc state.hists.nav dir in
1803 getanchory anchor;
1806 let gotoghyll y =
1807 let scroll f n a b =
1808 (* http://devmaster.net/forums/topic/9796-ease-in-ease-out-algorithm/ *)
1809 let snake f a b =
1810 let s x = 3.0*.x**2.0 -. 2.0*.x**3.0 in
1811 if f < a
1812 then s (float f /. float a)
1813 else (
1814 if f > b
1815 then 1.0 -. s ((float (f-b) /. float (n-b)))
1816 else 1.0
1819 snake f a b
1820 and summa f n a b =
1821 (* courtesy:
1822 http://integrals.wolfram.com/index.jsp?expr=3x%5E2-2x%5E3&random=false *)
1823 let iv x = -.((-.2.0 +. x)*.x**3.0)/.2.0 in
1824 let iv1 = iv f in
1825 let ins = float a *. iv1
1826 and outs = float (n-b) *. iv1 in
1827 let ones = b - a in
1828 ins +. outs +. float ones
1830 let rec set (_N, _A, _B) y sy =
1831 let sum = summa 1.0 _N _A _B in
1832 let dy = float (y - sy) in
1833 state.ghyll <- (
1834 let rec gf n y1 o =
1835 if n >= _N
1836 then state.ghyll <- noghyll
1837 else
1838 let go n =
1839 let s = scroll n _N _A _B in
1840 let y1 = y1 +. ((s *. dy) /. sum) in
1841 gotoy_and_clear_text (truncate y1);
1842 state.ghyll <- gf (n+1) y1;
1844 match o with
1845 | None -> go n
1846 | Some y' -> set (_N/2, 1, 1) y' state.y
1848 gf 0 (float state.y)
1851 match conf.ghyllscroll with
1852 | None ->
1853 gotoy_and_clear_text y
1854 | Some nab ->
1855 if state.ghyll == noghyll
1856 then set nab y state.y
1857 else state.ghyll (Some y)
1860 let gotopage n top =
1861 let y, h = getpageyh n in
1862 let y = y + (truncate (top *. float h)) in
1863 gotoghyll y
1866 let gotopage1 n top =
1867 let y = getpagey n in
1868 let y = y + top in
1869 gotoghyll y
1872 let invalidate s f =
1873 state.layout <- [];
1874 state.pdims <- [];
1875 state.rects <- [];
1876 state.rects1 <- [];
1877 match state.geomcmds with
1878 | ps, [] when String.length ps = 0 ->
1879 f ();
1880 state.geomcmds <- s, [];
1882 | ps, [] ->
1883 state.geomcmds <- ps, [s, f];
1885 | ps, (s', _) :: rest when s' = s ->
1886 state.geomcmds <- ps, ((s, f) :: rest);
1888 | ps, cmds ->
1889 state.geomcmds <- ps, ((s, f) :: cmds);
1892 let flushpages () =
1893 Hashtbl.iter (fun _ opaque ->
1894 wcmd "freepage %s" opaque;
1895 ) state.pagemap;
1896 Hashtbl.clear state.pagemap;
1899 let flushtiles () =
1900 if not (Queue.is_empty state.tilelru)
1901 then (
1902 Queue.iter (fun (k, p, s) ->
1903 wcmd "freetile %s" p;
1904 state.memused <- state.memused - s;
1905 Hashtbl.remove state.tilemap k;
1906 ) state.tilelru;
1907 state.uioh#infochanged Memused;
1908 Queue.clear state.tilelru;
1910 load state.layout;
1913 let opendoc path password =
1914 state.path <- path;
1915 state.password <- password;
1916 state.gen <- state.gen + 1;
1917 state.docinfo <- [];
1919 flushpages ();
1920 setaalevel conf.aalevel;
1921 Wsi.settitle ("llpp " ^ (mbtoutf8 (Filename.basename path)));
1922 wcmd "open %d %s\000%s\000" (btod state.wthack) path password;
1923 invalidate "reqlayout"
1924 (fun () ->
1925 wcmd "reqlayout %d %d %s\000"
1926 conf.angle (btod conf.proportional) state.nameddest;
1930 let reload () =
1931 state.anchor <- getanchor ();
1932 state.wthack <- !wtmode;
1933 opendoc state.path state.password;
1936 let scalecolor c =
1937 let c = c *. conf.colorscale in
1938 (c, c, c);
1941 let scalecolor2 (r, g, b) =
1942 (r *. conf.colorscale, g *. conf.colorscale, b *. conf.colorscale);
1945 let docolumns = function
1946 | Csingle _ ->
1947 let a = Array.make state.pagecount (-1, -1, -1, (-1, -1, -1, -1)) in
1948 let rec loop pageno pdimno pdim y ph pdims =
1949 if pageno = state.pagecount
1950 then ()
1951 else
1952 let pdimno, ((_, w, h, xoff) as pdim), pdims =
1953 match pdims with
1954 | ((pageno', _, _, _) as pdim) :: rest when pageno' = pageno ->
1955 pdimno+1, pdim, rest
1956 | _ ->
1957 pdimno, pdim, pdims
1959 let x = max 0 (((state.winw - state.scrollw - w) / 2) - xoff) in
1960 let y = y +
1961 (if conf.presentation
1962 then (if pageno = 0 then calcips h else calcips ph + calcips h)
1963 else (if pageno = 0 then 0 else conf.interpagespace)
1966 a.(pageno) <- (pdimno, x, y, pdim);
1967 loop (pageno+1) pdimno pdim (y + h) h pdims
1969 loop 0 ~-1 (-1,-1,-1,-1) 0 0 state.pdims;
1970 conf.columns <- Csingle a;
1972 | Cmulti ((columns, coverA, coverB), _) ->
1973 let a = Array.make state.pagecount (-1, -1, -1, (-1, -1, -1, -1)) in
1974 let rec loop pageno pdimno pdim x y rowh pdims =
1975 let rec fixrow m = if m = pageno then () else
1976 let (pdimno, x, y, ((_, _, h, _) as pdim)) = a.(m) in
1977 if h < rowh
1978 then (
1979 let y = y + (rowh - h) / 2 in
1980 a.(m) <- (pdimno, x, y, pdim);
1982 fixrow (m+1)
1984 if pageno = state.pagecount
1985 then fixrow (((pageno - 1) / columns) * columns)
1986 else
1987 let pdimno, ((_, w, h, xoff) as pdim), pdims =
1988 match pdims with
1989 | ((pageno', _, _, _) as pdim) :: rest when pageno' = pageno ->
1990 pdimno+1, pdim, rest
1991 | _ ->
1992 pdimno, pdim, pdims
1994 let x, y, rowh' =
1995 if pageno = coverA - 1 || pageno = state.pagecount - coverB
1996 then (
1997 let x = (state.winw - state.scrollw - w) / 2 in
1998 let ips =
1999 if conf.presentation then calcips h else conf.interpagespace in
2000 x, y + ips + rowh, h
2002 else (
2003 if (pageno - coverA) mod columns = 0
2004 then (
2005 let x = max 0 (state.winw - state.scrollw - state.w) / 2 in
2006 let y =
2007 if conf.presentation
2008 then
2009 let ips = calcips h in
2010 y + (if pageno = 0 then 0 else calcips rowh + ips)
2011 else
2012 y + (if pageno = 0 then 0 else conf.interpagespace)
2014 x, y + rowh, h
2016 else x, y, max rowh h
2019 let y =
2020 if pageno > 1 && (pageno - coverA) mod columns = 0
2021 then (
2022 let y =
2023 if pageno = columns && conf.presentation
2024 then (
2025 let ips = calcips rowh in
2026 for i = 0 to pred columns
2028 let (pdimno, x, y, pdim) = a.(i) in
2029 a.(i) <- (pdimno, x, y+ips, pdim)
2030 done;
2031 y+ips;
2033 else y
2035 fixrow (pageno - columns);
2038 else y
2040 a.(pageno) <- (pdimno, x, y, pdim);
2041 let x = x + w + xoff*2 + conf.interpagespace in
2042 loop (pageno+1) pdimno pdim x y rowh' pdims
2044 loop 0 ~-1 (-1,-1,-1,-1) 0 0 0 state.pdims;
2045 conf.columns <- Cmulti ((columns, coverA, coverB), a);
2047 | Csplit (c, _) ->
2048 let a = Array.make (state.pagecount*c) (-1, -1, -1, (-1, -1, -1, -1)) in
2049 let rec loop pageno pdimno pdim y pdims =
2050 if pageno = state.pagecount
2051 then ()
2052 else
2053 let pdimno, ((_, w, h, _) as pdim), pdims =
2054 match pdims with
2055 | ((pageno', _, _, _) as pdim) :: rest when pageno' = pageno ->
2056 pdimno+1, pdim, rest
2057 | _ ->
2058 pdimno, pdim, pdims
2060 let cw = w / c in
2061 let rec loop1 n x y =
2062 if n = c then y else (
2063 a.(pageno*c + n) <- (pdimno, x, y, pdim);
2064 loop1 (n+1) (x+cw) (y + h + conf.interpagespace)
2067 let y = loop1 0 0 y in
2068 loop (pageno+1) pdimno pdim y pdims
2070 loop 0 ~-1 (-1,-1,-1,-1) 0 state.pdims;
2071 conf.columns <- Csplit (c, a);
2074 let represent () =
2075 docolumns conf.columns;
2076 state.maxy <- calcheight ();
2077 state.hscrollh <-
2078 if state.x = 0 && state.w <= state.winw - state.scrollw
2079 then 0
2080 else state.scrollw
2082 if state.reprf == noreprf
2083 then (
2084 match state.mode with
2085 | Birdseye (_, _, pageno, _, _) ->
2086 let y, h = getpageyh pageno in
2087 let top = (state.winh - h) / 2 in
2088 gotoy (max 0 (y - top))
2089 | _ -> gotoanchor state.anchor
2091 else (
2092 state.reprf ();
2093 state.reprf <- noreprf;
2097 let reshape w h =
2098 state.wthack <- false;
2099 GlDraw.viewport 0 0 w h;
2100 let firsttime = state.geomcmds == firstgeomcmds in
2101 if not firsttime && nogeomcmds state.geomcmds
2102 then state.anchor <- getanchor ();
2104 state.winw <- w;
2105 let w = truncate (float w *. conf.zoom) - state.scrollw in
2106 let w = max w 2 in
2107 state.winh <- h;
2108 setfontsize fstate.fontsize;
2109 GlMat.mode `modelview;
2110 GlMat.load_identity ();
2112 GlMat.mode `projection;
2113 GlMat.load_identity ();
2114 GlMat.rotate ~x:1.0 ~angle:180.0 ();
2115 GlMat.translate ~x:~-.1.0 ~y:~-.1.0 ();
2116 GlMat.scale3 (2.0 /. float state.winw, 2.0 /. float state.winh, 1.0);
2118 let relx =
2119 if conf.zoom <= 1.0
2120 then 0.0
2121 else float state.x /. float state.w
2123 invalidate "geometry"
2124 (fun () ->
2125 state.w <- w;
2126 if not firsttime
2127 then state.x <- truncate (relx *. float w);
2128 let w =
2129 match conf.columns with
2130 | Csingle _ -> w
2131 | Cmulti ((c, _, _), _) -> (w - (c-1)*conf.interpagespace) / c
2132 | Csplit (c, _) -> w * c
2134 wcmd "geometry %d %d" w h);
2137 let enttext () =
2138 let len = String.length state.text in
2139 let drawstring s =
2140 let hscrollh =
2141 match state.mode with
2142 | Textentry _
2143 | View ->
2144 let h, _, _ = state.uioh#scrollpw in
2146 | _ -> 0
2148 let rect x w =
2149 GlDraw.rect
2150 (x, float (state.winh - (fstate.fontsize + 4) - hscrollh))
2151 (x+.w, float (state.winh - hscrollh))
2154 let w = float (state.winw - state.scrollw - 1) in
2155 if state.progress >= 0.0 && state.progress < 1.0
2156 then (
2157 GlDraw.color (0.3, 0.3, 0.3);
2158 let w1 = w *. state.progress in
2159 rect 0.0 w1;
2160 GlDraw.color (0.0, 0.0, 0.0);
2161 rect w1 (w-.w1)
2163 else (
2164 GlDraw.color (0.0, 0.0, 0.0);
2165 rect 0.0 w;
2168 GlDraw.color (1.0, 1.0, 1.0);
2169 drawstring fstate.fontsize
2170 (if len > 0 then 8 else 2) (state.winh - hscrollh - 5) s;
2172 let s =
2173 match state.mode with
2174 | Textentry ((prefix, text, _, _, _, _), _) ->
2175 let s =
2176 if len > 0
2177 then
2178 Printf.sprintf "%s%s_ [%s]" prefix text state.text
2179 else
2180 Printf.sprintf "%s%s_" prefix text
2184 | _ -> state.text
2186 let s =
2187 if state.newerrmsgs
2188 then (
2189 if not (istextentry state.mode)
2190 then
2191 let s1 = "(press 'e' to review error messasges)" in
2192 if String.length s > 0 then s ^ " " ^ s1 else s1
2193 else s
2195 else s
2197 if String.length s > 0
2198 then drawstring s
2201 let gctiles () =
2202 let len = Queue.length state.tilelru in
2203 let layout = lazy (
2204 match state.throttle with
2205 | None ->
2206 if conf.preload
2207 then preloadlayout state.y
2208 else state.layout
2209 | Some (layout, _, _) ->
2210 layout
2211 ) in
2212 let rec loop qpos =
2213 if state.memused <= conf.memlimit
2214 then ()
2215 else (
2216 if qpos < len
2217 then
2218 let (k, p, s) as lruitem = Queue.pop state.tilelru in
2219 let n, gen, colorspace, angle, pagew, pageh, col, row = k in
2220 let (_, pw, ph, _) = getpagedim n in
2222 gen = state.gen
2223 && colorspace = conf.colorspace
2224 && angle = conf.angle
2225 && pagew = pw
2226 && pageh = ph
2227 && (
2228 let x = col*conf.tilew
2229 and y = row*conf.tileh in
2230 tilevisible (Lazy.force_val layout) n x y
2232 then Queue.push lruitem state.tilelru
2233 else (
2234 freepbo p;
2235 wcmd "freetile %s" p;
2236 state.memused <- state.memused - s;
2237 state.uioh#infochanged Memused;
2238 Hashtbl.remove state.tilemap k;
2240 loop (qpos+1)
2243 loop 0
2246 let logcurrently = function
2247 | Idle -> dolog "Idle"
2248 | Loading (l, gen) ->
2249 dolog "Loading %d gen=%d curgen=%d" l.pageno gen state.gen
2250 | Tiling (l, pageopaque, colorspace, angle, gen, col, row, tilew, tileh) ->
2251 dolog
2252 "Tiling %d[%d,%d] page=%s cs=%s angle"
2253 l.pageno col row pageopaque
2254 (colorspace_to_string colorspace)
2256 dolog "gen=(%d,%d) (%d,%d) tile=(%d,%d) (%d,%d)"
2257 angle gen conf.angle state.gen
2258 tilew tileh
2259 conf.tilew conf.tileh
2261 | Outlining _ ->
2262 dolog "outlining"
2265 let splitatspace =
2266 let r = Str.regexp " " in
2267 fun s -> Str.bounded_split r s 2;
2270 let onpagerect pageno f =
2271 let b =
2272 match conf.columns with
2273 | Cmulti (_, b) -> b
2274 | Csingle b -> b
2275 | Csplit (_, b) -> b
2277 if pageno >= 0 && pageno < Array.length b
2278 then
2279 let (pdimno, _, _, (_, _, _, _)) = b.(pageno) in
2280 let r = getpdimrect pdimno in
2281 f (r.(1)-.r.(0)) (r.(3)-.r.(2))
2284 let gotopagexy pageno x y =
2285 onpagerect pageno (fun w h ->
2286 let top = y /. h in
2287 let _,w1,_,leftx = getpagedim pageno in
2288 let wh = state.winh - state.hscrollh in
2289 let sw = float w1 /. w in
2290 let x = sw *. x in
2291 let x = leftx + state.x + truncate x in
2292 let sx =
2293 if x < 0 || x >= state.winw - state.scrollw
2294 then state.x - x
2295 else state.x
2297 let py, h = getpageyh pageno in
2298 let y' = py + truncate (top *. float h) in
2299 let dy = y' - state.y in
2300 let sy =
2301 if x != state.x || not (dy > 0 && dy < wh)
2302 then (
2303 if conf.presentation
2304 then
2305 if abs (py - y') > wh
2306 then y'
2307 else py
2308 else y';
2310 else state.y
2312 if state.x != sx || state.y != sy
2313 then (
2314 let x, y =
2315 if !wtmode
2316 then (
2317 let ww = state.winw - state.scrollw in
2318 let qx = sx / ww
2319 and qy = sy / wh in
2320 let x = qx * ww
2321 and y = qy * wh in
2322 let x = if -x + ww > w1 then -(w1-ww) else x
2323 and y' = if y + wh > state.maxy then state.maxy - wh else y in
2324 let y =
2325 if conf.presentation
2326 then
2327 if abs (py - y') > wh
2328 then y'
2329 else py
2330 else y';
2332 (x, y)
2334 else (sx, sy)
2336 state.x <- x;
2337 state.hscrollh <-
2338 if x = 0 && state.w <= state.winw - state.scrollw
2339 then 0
2340 else state.scrollw
2342 gotoy_and_clear_text y;
2344 else gotoy_and_clear_text state.y;
2345 state.wthack <- !wtmode && not (layoutready state.layout);
2349 let act cmds =
2350 (* dolog "%S" cmds; *)
2351 let cl = splitatspace cmds in
2352 let scan s fmt f =
2353 try Scanf.sscanf s fmt f
2354 with exn ->
2355 dolog "error processing '%S': %s" cmds (exntos exn);
2356 exit 1
2358 match cl with
2359 | "clear" :: [] ->
2360 state.uioh#infochanged Pdim;
2361 state.pdims <- [];
2363 | "clearrects" :: [] ->
2364 state.rects <- state.rects1;
2365 G.postRedisplay "clearrects";
2367 | "continue" :: args :: [] ->
2368 let n = scan args "%u" (fun n -> n) in
2369 state.pagecount <- n;
2370 begin match state.currently with
2371 | Outlining l ->
2372 state.currently <- Idle;
2373 state.outlines <- Array.of_list (List.rev l)
2374 | _ -> ()
2375 end;
2377 let cur, cmds = state.geomcmds in
2378 if String.length cur = 0
2379 then failwith "umpossible";
2381 begin match List.rev cmds with
2382 | [] ->
2383 state.geomcmds <- "", [];
2384 represent ();
2385 | (s, f) :: rest ->
2386 f ();
2387 state.geomcmds <- s, List.rev rest;
2388 end;
2389 if conf.maxwait = None
2390 then G.postRedisplay "continue";
2392 | "title" :: args :: [] ->
2393 Wsi.settitle args
2395 | "msg" :: args :: [] ->
2396 showtext ' ' args
2398 | "vmsg" :: args :: [] ->
2399 if conf.verbose
2400 then showtext ' ' args
2402 | "emsg" :: args :: [] ->
2403 Buffer.add_string state.errmsgs args;
2404 state.newerrmsgs <- true;
2405 G.postRedisplay "error message"
2407 | "progress" :: args :: [] ->
2408 let progress, text =
2409 scan args "%f %n"
2410 (fun f pos ->
2411 f, String.sub args pos (String.length args - pos))
2413 state.text <- text;
2414 state.progress <- progress;
2415 G.postRedisplay "progress"
2417 | "firstmatch" :: args :: [] ->
2418 let pageno, c, x0, y0, x1, y1, x2, y2, x3, y3 =
2419 scan args "%u %d %f %f %f %f %f %f %f %f"
2420 (fun p c x0 y0 x1 y1 x2 y2 x3 y3 ->
2421 (p, c, x0, y0, x1, y1, x2, y2, x3, y3))
2423 let y = (getpagey pageno) + truncate y0 in
2424 addnav ();
2425 gotoy y;
2426 state.rects1 <- [pageno, c, (x0, y0, x1, y1, x2, y2, x3, y3)]
2428 | "match" :: args :: [] ->
2429 let pageno, c, x0, y0, x1, y1, x2, y2, x3, y3 =
2430 scan args "%u %d %f %f %f %f %f %f %f %f"
2431 (fun p c x0 y0 x1 y1 x2 y2 x3 y3 ->
2432 (p, c, x0, y0, x1, y1, x2, y2, x3, y3))
2434 state.rects1 <-
2435 (pageno, c, (x0, y0, x1, y1, x2, y2, x3, y3)) :: state.rects1
2437 | "page" :: args :: [] ->
2438 let pageopaque, t = scan args "%s %f" (fun p t -> p, t) in
2439 begin match state.currently with
2440 | Loading (l, gen) ->
2441 vlog "page %d took %f sec" l.pageno t;
2442 Hashtbl.replace state.pagemap (l.pageno, gen) pageopaque;
2443 begin match state.throttle with
2444 | None ->
2445 let preloadedpages =
2446 if conf.preload
2447 then preloadlayout state.y
2448 else state.layout
2450 let evict () =
2451 let module IntSet =
2452 Set.Make (struct type t = int let compare = (-) end) in
2453 let set =
2454 List.fold_left (fun s l -> IntSet.add l.pageno s)
2455 IntSet.empty preloadedpages
2457 let evictedpages =
2458 Hashtbl.fold (fun ((pageno, _) as key) opaque accu ->
2459 if not (IntSet.mem pageno set)
2460 then (
2461 wcmd "freepage %s" opaque;
2462 key :: accu
2464 else accu
2465 ) state.pagemap []
2467 List.iter (Hashtbl.remove state.pagemap) evictedpages;
2469 evict ();
2470 state.currently <- Idle;
2471 if gen = state.gen
2472 then (
2473 tilepage l.pageno pageopaque state.layout;
2474 load state.layout;
2475 load preloadedpages;
2476 if pagevisible state.layout l.pageno
2477 && layoutready state.layout
2478 then G.postRedisplay "page";
2481 | Some (layout, _, _) ->
2482 state.currently <- Idle;
2483 tilepage l.pageno pageopaque layout;
2484 load state.layout
2485 end;
2487 | _ ->
2488 dolog "Inconsistent loading state";
2489 logcurrently state.currently;
2490 exit 1
2493 | "tile" :: args :: [] ->
2494 let (x, y, opaque, size, t) =
2495 scan args "%u %u %s %u %f"
2496 (fun x y p size t -> (x, y, p, size, t))
2498 begin match state.currently with
2499 | Tiling (l, pageopaque, cs, angle, gen, col, row, tilew, tileh) ->
2500 vlog "tile %d [%d,%d] took %f sec" l.pageno col row t;
2502 unmappbo opaque;
2503 if tilew != conf.tilew || tileh != conf.tileh
2504 then (
2505 wcmd "freetile %s" opaque;
2506 state.currently <- Idle;
2507 load state.layout;
2509 else (
2510 puttileopaque l col row gen cs angle opaque size t;
2511 state.memused <- state.memused + size;
2512 state.uioh#infochanged Memused;
2513 gctiles ();
2514 Queue.push ((l.pageno, gen, cs, angle, l.pagew, l.pageh, col, row),
2515 opaque, size) state.tilelru;
2517 let layout =
2518 match state.throttle with
2519 | None -> state.layout
2520 | Some (layout, _, _) -> layout
2523 state.currently <- Idle;
2524 if gen = state.gen
2525 && conf.colorspace = cs
2526 && conf.angle = angle
2527 && tilevisible layout l.pageno x y
2528 then conttiling l.pageno pageopaque;
2530 begin match state.throttle with
2531 | None ->
2532 if state.wthack
2533 then state.wthack <- not (layoutready state.layout);
2534 preload state.layout;
2535 if gen = state.gen
2536 && conf.colorspace = cs
2537 && conf.angle = angle
2538 && tilevisible state.layout l.pageno x y
2539 then G.postRedisplay "tile nothrottle";
2541 | Some (layout, y, _) ->
2542 let ready = layoutready layout in
2543 if ready
2544 then (
2545 state.wthack <- false;
2546 state.y <- y;
2547 state.layout <- layout;
2548 state.throttle <- None;
2549 G.postRedisplay "throttle";
2551 else load layout;
2552 end;
2555 | _ ->
2556 dolog "Inconsistent tiling state";
2557 logcurrently state.currently;
2558 exit 1
2561 | "pdim" :: args :: [] ->
2562 let pdim =
2563 scan args "%u %u %u %u" (fun n w h x -> n, w, h, x)
2565 state.uioh#infochanged Pdim;
2566 state.pdims <- pdim :: state.pdims
2568 | "o" :: args :: [] ->
2569 let (l, n, t, h, pos) =
2570 scan args "%u %u %d %u %n"
2571 (fun l n t h pos -> l, n, t, h, pos)
2573 let s = String.sub args pos (String.length args - pos) in
2574 let outline = (s, l, (n, float t /. float h, 0.0)) in
2575 begin match state.currently with
2576 | Outlining outlines ->
2577 state.currently <- Outlining (outline :: outlines)
2578 | Idle ->
2579 state.currently <- Outlining [outline]
2580 | currently ->
2581 dolog "invalid outlining state";
2582 logcurrently currently
2585 | "a" :: args :: [] ->
2586 let (n, l, t) =
2587 scan args "%u %d %d" (fun n l t -> n, l, t)
2589 state.reprf <- (fun () -> gotopagexy n (float l) (float t))
2591 | "info" :: args :: [] ->
2592 state.docinfo <- (1, args) :: state.docinfo
2594 | "infoend" :: [] ->
2595 state.uioh#infochanged Docinfo;
2596 state.docinfo <- List.rev state.docinfo
2598 | _ ->
2599 failwith (Printf.sprintf "unknown cmd `%S'" cmds)
2602 let onhist cb =
2603 let rc = cb.rc in
2604 let action = function
2605 | HCprev -> cbget cb ~-1
2606 | HCnext -> cbget cb 1
2607 | HCfirst -> cbget cb ~-(cb.rc)
2608 | HClast -> cbget cb (cb.len - 1 - cb.rc)
2609 and cancel () = cb.rc <- rc
2610 in (action, cancel)
2613 let search pattern forward =
2614 if String.length pattern > 0
2615 then
2616 let pn, py =
2617 match state.layout with
2618 | [] -> 0, 0
2619 | l :: _ ->
2620 l.pageno, (l.pagey + if forward then 0 else 0*l.pagevh)
2622 wcmd "search %d %d %d %d,%s\000"
2623 (btod conf.icase) pn py (btod forward) pattern;
2626 let intentry text key =
2627 let c =
2628 if key >= 32 && key < 127
2629 then Char.chr key
2630 else '\000'
2632 match c with
2633 | '0' .. '9' ->
2634 let text = addchar text c in
2635 TEcont text
2637 | _ ->
2638 state.text <- Printf.sprintf "invalid char (%d, `%c')" key c;
2639 TEcont text
2642 let linknentry text key =
2643 let c =
2644 if key >= 32 && key < 127
2645 then Char.chr key
2646 else '\000'
2648 match c with
2649 | 'a' .. 'z' ->
2650 let text = addchar text c in
2651 TEcont text
2653 | _ ->
2654 state.text <- Printf.sprintf "invalid char (%d, `%c')" key c;
2655 TEcont text
2658 let linkndone f s =
2659 if String.length s > 0
2660 then (
2661 let n =
2662 let l = String.length s in
2663 let rec loop pos n = if pos = l then n else
2664 let m = Char.code s.[pos] - (if pos = 0 && l > 1 then 96 else 97) in
2665 loop (pos+1) (n*26 + m)
2666 in loop 0 0
2668 let rec loop n = function
2669 | [] -> ()
2670 | l :: rest ->
2671 match getopaque l.pageno with
2672 | None -> loop n rest
2673 | Some opaque ->
2674 let m = getlinkcount opaque in
2675 if n < m
2676 then (
2677 let under = getlink opaque n in
2678 f under
2680 else loop (n-m) rest
2682 loop n state.layout;
2686 let textentry text key =
2687 if key land 0xff00 = 0xff00
2688 then TEcont text
2689 else TEcont (text ^ toutf8 key)
2692 let reqlayout angle proportional =
2693 match state.throttle with
2694 | None ->
2695 if nogeomcmds state.geomcmds
2696 then state.anchor <- getanchor ();
2697 conf.angle <- angle mod 360;
2698 if conf.angle != 0
2699 then (
2700 match state.mode with
2701 | LinkNav _ -> state.mode <- View
2702 | _ -> ()
2704 conf.proportional <- proportional;
2705 invalidate "reqlayout"
2706 (fun () -> wcmd "reqlayout %d %d" conf.angle (btod proportional));
2707 | _ -> ()
2710 let settrim trimmargins trimfuzz =
2711 if nogeomcmds state.geomcmds
2712 then state.anchor <- getanchor ();
2713 conf.trimmargins <- trimmargins;
2714 conf.trimfuzz <- trimfuzz;
2715 let x0, y0, x1, y1 = trimfuzz in
2716 invalidate "settrim"
2717 (fun () ->
2718 wcmd "settrim %d %d %d %d %d" (btod conf.trimmargins) x0 y0 x1 y1);
2719 flushpages ();
2722 let setzoom zoom =
2723 match state.throttle with
2724 | None ->
2725 let zoom = max 0.01 zoom in
2726 if zoom <> conf.zoom
2727 then (
2728 state.prevzoom <- conf.zoom;
2729 conf.zoom <- zoom;
2730 reshape state.winw state.winh;
2731 state.text <- Printf.sprintf "zoom is now %-5.1f" (zoom *. 100.0);
2734 | Some (layout, y, started) ->
2735 let time =
2736 match conf.maxwait with
2737 | None -> 0.0
2738 | Some t -> t
2740 let dt = now () -. started in
2741 if dt > time
2742 then (
2743 state.y <- y;
2744 load layout;
2748 let setcolumns mode columns coverA coverB =
2749 state.prevcolumns <- Some (conf.columns, conf.zoom);
2750 if columns < 0
2751 then (
2752 if isbirdseye mode
2753 then showtext '!' "split mode doesn't work in bird's eye"
2754 else (
2755 conf.columns <- Csplit (-columns, [||]);
2756 state.x <- 0;
2757 conf.zoom <- 1.0;
2760 else (
2761 if columns < 2
2762 then (
2763 conf.columns <- Csingle [||];
2764 state.x <- 0;
2765 setzoom 1.0;
2767 else (
2768 conf.columns <- Cmulti ((columns, coverA, coverB), [||]);
2769 conf.zoom <- 1.0;
2772 reshape state.winw state.winh;
2775 let enterbirdseye () =
2776 let zoom = float conf.thumbw /. float state.winw in
2777 let birdseyepageno =
2778 let cy = state.winh / 2 in
2779 let fold = function
2780 | [] -> 0
2781 | l :: rest ->
2782 let rec fold best = function
2783 | [] -> best.pageno
2784 | l :: rest ->
2785 let d = cy - (l.pagedispy + l.pagevh/2)
2786 and dbest = cy - (best.pagedispy + best.pagevh/2) in
2787 if abs d < abs dbest
2788 then fold l rest
2789 else best.pageno
2790 in fold l rest
2792 fold state.layout
2794 state.mode <- Birdseye (
2795 { conf with zoom = conf.zoom }, state.x, birdseyepageno, -1, getanchor ()
2797 conf.zoom <- zoom;
2798 conf.presentation <- false;
2799 conf.interpagespace <- 10;
2800 conf.hlinks <- false;
2801 state.x <- 0;
2802 state.mstate <- Mnone;
2803 conf.maxwait <- None;
2804 conf.columns <- (
2805 match conf.beyecolumns with
2806 | Some c ->
2807 conf.zoom <- 1.0;
2808 Cmulti ((c, 0, 0), [||])
2809 | None -> Csingle [||]
2811 Wsi.setcursor Wsi.CURSOR_INHERIT;
2812 if conf.verbose
2813 then
2814 state.text <- Printf.sprintf "birds eye mode on (zoom %3.1f%%)"
2815 (100.0*.zoom)
2816 else
2817 state.text <- ""
2819 reshape state.winw state.winh;
2822 let leavebirdseye (c, leftx, pageno, _, anchor) goback =
2823 state.mode <- View;
2824 conf.zoom <- c.zoom;
2825 conf.presentation <- c.presentation;
2826 conf.interpagespace <- c.interpagespace;
2827 conf.maxwait <- c.maxwait;
2828 conf.hlinks <- c.hlinks;
2829 conf.beyecolumns <- (
2830 match conf.columns with
2831 | Cmulti ((c, _, _), _) -> Some c
2832 | Csingle _ -> None
2833 | Csplit _ -> failwith "leaving bird's eye split mode"
2835 conf.columns <- (
2836 match c.columns with
2837 | Cmulti (c, _) -> Cmulti (c, [||])
2838 | Csingle _ -> Csingle [||]
2839 | Csplit (c, _) -> Csplit (c, [||])
2841 state.x <- leftx;
2842 if conf.verbose
2843 then
2844 state.text <- Printf.sprintf "birds eye mode off (zoom %3.1f%%)"
2845 (100.0*.conf.zoom)
2847 reshape state.winw state.winh;
2848 state.anchor <- if goback then anchor else (pageno, 0.0, 1.0);
2851 let togglebirdseye () =
2852 match state.mode with
2853 | Birdseye vals -> leavebirdseye vals true
2854 | View -> enterbirdseye ()
2855 | _ -> ()
2858 let upbirdseye incr (conf, leftx, pageno, hooverpageno, anchor) =
2859 let pageno = max 0 (pageno - incr) in
2860 let rec loop = function
2861 | [] -> gotopage1 pageno 0
2862 | l :: _ when l.pageno = pageno ->
2863 if l.pagedispy >= 0 && l.pagey = 0
2864 then G.postRedisplay "upbirdseye"
2865 else gotopage1 pageno 0
2866 | _ :: rest -> loop rest
2868 loop state.layout;
2869 state.mode <- Birdseye (conf, leftx, pageno, hooverpageno, anchor)
2872 let downbirdseye incr (conf, leftx, pageno, hooverpageno, anchor) =
2873 let pageno = min (state.pagecount - 1) (pageno + incr) in
2874 state.mode <- Birdseye (conf, leftx, pageno, hooverpageno, anchor);
2875 let rec loop = function
2876 | [] ->
2877 let y, h = getpageyh pageno in
2878 let dy = (y - state.y) - (state.winh - h - conf.interpagespace) in
2879 gotoy (clamp dy)
2880 | l :: _ when l.pageno = pageno ->
2881 if l.pagevh != l.pageh
2882 then gotoy (clamp (l.pageh - l.pagevh + conf.interpagespace))
2883 else G.postRedisplay "downbirdseye"
2884 | _ :: rest -> loop rest
2886 loop state.layout
2889 let optentry mode _ key =
2890 let btos b = if b then "on" else "off" in
2891 if key >= 32 && key < 127
2892 then
2893 let c = Char.chr key in
2894 match c with
2895 | 's' ->
2896 let ondone s =
2897 try conf.scrollstep <- int_of_string s with exc ->
2898 state.text <- Printf.sprintf "bad integer `%s': %s" s (exntos exc)
2900 TEswitch ("scroll step: ", "", None, intentry, ondone, true)
2902 | 'A' ->
2903 let ondone s =
2905 conf.autoscrollstep <- int_of_string s;
2906 if state.autoscroll <> None
2907 then state.autoscroll <- Some conf.autoscrollstep
2908 with exc ->
2909 state.text <- Printf.sprintf "bad integer `%s': %s" s (exntos exc)
2911 TEswitch ("auto scroll step: ", "", None, intentry, ondone, true)
2913 | 'C' ->
2914 let ondone s =
2916 let n, a, b = multicolumns_of_string s in
2917 setcolumns mode n a b;
2918 with exc ->
2919 state.text <- Printf.sprintf "bad columns `%s': %s" s (exntos exc)
2921 TEswitch ("columns: ", "", None, textentry, ondone, true)
2923 | 'Z' ->
2924 let ondone s =
2926 let zoom = float (int_of_string s) /. 100.0 in
2927 setzoom zoom
2928 with exc ->
2929 state.text <- Printf.sprintf "bad integer `%s': %s" s (exntos exc)
2931 TEswitch ("zoom: ", "", None, intentry, ondone, true)
2933 | 't' ->
2934 let ondone s =
2936 conf.thumbw <- bound (int_of_string s) 2 4096;
2937 state.text <-
2938 Printf.sprintf "thumbnail width is set to %d" conf.thumbw;
2939 begin match mode with
2940 | Birdseye beye ->
2941 leavebirdseye beye false;
2942 enterbirdseye ();
2943 | _ -> ();
2945 with exc ->
2946 state.text <- Printf.sprintf "bad integer `%s': %s" s (exntos exc)
2948 TEswitch ("thumbnail width: ", "", None, intentry, ondone, true)
2950 | 'R' ->
2951 let ondone s =
2952 match try
2953 Some (int_of_string s)
2954 with exc ->
2955 state.text <- Printf.sprintf "bad integer `%s': %s"
2956 s (exntos exc);
2957 None
2958 with
2959 | Some angle -> reqlayout angle conf.proportional
2960 | None -> ()
2962 TEswitch ("rotation: ", "", None, intentry, ondone, true)
2964 | 'i' ->
2965 conf.icase <- not conf.icase;
2966 TEdone ("case insensitive search " ^ (btos conf.icase))
2968 | 'p' ->
2969 conf.preload <- not conf.preload;
2970 gotoy state.y;
2971 TEdone ("preload " ^ (btos conf.preload))
2973 | 'v' ->
2974 conf.verbose <- not conf.verbose;
2975 TEdone ("verbose " ^ (btos conf.verbose))
2977 | 'd' ->
2978 conf.debug <- not conf.debug;
2979 TEdone ("debug " ^ (btos conf.debug))
2981 | 'h' ->
2982 conf.maxhfit <- not conf.maxhfit;
2983 state.maxy <- calcheight ();
2984 TEdone ("maxhfit " ^ (btos conf.maxhfit))
2986 | 'c' ->
2987 conf.crophack <- not conf.crophack;
2988 TEdone ("crophack " ^ btos conf.crophack)
2990 | 'a' ->
2991 let s =
2992 match conf.maxwait with
2993 | None ->
2994 conf.maxwait <- Some infinity;
2995 "always wait for page to complete"
2996 | Some _ ->
2997 conf.maxwait <- None;
2998 "show placeholder if page is not ready"
3000 TEdone s
3002 | 'f' ->
3003 conf.underinfo <- not conf.underinfo;
3004 TEdone ("underinfo " ^ btos conf.underinfo)
3006 | 'P' ->
3007 conf.savebmarks <- not conf.savebmarks;
3008 TEdone ("persistent bookmarks " ^ btos conf.savebmarks)
3010 | 'S' ->
3011 let ondone s =
3013 let pageno, py =
3014 match state.layout with
3015 | [] -> 0, 0
3016 | l :: _ ->
3017 l.pageno, l.pagey
3019 conf.interpagespace <- int_of_string s;
3020 docolumns conf.columns;
3021 state.maxy <- calcheight ();
3022 let y = getpagey pageno in
3023 gotoy (y + py)
3024 with exc ->
3025 state.text <- Printf.sprintf "bad integer `%s': %s" s (exntos exc)
3027 TEswitch ("vertical margin: ", "", None, intentry, ondone, true)
3029 | 'l' ->
3030 reqlayout conf.angle (not conf.proportional);
3031 TEdone ("proportional display " ^ btos conf.proportional)
3033 | 'T' ->
3034 settrim (not conf.trimmargins) conf.trimfuzz;
3035 TEdone ("trim margins " ^ btos conf.trimmargins)
3037 | 'I' ->
3038 conf.invert <- not conf.invert;
3039 TEdone ("invert colors " ^ btos conf.invert)
3041 | 'x' ->
3042 let ondone s =
3043 cbput state.hists.sel s;
3044 conf.selcmd <- s;
3046 TEswitch ("selection command: ", "", Some (onhist state.hists.sel),
3047 textentry, ondone, true)
3049 | _ ->
3050 state.text <- Printf.sprintf "bad option %d `%c'" key c;
3051 TEstop
3052 else
3053 TEcont state.text
3056 class type lvsource = object
3057 method getitemcount : int
3058 method getitem : int -> (string * int)
3059 method hasaction : int -> bool
3060 method exit :
3061 uioh:uioh ->
3062 cancel:bool ->
3063 active:int ->
3064 first:int ->
3065 pan:int ->
3066 qsearch:string ->
3067 uioh option
3068 method getactive : int
3069 method getfirst : int
3070 method getqsearch : string
3071 method setqsearch : string -> unit
3072 method getpan : int
3073 end;;
3075 class virtual lvsourcebase = object
3076 val mutable m_active = 0
3077 val mutable m_first = 0
3078 val mutable m_qsearch = ""
3079 val mutable m_pan = 0
3080 method getactive = m_active
3081 method getfirst = m_first
3082 method getqsearch = m_qsearch
3083 method getpan = m_pan
3084 method setqsearch s = m_qsearch <- s
3085 end;;
3087 let withoutlastutf8 s =
3088 let len = String.length s in
3089 if len = 0
3090 then s
3091 else
3092 let rec find pos =
3093 if pos = 0
3094 then pos
3095 else
3096 let b = Char.code s.[pos] in
3097 if b land 0b11000000 = 0b11000000
3098 then pos
3099 else find (pos-1)
3101 let first =
3102 if Char.code s.[len-1] land 0x80 = 0
3103 then len-1
3104 else find (len-1)
3106 String.sub s 0 first;
3109 let textentrykeyboard
3110 key _mask ((c, text, opthist, onkey, ondone, cancelonempty), onleave) =
3111 let key =
3112 if key >= 0xffb0 && key <= 0xffb9
3113 then key - 0xffb0 + 48 else key
3115 let enttext te =
3116 state.mode <- Textentry (te, onleave);
3117 state.text <- "";
3118 enttext ();
3119 G.postRedisplay "textentrykeyboard enttext";
3121 let histaction cmd =
3122 match opthist with
3123 | None -> ()
3124 | Some (action, _) ->
3125 state.mode <- Textentry (
3126 (c, action cmd, opthist, onkey, ondone, cancelonempty), onleave
3128 G.postRedisplay "textentry histaction"
3130 match key with
3131 | 0xff08 -> (* backspace *)
3132 let s = withoutlastutf8 text in
3133 let len = String.length s in
3134 if cancelonempty && len = 0
3135 then (
3136 onleave Cancel;
3137 G.postRedisplay "textentrykeyboard after cancel";
3139 else (
3140 enttext (c, s, opthist, onkey, ondone, cancelonempty)
3143 | 0xff0d | 0xff8d -> (* (kp) enter *)
3144 ondone text;
3145 onleave Confirm;
3146 G.postRedisplay "textentrykeyboard after confirm"
3148 | 0xff52 | 0xff97 -> histaction HCprev (* (kp) up *)
3149 | 0xff54 | 0xff99 -> histaction HCnext (* (kp) down *)
3150 | 0xff50 | 0xff95 -> histaction HCfirst (* (kp) home) *)
3151 | 0xff57 | 0xff9c -> histaction HClast (* (kp) end *)
3153 | 0xff1b -> (* escape*)
3154 if String.length text = 0
3155 then (
3156 begin match opthist with
3157 | None -> ()
3158 | Some (_, onhistcancel) -> onhistcancel ()
3159 end;
3160 onleave Cancel;
3161 state.text <- "";
3162 G.postRedisplay "textentrykeyboard after cancel2"
3164 else (
3165 enttext (c, "", opthist, onkey, ondone, cancelonempty)
3168 | 0xff9f | 0xffff -> () (* delete *)
3170 | _ when key != 0
3171 && key land 0xff00 != 0xff00 (* keyboard *)
3172 && key land 0xfe00 != 0xfe00 (* xkb *)
3173 && key land 0xfd00 != 0xfd00 (* 3270 *)
3175 begin match onkey text key with
3176 | TEdone text ->
3177 ondone text;
3178 onleave Confirm;
3179 G.postRedisplay "textentrykeyboard after confirm2";
3181 | TEcont text ->
3182 enttext (c, text, opthist, onkey, ondone, cancelonempty);
3184 | TEstop ->
3185 onleave Cancel;
3186 G.postRedisplay "textentrykeyboard after cancel3"
3188 | TEswitch te ->
3189 state.mode <- Textentry (te, onleave);
3190 G.postRedisplay "textentrykeyboard switch";
3191 end;
3193 | _ ->
3194 vlog "unhandled key %s" (Wsi.keyname key)
3197 let firstof first active =
3198 if first > active || abs (first - active) > fstate.maxrows - 1
3199 then max 0 (active - (fstate.maxrows/2))
3200 else first
3203 let calcfirst first active =
3204 if active > first
3205 then
3206 let rows = active - first in
3207 if rows > fstate.maxrows then active - fstate.maxrows else first
3208 else active
3211 let scrollph y maxy =
3212 let sh = (float (maxy + state.winh) /. float state.winh) in
3213 let sh = float state.winh /. sh in
3214 let sh = max sh (float conf.scrollh) in
3216 let percent =
3217 if y = state.maxy
3218 then 1.0
3219 else float y /. float maxy
3221 let position = (float state.winh -. sh) *. percent in
3223 let position =
3224 if position +. sh > float state.winh
3225 then float state.winh -. sh
3226 else position
3228 position, sh;
3231 let coe s = (s :> uioh);;
3233 class listview ~(source:lvsource) ~trusted ~modehash =
3234 object (self)
3235 val m_pan = source#getpan
3236 val m_first = source#getfirst
3237 val m_active = source#getactive
3238 val m_qsearch = source#getqsearch
3239 val m_prev_uioh = state.uioh
3241 method private elemunder y =
3242 let n = y / (fstate.fontsize+1) in
3243 if m_first + n < source#getitemcount
3244 then (
3245 if source#hasaction (m_first + n)
3246 then Some (m_first + n)
3247 else None
3249 else None
3251 method display =
3252 Gl.enable `blend;
3253 GlFunc.blend_func `src_alpha `one_minus_src_alpha;
3254 GlDraw.color (0., 0., 0.) ~alpha:0.85;
3255 GlDraw.rect (0., 0.) (float state.winw, float state.winh);
3256 GlDraw.color (1., 1., 1.);
3257 Gl.enable `texture_2d;
3258 let fs = fstate.fontsize in
3259 let nfs = fs + 1 in
3260 let ww = fstate.wwidth in
3261 let tabw = 30.0*.ww in
3262 let itemcount = source#getitemcount in
3263 let rec loop row =
3264 if (row - m_first) > fstate.maxrows
3265 then ()
3266 else (
3267 if row >= 0 && row < itemcount
3268 then (
3269 let (s, level) = source#getitem row in
3270 let y = (row - m_first) * nfs in
3271 let x = 5.0 +. float (level + m_pan) *. ww in
3272 if row = m_active
3273 then (
3274 Gl.disable `texture_2d;
3275 GlDraw.polygon_mode `both `line;
3276 GlDraw.color (1., 1., 1.) ~alpha:0.9;
3277 GlDraw.rect (1., float (y + 1))
3278 (float (state.winw - conf.scrollbw - 1), float (y + fs + 3));
3279 GlDraw.polygon_mode `both `fill;
3280 GlDraw.color (1., 1., 1.);
3281 Gl.enable `texture_2d;
3284 let drawtabularstring s =
3285 let drawstr x s = drawstring1 fs (truncate x) (y+nfs) s in
3286 if trusted
3287 then
3288 let tabpos = try String.index s '\t' with Not_found -> -1 in
3289 if tabpos > 0
3290 then
3291 let len = String.length s - tabpos - 1 in
3292 let s1 = String.sub s 0 tabpos
3293 and s2 = String.sub s (tabpos + 1) len in
3294 let nx = drawstr x s1 in
3295 let sw = nx -. x in
3296 let x = x +. (max tabw sw) in
3297 drawstr x s2
3298 else
3299 drawstr x s
3300 else
3301 drawstr x s
3303 let _ = drawtabularstring s in
3304 loop (row+1)
3308 loop m_first;
3309 Gl.disable `blend;
3310 Gl.disable `texture_2d;
3312 method updownlevel incr =
3313 let len = source#getitemcount in
3314 let curlevel =
3315 if m_active >= 0 && m_active < len
3316 then snd (source#getitem m_active)
3317 else -1
3319 let rec flow i =
3320 if i = len then i-1 else if i = -1 then 0 else
3321 let _, l = source#getitem i in
3322 if l != curlevel then i else flow (i+incr)
3324 let active = flow m_active in
3325 let first = calcfirst m_first active in
3326 G.postRedisplay "outline updownlevel";
3327 {< m_active = active; m_first = first >}
3329 method private key1 key mask =
3330 let set1 active first qsearch =
3331 coe {< m_active = active; m_first = first; m_qsearch = qsearch >}
3333 let search active pattern incr =
3334 let dosearch re =
3335 let rec loop n =
3336 if n >= 0 && n < source#getitemcount
3337 then (
3338 let s, _ = source#getitem n in
3340 (try ignore (Str.search_forward re s 0); true
3341 with Not_found -> false)
3342 then Some n
3343 else loop (n + incr)
3345 else None
3347 loop active
3350 let re = Str.regexp_case_fold pattern in
3351 dosearch re
3352 with Failure s ->
3353 state.text <- s;
3354 None
3356 let itemcount = source#getitemcount in
3357 let find start incr =
3358 let rec find i =
3359 if i = -1 || i = itemcount
3360 then -1
3361 else (
3362 if source#hasaction i
3363 then i
3364 else find (i + incr)
3367 find start
3369 let set active first =
3370 let first = bound first 0 (itemcount - fstate.maxrows) in
3371 state.text <- "";
3372 coe {< m_active = active; m_first = first >}
3374 let navigate incr =
3375 let isvisible first n = n >= first && n - first <= fstate.maxrows in
3376 let active, first =
3377 let incr1 = if incr > 0 then 1 else -1 in
3378 if isvisible m_first m_active
3379 then
3380 let next =
3381 let next = m_active + incr in
3382 let next =
3383 if next < 0 || next >= itemcount
3384 then -1
3385 else find next incr1
3387 if next = -1 || abs (m_active - next) > fstate.maxrows
3388 then -1
3389 else next
3391 if next = -1
3392 then
3393 let first = m_first + incr in
3394 let first = bound first 0 (itemcount - 1) in
3395 let next =
3396 let next = m_active + incr in
3397 let next = bound next 0 (itemcount - 1) in
3398 find next ~-incr1
3400 let active = if next = -1 then m_active else next in
3401 active, first
3402 else
3403 let first = min next m_first in
3404 let first =
3405 if abs (next - first) > fstate.maxrows
3406 then first + incr
3407 else first
3409 next, first
3410 else
3411 let first = m_first + incr in
3412 let first = bound first 0 (itemcount - 1) in
3413 let active =
3414 let next = m_active + incr in
3415 let next = bound next 0 (itemcount - 1) in
3416 let next = find next incr1 in
3417 let active =
3418 if next = -1 || abs (m_active - first) > fstate.maxrows
3419 then (
3420 let active = if m_active = -1 then next else m_active in
3421 active
3423 else next
3425 if isvisible first active
3426 then active
3427 else -1
3429 active, first
3431 G.postRedisplay "listview navigate";
3432 set active first;
3434 match key with
3435 | (0x72|0x73) when Wsi.withctrl mask -> (* ctrl-r/ctlr-s *)
3436 let incr = if key = 0x72 then -1 else 1 in
3437 let active, first =
3438 match search (m_active + incr) m_qsearch incr with
3439 | None ->
3440 state.text <- m_qsearch ^ " [not found]";
3441 m_active, m_first
3442 | Some active ->
3443 state.text <- m_qsearch;
3444 active, firstof m_first active
3446 G.postRedisplay "listview ctrl-r/s";
3447 set1 active first m_qsearch;
3449 | 0xff08 -> (* backspace *)
3450 if String.length m_qsearch = 0
3451 then coe self
3452 else (
3453 let qsearch = withoutlastutf8 m_qsearch in
3454 let len = String.length qsearch in
3455 if len = 0
3456 then (
3457 state.text <- "";
3458 G.postRedisplay "listview empty qsearch";
3459 set1 m_active m_first "";
3461 else
3462 let active, first =
3463 match search m_active qsearch ~-1 with
3464 | None ->
3465 state.text <- qsearch ^ " [not found]";
3466 m_active, m_first
3467 | Some active ->
3468 state.text <- qsearch;
3469 active, firstof m_first active
3471 G.postRedisplay "listview backspace qsearch";
3472 set1 active first qsearch
3475 | key when (key != 0 && key land 0xff00 != 0xff00) ->
3476 let pattern = m_qsearch ^ toutf8 key in
3477 let active, first =
3478 match search m_active pattern 1 with
3479 | None ->
3480 state.text <- pattern ^ " [not found]";
3481 m_active, m_first
3482 | Some active ->
3483 state.text <- pattern;
3484 active, firstof m_first active
3486 G.postRedisplay "listview qsearch add";
3487 set1 active first pattern;
3489 | 0xff1b -> (* escape *)
3490 state.text <- "";
3491 if String.length m_qsearch = 0
3492 then (
3493 G.postRedisplay "list view escape";
3494 begin
3495 match
3496 source#exit (coe self) true m_active m_first m_pan m_qsearch
3497 with
3498 | None -> m_prev_uioh
3499 | Some uioh -> uioh
3502 else (
3503 G.postRedisplay "list view kill qsearch";
3504 source#setqsearch "";
3505 coe {< m_qsearch = "" >}
3508 | 0xff0d | 0xff8d -> (* (kp) enter *)
3509 state.text <- "";
3510 let self = {< m_qsearch = "" >} in
3511 source#setqsearch "";
3512 let opt =
3513 G.postRedisplay "listview enter";
3514 if m_active >= 0 && m_active < source#getitemcount
3515 then (
3516 source#exit (coe self) false m_active m_first m_pan "";
3518 else (
3519 source#exit (coe self) true m_active m_first m_pan "";
3522 begin match opt with
3523 | None -> m_prev_uioh
3524 | Some uioh -> uioh
3527 | 0xff9f | 0xffff -> (* (kp) delete *)
3528 coe self
3530 | 0xff52 | 0xff97 -> navigate ~-1 (* (kp) up *)
3531 | 0xff54 | 0xff99 -> navigate 1 (* (kp) down *)
3532 | 0xff55 | 0xff9a -> navigate ~-(fstate.maxrows) (* (kp) prior *)
3533 | 0xff56 | 0xff9b -> navigate fstate.maxrows (* (kp) next *)
3535 | 0xff53 | 0xff98 -> (* (kp) right *)
3536 state.text <- "";
3537 G.postRedisplay "listview right";
3538 coe {< m_pan = m_pan - 1 >}
3540 | 0xff51 | 0xff96 -> (* (kp) left *)
3541 state.text <- "";
3542 G.postRedisplay "listview left";
3543 coe {< m_pan = m_pan + 1 >}
3545 | 0xff50 | 0xff95 -> (* (kp) home *)
3546 let active = find 0 1 in
3547 G.postRedisplay "listview home";
3548 set active 0;
3550 | 0xff57 | 0xff9c -> (* (kp) end *)
3551 let first = max 0 (itemcount - fstate.maxrows) in
3552 let active = find (itemcount - 1) ~-1 in
3553 G.postRedisplay "listview end";
3554 set active first;
3556 | key when (key = 0 || key land 0xff00 = 0xff00) ->
3557 coe self
3559 | _ ->
3560 dolog "listview unknown key %#x" key; coe self
3562 method key key mask =
3563 match state.mode with
3564 | Textentry te -> textentrykeyboard key mask te; coe self
3565 | _ -> self#key1 key mask
3567 method button button down x y _ =
3568 let opt =
3569 match button with
3570 | 1 when x > state.winw - conf.scrollbw ->
3571 G.postRedisplay "listview scroll";
3572 if down
3573 then
3574 let _, position, sh = self#scrollph in
3575 if y > truncate position && y < truncate (position +. sh)
3576 then (
3577 state.mstate <- Mscrolly;
3578 Some (coe self)
3580 else
3581 let s = float (max 0 (y - conf.scrollh)) /. float state.winh in
3582 let first = truncate (s *. float source#getitemcount) in
3583 let first = min source#getitemcount first in
3584 Some (coe {< m_first = first; m_active = first >})
3585 else (
3586 state.mstate <- Mnone;
3587 Some (coe self);
3589 | 1 when not down ->
3590 begin match self#elemunder y with
3591 | Some n ->
3592 G.postRedisplay "listview click";
3593 source#exit
3594 (coe {< m_active = n >}) false n m_first m_pan m_qsearch
3595 | _ ->
3596 Some (coe self)
3598 | n when (n == 4 || n == 5) && not down ->
3599 let len = source#getitemcount in
3600 let first =
3601 if n = 5 && m_first + fstate.maxrows >= len
3602 then
3603 m_first
3604 else
3605 let first = m_first + (if n == 4 then -1 else 1) in
3606 bound first 0 (len - 1)
3608 G.postRedisplay "listview wheel";
3609 Some (coe {< m_first = first >})
3610 | n when (n = 6 || n = 7) && not down ->
3611 let inc = m_first + (if n = 7 then -1 else 1) in
3612 G.postRedisplay "listview hwheel";
3613 Some (coe {< m_pan = m_pan + inc >})
3614 | _ ->
3615 Some (coe self)
3617 match opt with
3618 | None -> m_prev_uioh
3619 | Some uioh -> uioh
3621 method motion _ y =
3622 match state.mstate with
3623 | Mscrolly ->
3624 let s = float (max 0 (y - conf.scrollh)) /. float state.winh in
3625 let first = truncate (s *. float source#getitemcount) in
3626 let first = min source#getitemcount first in
3627 G.postRedisplay "listview motion";
3628 coe {< m_first = first; m_active = first >}
3629 | _ -> coe self
3631 method pmotion x y =
3632 if x < state.winw - conf.scrollbw
3633 then
3634 let n =
3635 match self#elemunder y with
3636 | None -> Wsi.setcursor Wsi.CURSOR_INHERIT; m_active
3637 | Some n -> Wsi.setcursor Wsi.CURSOR_INFO; n
3639 let o =
3640 if n != m_active
3641 then (G.postRedisplay "listview pmotion"; {< m_active = n >})
3642 else self
3644 coe o
3645 else (
3646 Wsi.setcursor Wsi.CURSOR_INHERIT;
3647 coe self
3650 method infochanged _ = ()
3652 method scrollpw = (0, 0.0, 0.0)
3653 method scrollph =
3654 let nfs = fstate.fontsize + 1 in
3655 let y = m_first * nfs in
3656 let itemcount = source#getitemcount in
3657 let maxi = max 0 (itemcount - fstate.maxrows) in
3658 let maxy = maxi * nfs in
3659 let p, h = scrollph y maxy in
3660 conf.scrollbw, p, h
3662 method modehash = modehash
3663 end;;
3665 class outlinelistview ~source =
3666 object (self)
3667 inherit listview
3668 ~source:(source :> lvsource)
3669 ~trusted:false
3670 ~modehash:(findkeyhash conf "outline")
3671 as super
3673 method key key mask =
3674 let calcfirst first active =
3675 if active > first
3676 then
3677 let rows = active - first in
3678 let maxrows =
3679 if String.length state.text = 0
3680 then fstate.maxrows
3681 else fstate.maxrows - 2
3683 if rows > maxrows then active - maxrows else first
3684 else active
3686 let navigate incr =
3687 let active = m_active + incr in
3688 let active = bound active 0 (source#getitemcount - 1) in
3689 let first = calcfirst m_first active in
3690 G.postRedisplay "outline navigate";
3691 coe {< m_active = active; m_first = first >}
3693 let ctrl = Wsi.withctrl mask in
3694 match key with
3695 | 110 when ctrl -> (* ctrl-n *)
3696 source#narrow m_qsearch;
3697 G.postRedisplay "outline ctrl-n";
3698 coe {< m_first = 0; m_active = 0 >}
3700 | 117 when ctrl -> (* ctrl-u *)
3701 source#denarrow;
3702 G.postRedisplay "outline ctrl-u";
3703 state.text <- "";
3704 coe {< m_first = 0; m_active = 0 >}
3706 | 108 when ctrl -> (* ctrl-l *)
3707 let first = max 0 (m_active - (fstate.maxrows / 2)) in
3708 G.postRedisplay "outline ctrl-l";
3709 coe {< m_first = first >}
3711 | 0xff9f | 0xffff -> (* (kp) delete *)
3712 source#remove m_active;
3713 G.postRedisplay "outline delete";
3714 let active = max 0 (m_active-1) in
3715 coe {< m_first = firstof m_first active;
3716 m_active = active >}
3718 | 0xff52 | 0xff97 -> navigate ~-1 (* (kp) up *)
3719 | 0xff54 | 0xff99 -> navigate 1 (* (kp) down *)
3720 | 0xff55 | 0xff9a -> (* (kp) prior *)
3721 navigate ~-(fstate.maxrows)
3722 | 0xff56 | 0xff9b -> (* (kp) next *)
3723 navigate fstate.maxrows
3725 | 0xff53 | 0xff98 -> (* [ctrl-] (kp) right *)
3726 let o =
3727 if ctrl
3728 then (
3729 G.postRedisplay "outline ctrl right";
3730 {< m_pan = m_pan + 1 >}
3732 else self#updownlevel 1
3734 coe o
3736 | 0xff51 | 0xff96 -> (* [ctrl-] (kp) left *)
3737 let o =
3738 if ctrl
3739 then (
3740 G.postRedisplay "outline ctrl left";
3741 {< m_pan = m_pan - 1 >}
3743 else self#updownlevel ~-1
3745 coe o
3747 | 0xff50 | 0xff95 -> (* (kp) home *)
3748 G.postRedisplay "outline home";
3749 coe {< m_first = 0; m_active = 0 >}
3751 | 0xff57 | 0xff9c -> (* (kp) end *)
3752 let active = source#getitemcount - 1 in
3753 let first = max 0 (active - fstate.maxrows) in
3754 G.postRedisplay "outline end";
3755 coe {< m_active = active; m_first = first >}
3757 | _ -> super#key key mask
3760 let outlinesource usebookmarks =
3761 let empty = [||] in
3762 (object
3763 inherit lvsourcebase
3764 val mutable m_items = empty
3765 val mutable m_orig_items = empty
3766 val mutable m_prev_items = empty
3767 val mutable m_narrow_pattern = ""
3768 val mutable m_hadremovals = false
3770 method getitemcount =
3771 Array.length m_items + (if m_hadremovals then 1 else 0)
3773 method getitem n =
3774 if n == Array.length m_items && m_hadremovals
3775 then
3776 ("[Confirm removal]", 0)
3777 else
3778 let s, n, _ = m_items.(n) in
3779 (s, n)
3781 method exit ~uioh ~cancel ~active ~first ~pan ~qsearch =
3782 ignore (uioh, first, qsearch);
3783 let confrimremoval = m_hadremovals && active = Array.length m_items in
3784 let items =
3785 if String.length m_narrow_pattern = 0
3786 then m_orig_items
3787 else m_items
3789 if not cancel
3790 then (
3791 if not confrimremoval
3792 then(
3793 let _, _, anchor = m_items.(active) in
3794 gotoghyll (getanchory anchor);
3795 m_items <- items;
3797 else (
3798 state.bookmarks <- Array.to_list m_items;
3799 m_orig_items <- m_items;
3802 else m_items <- items;
3803 m_pan <- pan;
3804 None
3806 method hasaction _ = true
3808 method greetmsg =
3809 if Array.length m_items != Array.length m_orig_items
3810 then "Narrowed to " ^ m_narrow_pattern ^ " (ctrl-u to restore)"
3811 else ""
3813 method narrow pattern =
3814 let reopt = try Some (Str.regexp_case_fold pattern) with _ -> None in
3815 match reopt with
3816 | None -> ()
3817 | Some re ->
3818 let rec loop accu n =
3819 if n = -1
3820 then (
3821 m_narrow_pattern <- pattern;
3822 m_items <- Array.of_list accu
3824 else
3825 let (s, _, _) as o = m_items.(n) in
3826 let accu =
3827 if (try ignore (Str.search_forward re s 0); true
3828 with Not_found -> false)
3829 then o :: accu
3830 else accu
3832 loop accu (n-1)
3834 loop [] (Array.length m_items - 1)
3836 method denarrow =
3837 m_orig_items <- (
3838 if usebookmarks
3839 then Array.of_list state.bookmarks
3840 else state.outlines
3842 m_items <- m_orig_items
3844 method remove m =
3845 if usebookmarks
3846 then
3847 if m >= 0 && m < Array.length m_items
3848 then (
3849 m_hadremovals <- true;
3850 m_items <- Array.init (Array.length m_items - 1) (fun n ->
3851 let n = if n >= m then n+1 else n in
3852 m_items.(n)
3856 method reset anchor items =
3857 m_hadremovals <- false;
3858 if m_orig_items == empty || m_prev_items != items
3859 then (
3860 m_orig_items <- items;
3861 if String.length m_narrow_pattern = 0
3862 then m_items <- items;
3864 m_prev_items <- items;
3865 let rely = getanchory anchor in
3866 let active =
3867 let rec loop n best bestd =
3868 if n = Array.length m_items
3869 then best
3870 else
3871 let (_, _, anchor) = m_items.(n) in
3872 let orely = getanchory anchor in
3873 let d = abs (orely - rely) in
3874 if d < bestd
3875 then loop (n+1) n d
3876 else loop (n+1) best bestd
3878 loop 0 ~-1 max_int
3880 m_active <- active;
3881 m_first <- firstof m_first active
3882 end)
3885 let enterselector usebookmarks =
3886 let source = outlinesource usebookmarks in
3887 fun errmsg ->
3888 let outlines =
3889 if usebookmarks
3890 then Array.of_list state.bookmarks
3891 else state.outlines
3893 if Array.length outlines = 0
3894 then (
3895 showtext ' ' errmsg;
3897 else (
3898 state.text <- source#greetmsg;
3899 Wsi.setcursor Wsi.CURSOR_INHERIT;
3900 let anchor = getanchor () in
3901 source#reset anchor outlines;
3902 state.uioh <- coe (new outlinelistview ~source);
3903 G.postRedisplay "enter selector";
3907 let enteroutlinemode =
3908 let f = enterselector false in
3909 fun ()-> f "Document has no outline";
3912 let enterbookmarkmode =
3913 let f = enterselector true in
3914 fun () -> f "Document has no bookmarks (yet)";
3917 let color_of_string s =
3918 Scanf.sscanf s "%d/%d/%d" (fun r g b ->
3919 (float r /. 256.0, float g /. 256.0, float b /. 256.0)
3923 let color_to_string (r, g, b) =
3924 let r = truncate (r *. 256.0)
3925 and g = truncate (g *. 256.0)
3926 and b = truncate (b *. 256.0) in
3927 Printf.sprintf "%d/%d/%d" r g b
3930 let irect_of_string s =
3931 Scanf.sscanf s "%d/%d/%d/%d" (fun x0 y0 x1 y1 -> (x0,y0,x1,y1))
3934 let irect_to_string (x0,y0,x1,y1) =
3935 Printf.sprintf "%d/%d/%d/%d" x0 y0 x1 y1
3938 let makecheckers () =
3939 (* Based on lablGL-1.04/LablGlut/examples/lablGL/checker.ml which had
3940 following to say:
3941 converted by Issac Trotts. July 25, 2002 *)
3942 let image = GlPix.create `ubyte ~format:`luminance ~width:2 ~height:2 in
3943 Raw.sets_string (GlPix.to_raw image) ~pos:0 "\255\200\200\255";
3944 let id = GlTex.gen_texture () in
3945 GlTex.bind_texture `texture_2d id;
3946 GlPix.store (`unpack_alignment 1);
3947 GlTex.image2d image;
3948 List.iter (GlTex.parameter ~target:`texture_2d)
3949 [ `mag_filter `nearest; `min_filter `nearest ];
3953 let setcheckers enabled =
3954 match state.texid with
3955 | None ->
3956 if enabled then state.texid <- Some (makecheckers ())
3958 | Some texid ->
3959 if not enabled
3960 then (
3961 GlTex.delete_texture texid;
3962 state.texid <- None;
3966 let int_of_string_with_suffix s =
3967 let l = String.length s in
3968 let s1, shift =
3969 if l > 1
3970 then
3971 let suffix = Char.lowercase s.[l-1] in
3972 match suffix with
3973 | 'k' -> String.sub s 0 (l-1), 10
3974 | 'm' -> String.sub s 0 (l-1), 20
3975 | 'g' -> String.sub s 0 (l-1), 30
3976 | _ -> s, 0
3977 else s, 0
3979 let n = int_of_string s1 in
3980 let m = n lsl shift in
3981 if m < 0 || m < n
3982 then raise (Failure "value too large")
3983 else m
3986 let string_with_suffix_of_int n =
3987 if n = 0
3988 then "0"
3989 else
3990 let n, s =
3991 if n land ((1 lsl 30) - 1) = 0
3992 then n lsr 30, "G"
3993 else (
3994 if n land ((1 lsl 20) - 1) = 0
3995 then n lsr 20, "M"
3996 else (
3997 if n land ((1 lsl 10) - 1) = 0
3998 then n lsr 10, "K"
3999 else n, ""
4003 let rec loop s n =
4004 let h = n mod 1000 in
4005 let n = n / 1000 in
4006 if n = 0
4007 then string_of_int h ^ s
4008 else (
4009 let s = Printf.sprintf "_%03d%s" h s in
4010 loop s n
4013 loop "" n ^ s;
4016 let defghyllscroll = (40, 8, 32);;
4017 let ghyllscroll_of_string s =
4018 let (n, a, b) as nab =
4019 if s = "default"
4020 then defghyllscroll
4021 else Scanf.sscanf s "%u,%u,%u" (fun n a b -> n, a, b)
4023 if n <= a || n <= b || a >= b
4024 then failwith "invalid ghyll N,A,B (N <= A, A < B, N <= B)";
4025 nab;
4028 let ghyllscroll_to_string ((n, a, b) as nab) =
4029 if nab = defghyllscroll
4030 then "default"
4031 else Printf.sprintf "%d,%d,%d" n a b;
4034 let describe_location () =
4035 let fn = page_of_y state.y in
4036 let ln = page_of_y (state.y + state.winh - state.hscrollh) in
4037 let maxy = state.maxy - (if conf.maxhfit then state.winh else 0) in
4038 let percent =
4039 if maxy <= 0
4040 then 100.
4041 else (100. *. (float state.y /. float maxy))
4043 if fn = ln
4044 then
4045 Printf.sprintf "page %d of %d [%.2f%%]"
4046 (fn+1) state.pagecount percent
4047 else
4048 Printf.sprintf
4049 "pages %d-%d of %d [%.2f%%]"
4050 (fn+1) (ln+1) state.pagecount percent
4053 let setpresentationmode v =
4054 let n = page_of_y state.y in
4055 state.anchor <- (n, 0.0, 1.0);
4056 conf.presentation <- v;
4057 if conf.presentation
4058 then (
4059 if not conf.scrollbarinpm
4060 then state.scrollw <- 0;
4062 else state.scrollw <- conf.scrollbw;
4063 represent ();
4066 let enterinfomode =
4067 let btos b = if b then "\xe2\x88\x9a" else "" in
4068 let showextended = ref false in
4069 let leave mode = function
4070 | Confirm -> state.mode <- mode
4071 | Cancel -> state.mode <- mode in
4072 let src =
4073 (object
4074 val mutable m_first_time = true
4075 val mutable m_l = []
4076 val mutable m_a = [||]
4077 val mutable m_prev_uioh = nouioh
4078 val mutable m_prev_mode = View
4080 inherit lvsourcebase
4082 method reset prev_mode prev_uioh =
4083 m_a <- Array.of_list (List.rev m_l);
4084 m_l <- [];
4085 m_prev_mode <- prev_mode;
4086 m_prev_uioh <- prev_uioh;
4087 if m_first_time
4088 then (
4089 let rec loop n =
4090 if n >= Array.length m_a
4091 then ()
4092 else
4093 match m_a.(n) with
4094 | _, _, _, Action _ -> m_active <- n
4095 | _ -> loop (n+1)
4097 loop 0;
4098 m_first_time <- false;
4101 method int name get set =
4102 m_l <-
4103 (name, `int get, 1, Action (
4104 fun u ->
4105 let ondone s =
4106 try set (int_of_string s)
4107 with exn ->
4108 state.text <- Printf.sprintf "bad integer `%s': %s"
4109 s (exntos exn)
4111 state.text <- "";
4112 let te = name ^ ": ", "", None, intentry, ondone, true in
4113 state.mode <- Textentry (te, leave m_prev_mode);
4115 )) :: m_l
4117 method int_with_suffix name get set =
4118 m_l <-
4119 (name, `intws get, 1, Action (
4120 fun u ->
4121 let ondone s =
4122 try set (int_of_string_with_suffix s)
4123 with exn ->
4124 state.text <- Printf.sprintf "bad integer `%s': %s"
4125 s (exntos exn)
4127 state.text <- "";
4128 let te =
4129 name ^ ": ", "", None, intentry_with_suffix, ondone, true
4131 state.mode <- Textentry (te, leave m_prev_mode);
4133 )) :: m_l
4135 method bool ?(offset=1) ?(btos=btos) name get set =
4136 m_l <-
4137 (name, `bool (btos, get), offset, Action (
4138 fun u ->
4139 let v = get () in
4140 set (not v);
4142 )) :: m_l
4144 method color name get set =
4145 m_l <-
4146 (name, `color get, 1, Action (
4147 fun u ->
4148 let invalid = (nan, nan, nan) in
4149 let ondone s =
4150 let c =
4151 try color_of_string s
4152 with exn ->
4153 state.text <- Printf.sprintf "bad color `%s': %s"
4154 s (exntos exn);
4155 invalid
4157 if c <> invalid
4158 then set c;
4160 let te = name ^ ": ", "", None, textentry, ondone, true in
4161 state.text <- color_to_string (get ());
4162 state.mode <- Textentry (te, leave m_prev_mode);
4164 )) :: m_l
4166 method string name get set =
4167 m_l <-
4168 (name, `string get, 1, Action (
4169 fun u ->
4170 let ondone s = set s in
4171 let te = name ^ ": ", "", None, textentry, ondone, true in
4172 state.mode <- Textentry (te, leave m_prev_mode);
4174 )) :: m_l
4176 method colorspace name get set =
4177 m_l <-
4178 (name, `string get, 1, Action (
4179 fun _ ->
4180 let source =
4181 let vals = [| "rgb"; "bgr"; "gray" |] in
4182 (object
4183 inherit lvsourcebase
4185 initializer
4186 m_active <- int_of_colorspace conf.colorspace;
4187 m_first <- 0;
4189 method getitemcount = Array.length vals
4190 method getitem n = (vals.(n), 0)
4191 method exit ~uioh ~cancel ~active ~first ~pan ~qsearch =
4192 ignore (uioh, first, pan, qsearch);
4193 if not cancel then set active;
4194 None
4195 method hasaction _ = true
4196 end)
4198 state.text <- "";
4199 let modehash = findkeyhash conf "info" in
4200 coe (new listview ~source ~trusted:true ~modehash)
4201 )) :: m_l
4203 method caption s offset =
4204 m_l <- (s, `empty, offset, Noaction) :: m_l
4206 method caption2 s f offset =
4207 m_l <- (s, `string f, offset, Noaction) :: m_l
4209 method getitemcount = Array.length m_a
4211 method getitem n =
4212 let tostr = function
4213 | `int f -> string_of_int (f ())
4214 | `intws f -> string_with_suffix_of_int (f ())
4215 | `string f -> f ()
4216 | `color f -> color_to_string (f ())
4217 | `bool (btos, f) -> btos (f ())
4218 | `empty -> ""
4220 let name, t, offset, _ = m_a.(n) in
4221 ((let s = tostr t in
4222 if String.length s > 0
4223 then Printf.sprintf "%s\t%s" name s
4224 else name),
4225 offset)
4227 method exit ~uioh ~cancel ~active ~first ~pan ~qsearch =
4228 let uiohopt =
4229 if not cancel
4230 then (
4231 m_qsearch <- qsearch;
4232 let uioh =
4233 match m_a.(active) with
4234 | _, _, _, Action f -> f uioh
4235 | _ -> uioh
4237 Some uioh
4239 else None
4241 m_active <- active;
4242 m_first <- first;
4243 m_pan <- pan;
4244 uiohopt
4246 method hasaction n =
4247 match m_a.(n) with
4248 | _, _, _, Action _ -> true
4249 | _ -> false
4250 end)
4252 let rec fillsrc prevmode prevuioh =
4253 let sep () = src#caption "" 0 in
4254 let colorp name get set =
4255 src#string name
4256 (fun () -> color_to_string (get ()))
4257 (fun v ->
4259 let c = color_of_string v in
4260 set c
4261 with exn ->
4262 state.text <- Printf.sprintf "bad color `%s': %s" v (exntos exn)
4265 let oldmode = state.mode in
4266 let birdseye = isbirdseye state.mode in
4268 src#caption (if birdseye then "Setup (Bird's eye)" else "Setup") 0;
4270 src#bool "presentation mode"
4271 (fun () -> conf.presentation)
4272 (fun v -> setpresentationmode v);
4274 src#bool "ignore case in searches"
4275 (fun () -> conf.icase)
4276 (fun v -> conf.icase <- v);
4278 src#bool "preload"
4279 (fun () -> conf.preload)
4280 (fun v -> conf.preload <- v);
4282 src#bool "highlight links"
4283 (fun () -> conf.hlinks)
4284 (fun v -> conf.hlinks <- v);
4286 src#bool "under info"
4287 (fun () -> conf.underinfo)
4288 (fun v -> conf.underinfo <- v);
4290 src#bool "persistent bookmarks"
4291 (fun () -> conf.savebmarks)
4292 (fun v -> conf.savebmarks <- v);
4294 src#bool "proportional display"
4295 (fun () -> conf.proportional)
4296 (fun v -> reqlayout conf.angle v);
4298 src#bool "trim margins"
4299 (fun () -> conf.trimmargins)
4300 (fun v -> settrim v conf.trimfuzz; fillsrc prevmode prevuioh);
4302 src#bool "persistent location"
4303 (fun () -> conf.jumpback)
4304 (fun v -> conf.jumpback <- v);
4306 sep ();
4307 src#int "inter-page space"
4308 (fun () -> conf.interpagespace)
4309 (fun n ->
4310 conf.interpagespace <- n;
4311 docolumns conf.columns;
4312 let pageno, py =
4313 match state.layout with
4314 | [] -> 0, 0
4315 | l :: _ ->
4316 l.pageno, l.pagey
4318 state.maxy <- calcheight ();
4319 let y = getpagey pageno in
4320 gotoy (y + py)
4323 src#int "page bias"
4324 (fun () -> conf.pagebias)
4325 (fun v -> conf.pagebias <- v);
4327 src#int "scroll step"
4328 (fun () -> conf.scrollstep)
4329 (fun n -> conf.scrollstep <- n);
4331 src#int "horizontal scroll step"
4332 (fun () -> conf.hscrollstep)
4333 (fun v -> conf.hscrollstep <- v);
4335 src#int "auto scroll step"
4336 (fun () ->
4337 match state.autoscroll with
4338 | Some step -> step
4339 | _ -> conf.autoscrollstep)
4340 (fun n ->
4341 if state.autoscroll <> None
4342 then state.autoscroll <- Some n;
4343 conf.autoscrollstep <- n);
4345 src#int "zoom"
4346 (fun () -> truncate (conf.zoom *. 100.))
4347 (fun v -> setzoom ((float v) /. 100.));
4349 src#int "rotation"
4350 (fun () -> conf.angle)
4351 (fun v -> reqlayout v conf.proportional);
4353 src#int "scroll bar width"
4354 (fun () -> state.scrollw)
4355 (fun v ->
4356 state.scrollw <- v;
4357 conf.scrollbw <- v;
4358 reshape state.winw state.winh;
4361 src#int "scroll handle height"
4362 (fun () -> conf.scrollh)
4363 (fun v -> conf.scrollh <- v;);
4365 src#int "thumbnail width"
4366 (fun () -> conf.thumbw)
4367 (fun v ->
4368 conf.thumbw <- min 4096 v;
4369 match oldmode with
4370 | Birdseye beye ->
4371 leavebirdseye beye false;
4372 enterbirdseye ()
4373 | _ -> ()
4376 let mode = state.mode in
4377 src#string "columns"
4378 (fun () ->
4379 match conf.columns with
4380 | Csingle _ -> "1"
4381 | Cmulti (multi, _) -> multicolumns_to_string multi
4382 | Csplit (count, _) -> "-" ^ string_of_int count
4384 (fun v ->
4385 let n, a, b = multicolumns_of_string v in
4386 setcolumns mode n a b);
4388 sep ();
4389 src#caption "Presentation mode" 0;
4390 src#bool "scrollbar visible"
4391 (fun () -> conf.scrollbarinpm)
4392 (fun v ->
4393 if v != conf.scrollbarinpm
4394 then (
4395 conf.scrollbarinpm <- v;
4396 if conf.presentation
4397 then (
4398 state.scrollw <- if v then conf.scrollbw else 0;
4399 reshape state.winw state.winh;
4404 sep ();
4405 src#caption "Pixmap cache" 0;
4406 src#int_with_suffix "size (advisory)"
4407 (fun () -> conf.memlimit)
4408 (fun v -> conf.memlimit <- v);
4410 src#caption2 "used"
4411 (fun () -> Printf.sprintf "%s bytes, %d tiles"
4412 (string_with_suffix_of_int state.memused)
4413 (Hashtbl.length state.tilemap)) 1;
4415 sep ();
4416 src#caption "Layout" 0;
4417 src#caption2 "Dimension"
4418 (fun () ->
4419 Printf.sprintf "%dx%d (virtual %dx%d)"
4420 state.winw state.winh
4421 state.w state.maxy)
4423 if conf.debug
4424 then
4425 src#caption2 "Position" (fun () ->
4426 Printf.sprintf "%dx%d" state.x state.y
4428 else
4429 src#caption2 "Position" (fun () -> describe_location ()) 1
4432 sep ();
4433 src#bool ~offset:0 ~btos:(fun v -> if v then "(on)" else "(off)")
4434 "Save these parameters as global defaults at exit"
4435 (fun () -> conf.bedefault)
4436 (fun v -> conf.bedefault <- v)
4439 sep ();
4440 let btos b = if b then "\xc2\xab" else "\xc2\xbb" in
4441 src#bool ~offset:0 ~btos "Extended parameters"
4442 (fun () -> !showextended)
4443 (fun v -> showextended := v; fillsrc prevmode prevuioh);
4444 if !showextended
4445 then (
4446 src#bool "checkers"
4447 (fun () -> conf.checkers)
4448 (fun v -> conf.checkers <- v; setcheckers v);
4449 src#bool "update cursor"
4450 (fun () -> conf.updatecurs)
4451 (fun v -> conf.updatecurs <- v);
4452 src#bool "verbose"
4453 (fun () -> conf.verbose)
4454 (fun v -> conf.verbose <- v);
4455 src#bool "invert colors"
4456 (fun () -> conf.invert)
4457 (fun v -> conf.invert <- v);
4458 src#bool "max fit"
4459 (fun () -> conf.maxhfit)
4460 (fun v -> conf.maxhfit <- v);
4461 src#bool "redirect stderr"
4462 (fun () -> conf.redirectstderr)
4463 (fun v -> conf.redirectstderr <- v; redirectstderr ());
4464 src#string "uri launcher"
4465 (fun () -> conf.urilauncher)
4466 (fun v -> conf.urilauncher <- v);
4467 src#string "path launcher"
4468 (fun () -> conf.pathlauncher)
4469 (fun v -> conf.pathlauncher <- v);
4470 src#string "tile size"
4471 (fun () -> Printf.sprintf "%dx%d" conf.tilew conf.tileh)
4472 (fun v ->
4474 let w, h = Scanf.sscanf v "%dx%d" (fun w h -> w, h) in
4475 conf.tilew <- max 64 w;
4476 conf.tileh <- max 64 h;
4477 flushtiles ();
4478 with exn ->
4479 state.text <- Printf.sprintf "bad tile size `%s': %s"
4480 v (exntos exn)
4482 src#int "texture count"
4483 (fun () -> conf.texcount)
4484 (fun v ->
4485 if realloctexts v
4486 then conf.texcount <- v
4487 else showtext '!' " Failed to set texture count please retry later"
4489 src#int "slice height"
4490 (fun () -> conf.sliceheight)
4491 (fun v ->
4492 conf.sliceheight <- v;
4493 wcmd "sliceh %d" conf.sliceheight;
4495 src#int "anti-aliasing level"
4496 (fun () -> conf.aalevel)
4497 (fun v ->
4498 conf.aalevel <- bound v 0 8;
4499 state.anchor <- getanchor ();
4500 opendoc state.path state.password;
4502 src#string "page scroll scaling factor"
4503 (fun () -> string_of_float conf.pgscale)
4504 (fun v ->
4506 let s = float_of_string v in
4507 conf.pgscale <- s
4508 with exn ->
4509 state.text <- Printf.sprintf
4510 "bad page scroll scaling factor `%s': %s" v (exntos exn)
4513 src#int "ui font size"
4514 (fun () -> fstate.fontsize)
4515 (fun v -> setfontsize (bound v 5 100));
4516 src#int "hint font size"
4517 (fun () -> conf.hfsize)
4518 (fun v -> conf.hfsize <- bound v 5 100);
4519 colorp "background color"
4520 (fun () -> conf.bgcolor)
4521 (fun v -> conf.bgcolor <- v);
4522 src#bool "crop hack"
4523 (fun () -> conf.crophack)
4524 (fun v -> conf.crophack <- v);
4525 src#string "trim fuzz"
4526 (fun () -> irect_to_string conf.trimfuzz)
4527 (fun v ->
4529 conf.trimfuzz <- irect_of_string v;
4530 if conf.trimmargins
4531 then settrim true conf.trimfuzz;
4532 with exn ->
4533 state.text <- Printf.sprintf "bad irect `%s': %s" v (exntos exn)
4535 src#string "throttle"
4536 (fun () ->
4537 match conf.maxwait with
4538 | None -> "show place holder if page is not ready"
4539 | Some time ->
4540 if time = infinity
4541 then "wait for page to fully render"
4542 else
4543 "wait " ^ string_of_float time
4544 ^ " seconds before showing placeholder"
4546 (fun v ->
4548 let f = float_of_string v in
4549 if f <= 0.0
4550 then conf.maxwait <- None
4551 else conf.maxwait <- Some f
4552 with exn ->
4553 state.text <- Printf.sprintf "bad time `%s': %s" v (exntos exn)
4555 src#string "ghyll scroll"
4556 (fun () ->
4557 match conf.ghyllscroll with
4558 | None -> ""
4559 | Some nab -> ghyllscroll_to_string nab
4561 (fun v ->
4563 let gs =
4564 if String.length v = 0
4565 then None
4566 else Some (ghyllscroll_of_string v)
4568 conf.ghyllscroll <- gs
4569 with exn ->
4570 state.text <- Printf.sprintf "bad ghyll `%s': %s" v (exntos exn)
4572 src#string "selection command"
4573 (fun () -> conf.selcmd)
4574 (fun v -> conf.selcmd <- v);
4575 src#string "synctex command"
4576 (fun () -> conf.stcmd)
4577 (fun v -> conf.stcmd <- v);
4578 src#colorspace "color space"
4579 (fun () -> colorspace_to_string conf.colorspace)
4580 (fun v ->
4581 conf.colorspace <- colorspace_of_int v;
4582 wcmd "cs %d" v;
4583 load state.layout;
4585 if pbousable ()
4586 then
4587 src#bool "use PBO"
4588 (fun () -> conf.usepbo)
4589 (fun v -> conf.usepbo <- v);
4590 src#bool "mouse wheel scrolls pages"
4591 (fun () -> conf.wheelbypage)
4592 (fun v -> conf.wheelbypage <- v);
4595 sep ();
4596 src#caption "Document" 0;
4597 List.iter (fun (_, s) -> src#caption s 1) state.docinfo;
4598 src#caption2 "Pages"
4599 (fun () -> string_of_int state.pagecount) 1;
4600 src#caption2 "Dimensions"
4601 (fun () -> string_of_int (List.length state.pdims)) 1;
4602 if conf.trimmargins
4603 then (
4604 sep ();
4605 src#caption "Trimmed margins" 0;
4606 src#caption2 "Dimensions"
4607 (fun () -> string_of_int (List.length state.pdims)) 1;
4610 sep ();
4611 src#caption "OpenGL" 0;
4612 src#caption (Printf.sprintf "Vendor\t%s" (GlMisc.get_string `vendor)) 1;
4613 src#caption (Printf.sprintf "Renderer\t%s" (GlMisc.get_string `renderer)) 1;
4614 src#reset prevmode prevuioh;
4616 fun () ->
4617 state.text <- "";
4618 let prevmode = state.mode
4619 and prevuioh = state.uioh in
4620 fillsrc prevmode prevuioh;
4621 let source = (src :> lvsource) in
4622 let modehash = findkeyhash conf "info" in
4623 state.uioh <- coe (object (self)
4624 inherit listview ~source ~trusted:true ~modehash as super
4625 val mutable m_prevmemused = 0
4626 method infochanged = function
4627 | Memused ->
4628 if m_prevmemused != state.memused
4629 then (
4630 m_prevmemused <- state.memused;
4631 G.postRedisplay "memusedchanged";
4633 | Pdim -> G.postRedisplay "pdimchanged"
4634 | Docinfo -> fillsrc prevmode prevuioh
4636 method key key mask =
4637 if not (Wsi.withctrl mask)
4638 then
4639 match key with
4640 | 0xff51 | 0xff96 -> coe (self#updownlevel ~-1) (* (kp) left *)
4641 | 0xff53 | 0xff98 -> coe (self#updownlevel 1) (* (kp) right *)
4642 | _ -> super#key key mask
4643 else super#key key mask
4644 end);
4645 G.postRedisplay "info";
4648 let enterhelpmode =
4649 let source =
4650 (object
4651 inherit lvsourcebase
4652 method getitemcount = Array.length state.help
4653 method getitem n =
4654 let s, l, _ = state.help.(n) in
4655 (s, l)
4657 method exit ~uioh ~cancel ~active ~first ~pan ~qsearch =
4658 let optuioh =
4659 if not cancel
4660 then (
4661 m_qsearch <- qsearch;
4662 match state.help.(active) with
4663 | _, _, Action f -> Some (f uioh)
4664 | _ -> Some (uioh)
4666 else None
4668 m_active <- active;
4669 m_first <- first;
4670 m_pan <- pan;
4671 optuioh
4673 method hasaction n =
4674 match state.help.(n) with
4675 | _, _, Action _ -> true
4676 | _ -> false
4678 initializer
4679 m_active <- -1
4680 end)
4681 in fun () ->
4682 let modehash = findkeyhash conf "help" in
4683 state.uioh <- coe (new listview ~source ~trusted:true ~modehash);
4684 G.postRedisplay "help";
4687 let entermsgsmode =
4688 let msgsource =
4689 let re = Str.regexp "[\r\n]" in
4690 (object
4691 inherit lvsourcebase
4692 val mutable m_items = [||]
4694 method getitemcount = 1 + Array.length m_items
4696 method getitem n =
4697 if n = 0
4698 then "[Clear]", 0
4699 else m_items.(n-1), 0
4701 method exit ~uioh ~cancel ~active ~first ~pan ~qsearch =
4702 ignore uioh;
4703 if not cancel
4704 then (
4705 if active = 0
4706 then Buffer.clear state.errmsgs;
4707 m_qsearch <- qsearch;
4709 m_active <- active;
4710 m_first <- first;
4711 m_pan <- pan;
4712 None
4714 method hasaction n =
4715 n = 0
4717 method reset =
4718 state.newerrmsgs <- false;
4719 let l = Str.split re (Buffer.contents state.errmsgs) in
4720 m_items <- Array.of_list l
4722 initializer
4723 m_active <- 0
4724 end)
4725 in fun () ->
4726 state.text <- "";
4727 msgsource#reset;
4728 let source = (msgsource :> lvsource) in
4729 let modehash = findkeyhash conf "listview" in
4730 state.uioh <- coe (object
4731 inherit listview ~source ~trusted:false ~modehash as super
4732 method display =
4733 if state.newerrmsgs
4734 then msgsource#reset;
4735 super#display
4736 end);
4737 G.postRedisplay "msgs";
4740 let quickbookmark ?title () =
4741 match state.layout with
4742 | [] -> ()
4743 | l :: _ ->
4744 let title =
4745 match title with
4746 | None ->
4747 let sec = Unix.gettimeofday () in
4748 let tm = Unix.localtime sec in
4749 Printf.sprintf "Quick (page %d) (bookmarked at %d/%d/%d %d:%d)"
4750 (l.pageno+1)
4751 tm.Unix.tm_mday
4752 tm.Unix.tm_mon
4753 (tm.Unix.tm_year + 1900)
4754 tm.Unix.tm_hour
4755 tm.Unix.tm_min
4756 | Some title -> title
4758 state.bookmarks <- (title, 0, getanchor1 l) :: state.bookmarks
4761 let doreshape w h =
4762 Wsi.reshape w h;
4765 let setautoscrollspeed step goingdown =
4766 let incr = max 1 ((abs step) / 2) in
4767 let incr = if goingdown then incr else -incr in
4768 let astep = step + incr in
4769 state.autoscroll <- Some astep;
4772 let gotounder = function
4773 | Ulinkgoto (pageno, top) ->
4774 if pageno >= 0
4775 then (
4776 addnav ();
4777 gotopage1 pageno top;
4780 | Ulinkuri s ->
4781 gotouri s
4783 | Uremote (filename, pageno) ->
4784 let path =
4785 if Sys.file_exists filename
4786 then filename
4787 else
4788 let dir = Filename.dirname state.path in
4789 let path = Filename.concat dir filename in
4790 if Sys.file_exists path
4791 then path
4792 else ""
4794 if String.length path > 0
4795 then (
4796 let anchor = getanchor () in
4797 let ranchor = state.path, state.password, anchor in
4798 state.anchor <- (pageno, 0.0, 0.0);
4799 state.ranchors <- ranchor :: state.ranchors;
4800 opendoc path "";
4802 else showtext '!' ("Could not find " ^ filename)
4804 | Uunexpected _ | Ulaunch _ | Unamed _ | Utext _ | Unone -> ()
4807 let canpan () =
4808 match conf.columns with
4809 | Csplit _ -> true
4810 | _ -> state.x != 0 || conf.zoom > 1.0
4813 let existsinrow pageno (columns, coverA, coverB) p =
4814 let last = ((pageno - coverA) mod columns) + columns in
4815 let rec any = function
4816 | [] -> false
4817 | l :: rest ->
4818 if l.pageno = coverA - 1 || l.pageno = state.pagecount - coverB
4819 then p l
4820 else (
4821 if not (p l)
4822 then (if l.pageno = last then false else any rest)
4823 else true
4826 any state.layout
4829 let nextpage () =
4830 match state.layout with
4831 | [] ->
4832 let pageno = page_of_y state.y in
4833 gotoghyll (getpagey (pageno+1))
4834 | l :: rest ->
4835 match conf.columns with
4836 | Csingle _ ->
4837 if conf.presentation && rest == [] && l.pageh > l.pagey + l.pagevh
4838 then
4839 let y = clamp (pgscale state.winh) in
4840 gotoghyll y
4841 else
4842 let pageno = min (l.pageno+1) (state.pagecount-1) in
4843 gotoghyll (getpagey pageno)
4844 | Cmulti ((c, _, _) as cl, _) ->
4845 if conf.presentation
4846 && (existsinrow l.pageno cl
4847 (fun l -> l.pageh > l.pagey + l.pagevh))
4848 then
4849 let y = clamp (pgscale state.winh) in
4850 gotoghyll y
4851 else
4852 let pageno = min (l.pageno+c) (state.pagecount-1) in
4853 gotoghyll (getpagey pageno)
4854 | Csplit (n, _) ->
4855 if l.pageno < state.pagecount - 1 || l.pagecol < n - 1
4856 then
4857 let pagey, pageh = getpageyh l.pageno in
4858 let pagey = pagey + pageh * l.pagecol in
4859 let ips = if l.pagecol = 0 then 0 else conf.interpagespace in
4860 gotoghyll (pagey + pageh + ips)
4863 let prevpage () =
4864 match state.layout with
4865 | [] ->
4866 let pageno = page_of_y state.y in
4867 gotoghyll (getpagey (pageno-1))
4868 | l :: _ ->
4869 match conf.columns with
4870 | Csingle _ ->
4871 if conf.presentation && l.pagey != 0
4872 then
4873 gotoghyll (clamp (pgscale ~-(state.winh)))
4874 else
4875 let pageno = max 0 (l.pageno-1) in
4876 gotoghyll (getpagey pageno)
4877 | Cmulti ((c, _, coverB) as cl, _) ->
4878 if conf.presentation &&
4879 (existsinrow l.pageno cl (fun l -> l.pagey != 0))
4880 then
4881 gotoghyll (clamp (pgscale ~-(state.winh)))
4882 else
4883 let decr =
4884 if l.pageno = state.pagecount - coverB
4885 then 1
4886 else c
4888 let pageno = max 0 (l.pageno-decr) in
4889 gotoghyll (getpagey pageno)
4890 | Csplit (n, _) ->
4891 let y =
4892 if l.pagecol = 0
4893 then
4894 if l.pageno = 0
4895 then l.pagey
4896 else
4897 let pageno = max 0 (l.pageno-1) in
4898 let pagey, pageh = getpageyh pageno in
4899 pagey + (n-1)*pageh
4900 else
4901 let pagey, pageh = getpageyh l.pageno in
4902 pagey + pageh * (l.pagecol-1) - conf.interpagespace
4904 gotoghyll y
4907 let viewkeyboard key mask =
4908 let enttext te =
4909 let mode = state.mode in
4910 state.mode <- Textentry (te, fun _ -> state.mode <- mode);
4911 state.text <- "";
4912 enttext ();
4913 G.postRedisplay "view:enttext"
4915 let ctrl = Wsi.withctrl mask in
4916 let key =
4917 if key >= 0xffb0 && key < 0xffb9 then key - 0xffb0 + 48 else key
4919 match key with
4920 | 81 -> (* Q *)
4921 exit 0
4923 | 0xff63 -> (* insert *)
4924 if conf.angle mod 360 = 0 && not (isbirdseye state.mode)
4925 then (
4926 state.mode <- LinkNav (Ltgendir 0);
4927 gotoy state.y;
4929 else showtext '!' "Keyboard link navigation does not work under rotation"
4931 | 0xff1b | 113 -> (* escape / q *)
4932 begin match state.mstate with
4933 | Mzoomrect _ ->
4934 state.mstate <- Mnone;
4935 Wsi.setcursor Wsi.CURSOR_INHERIT;
4936 G.postRedisplay "kill zoom rect";
4937 | _ ->
4938 begin match state.mode with
4939 | LinkNav _ ->
4940 state.mode <- View;
4941 G.postRedisplay "esc leave linknav"
4942 | _ ->
4943 match state.ranchors with
4944 | [] -> raise Quit
4945 | (path, password, anchor) :: rest ->
4946 state.ranchors <- rest;
4947 state.anchor <- anchor;
4948 opendoc path password
4949 end;
4950 end;
4952 | 0xff08 -> (* backspace *)
4953 gotoghyll (getnav ~-1)
4955 | 111 -> (* o *)
4956 enteroutlinemode ()
4958 | 117 -> (* u *)
4959 state.rects <- [];
4960 state.text <- "";
4961 G.postRedisplay "dehighlight";
4963 | 47 | 63 -> (* / ? *)
4964 let ondone isforw s =
4965 cbput state.hists.pat s;
4966 state.searchpattern <- s;
4967 search s isforw
4969 let s = String.create 1 in
4970 s.[0] <- Char.chr key;
4971 enttext (s, "", Some (onhist state.hists.pat),
4972 textentry, ondone (key = 47), true)
4974 | 43 | 0xffab | 61 when ctrl -> (* ctrl-+ or ctrl-= *)
4975 let incr = if conf.zoom +. 0.01 > 0.1 then 0.1 else 0.01 in
4976 setzoom (conf.zoom +. incr)
4978 | 43 | 0xffab -> (* + *)
4979 let ondone s =
4980 let n =
4981 try int_of_string s with exc ->
4982 state.text <- Printf.sprintf "bad integer `%s': %s" s (exntos exc);
4983 max_int
4985 if n != max_int
4986 then (
4987 conf.pagebias <- n;
4988 state.text <- "page bias is now " ^ string_of_int n;
4991 enttext ("page bias: ", "", None, intentry, ondone, true)
4993 | 45 | 0xffad when ctrl -> (* ctrl-- *)
4994 let decr = if conf.zoom -. 0.1 < 0.1 then 0.01 else 0.1 in
4995 setzoom (max 0.01 (conf.zoom -. decr))
4997 | 45 | 0xffad -> (* - *)
4998 let ondone msg = state.text <- msg in
4999 enttext (
5000 "option [acfhilpstvxACFPRSZTIS]: ", "", None,
5001 optentry state.mode, ondone, true
5004 | 48 when ctrl -> (* ctrl-0 *)
5005 if conf.zoom = 1.0
5006 then (
5007 state.x <- 0;
5008 state.hscrollh <-
5009 if state.w <= state.winw - state.scrollw
5010 then 0
5011 else state.scrollw
5013 gotoy state.y
5015 else setzoom 1.0
5017 | 49 when ctrl -> (* ctrl-1 *)
5018 let cols =
5019 match conf.columns with
5020 | Csingle _ | Cmulti _ -> 1
5021 | Csplit (n, _) -> n
5023 let zoom = zoomforh state.winw state.winh state.scrollw cols in
5024 if zoom < 1.0
5025 then setzoom zoom
5027 | 0xffc6 -> (* f9 *)
5028 togglebirdseye ()
5030 | 57 when ctrl -> (* ctrl-9 *)
5031 togglebirdseye ()
5033 | (48 | 49 | 50 | 51 | 52 | 53 | 54 | 55 | 56 | 57)
5034 when not ctrl -> (* 0..9 *)
5035 let ondone s =
5036 let n =
5037 try int_of_string s with exc ->
5038 state.text <- Printf.sprintf "bad integer `%s': %s" s (exntos exc);
5041 if n >= 0
5042 then (
5043 addnav ();
5044 cbput state.hists.pag (string_of_int n);
5045 gotopage1 (n + conf.pagebias - 1) 0;
5048 let pageentry text key =
5049 match Char.unsafe_chr key with
5050 | 'g' -> TEdone text
5051 | _ -> intentry text key
5053 let text = "x" in text.[0] <- Char.chr key;
5054 enttext (":", text, Some (onhist state.hists.pag), pageentry, ondone, true)
5056 | 98 -> (* b *)
5057 state.scrollw <- if state.scrollw > 0 then 0 else conf.scrollbw;
5058 reshape state.winw state.winh;
5060 | 108 -> (* l *)
5061 conf.hlinks <- not conf.hlinks;
5062 state.text <- "highlightlinks " ^ if conf.hlinks then "on" else "off";
5063 G.postRedisplay "toggle highlightlinks";
5065 | 70 -> (* F *)
5066 state.glinks <- true;
5067 let mode = state.mode in
5068 state.mode <- Textentry (
5069 (":", "", None, linknentry, linkndone gotounder, false),
5070 (fun _ ->
5071 state.glinks <- false;
5072 state.mode <- mode)
5074 state.text <- "";
5075 G.postRedisplay "view:linkent(F)"
5077 | 121 -> (* y *)
5078 state.glinks <- true;
5079 let mode = state.mode in
5080 state.mode <- Textentry (
5081 (":", "", None, linknentry, linkndone (fun under ->
5082 match Ne.pipe () with
5083 | Ne.Exn exn ->
5084 showtext '!' (Printf.sprintf "pipe failed: %s" (exntos exn))
5085 | Ne.Res (r, w) ->
5086 let popened =
5087 try popen conf.selcmd [r, 0; w, -1]; true
5088 with exn ->
5089 showtext '!'
5090 (Printf.sprintf "failed to execute %s: %s"
5091 conf.selcmd (exntos exn));
5092 false
5094 let clo cap fd =
5095 Ne.clo fd (fun msg ->
5096 showtext '!' (Printf.sprintf "failed to close %s: %s" cap msg)
5099 let s = undertext under in
5100 if popened
5101 then
5102 (try
5103 let l = String.length s in
5104 let n = tempfailureretry (Unix.write w s 0) l in
5105 if n != l
5106 then
5107 showtext '!'
5108 (Printf.sprintf
5109 "failed to write %d characters to sel pipe, wrote %d"
5112 with exn ->
5113 showtext '!'
5114 (Printf.sprintf "failed to write to sel pipe: %s"
5115 (exntos exn)
5118 else dolog "%s" s;
5119 clo "pipe/r" r;
5120 clo "pipe/w" w;
5121 ), false
5123 fun _ ->
5124 state.glinks <- false;
5125 state.mode <- mode
5127 state.text <- "";
5128 G.postRedisplay "view:linkent"
5130 | 97 -> (* a *)
5131 begin match state.autoscroll with
5132 | Some step ->
5133 conf.autoscrollstep <- step;
5134 state.autoscroll <- None
5135 | None ->
5136 if conf.autoscrollstep = 0
5137 then state.autoscroll <- Some 1
5138 else state.autoscroll <- Some conf.autoscrollstep
5141 | 112 when ctrl -> (* ctrl-p *)
5142 launchpath ()
5144 | 80 -> (* P *)
5145 setpresentationmode (not conf.presentation);
5146 showtext ' ' ("presentation mode " ^
5147 if conf.presentation then "on" else "off");
5149 | 102 -> (* f *)
5150 if List.mem Wsi.Fullscreen state.winstate
5151 then doreshape conf.cwinw conf.cwinh
5152 else Wsi.fullscreen ()
5154 | 112 | 78 -> (* p|N *)
5155 search state.searchpattern false
5157 | 110 | 0xffc0 -> (* n|F3 *)
5158 search state.searchpattern true
5160 | 116 -> (* t *)
5161 begin match state.layout with
5162 | [] -> ()
5163 | l :: _ ->
5164 gotoghyll (getpagey l.pageno)
5167 | 32 -> (* space *)
5168 nextpage ()
5170 | 0xff9f | 0xffff -> (* delete *)
5171 prevpage ()
5173 | 61 -> (* = *)
5174 showtext ' ' (describe_location ());
5176 | 119 -> (* w *)
5177 begin match state.layout with
5178 | [] -> ()
5179 | l :: _ ->
5180 doreshape (l.pagew + state.scrollw) l.pageh;
5181 G.postRedisplay "w"
5184 | 39 -> (* ' *)
5185 enterbookmarkmode ()
5187 | 104 | 0xffbe -> (* h|F1 *)
5188 enterhelpmode ()
5190 | 105 -> (* i *)
5191 enterinfomode ()
5193 | 101 when Buffer.length state.errmsgs > 0 -> (* e *)
5194 entermsgsmode ()
5196 | 109 -> (* m *)
5197 let ondone s =
5198 match state.layout with
5199 | l :: _ ->
5200 if String.length s > 0
5201 then
5202 state.bookmarks <- (s, 0, getanchor1 l) :: state.bookmarks
5203 | _ -> ()
5205 enttext ("bookmark: ", "", None, textentry, ondone, true)
5207 | 126 -> (* ~ *)
5208 quickbookmark ();
5209 showtext ' ' "Quick bookmark added";
5211 | 122 -> (* z *)
5212 begin match state.layout with
5213 | l :: _ ->
5214 let rect = getpdimrect l.pagedimno in
5215 let w, h =
5216 if conf.crophack
5217 then
5218 (truncate (1.8 *. (rect.(1) -. rect.(0))),
5219 truncate (1.2 *. (rect.(3) -. rect.(0))))
5220 else
5221 (truncate (rect.(1) -. rect.(0)),
5222 truncate (rect.(3) -. rect.(0)))
5224 let w = truncate ((float w)*.conf.zoom)
5225 and h = truncate ((float h)*.conf.zoom) in
5226 if w != 0 && h != 0
5227 then (
5228 state.anchor <- getanchor ();
5229 doreshape (w + state.scrollw) (h + conf.interpagespace)
5231 G.postRedisplay "z";
5233 | [] -> ()
5236 | 50 when ctrl -> (* ctrl-2 *)
5237 let maxw = getmaxw () in
5238 if maxw > 0.0
5239 then setzoom (maxw /. float state.winw)
5241 | 60 | 62 -> (* < > *)
5242 reqlayout (conf.angle + (if key = 62 then 30 else -30)) conf.proportional
5244 | 91 | 93 -> (* [ ] *)
5245 conf.colorscale <-
5246 bound (conf.colorscale +. (if key = 93 then 0.1 else -0.1)) 0.0 1.0
5248 G.postRedisplay "brightness";
5250 | 99 when state.mode = View -> (* c *)
5251 let (c, a, b), z =
5252 match state.prevcolumns with
5253 | None -> (1, 0, 0), 1.0
5254 | Some (columns, z) ->
5255 let cab =
5256 match columns with
5257 | Csplit (c, _) -> -c, 0, 0
5258 | Cmulti ((c, a, b), _) -> c, a, b
5259 | Csingle _ -> 1, 0, 0
5261 cab, z
5263 setcolumns View c a b;
5264 setzoom z;
5266 | 0xff54 | 0xff52 when ctrl && Wsi.withshift mask ->
5267 setzoom state.prevzoom
5269 | 107 | 0xff52 | 0xff97 -> (* k (kp) up *)
5270 begin match state.autoscroll with
5271 | None ->
5272 begin match state.mode with
5273 | Birdseye beye -> upbirdseye 1 beye
5274 | _ ->
5275 if ctrl
5276 then gotoy_and_clear_text (clamp ~-(state.winh/2))
5277 else gotoy_and_clear_text (clamp (-conf.scrollstep))
5279 | Some n ->
5280 setautoscrollspeed n false
5283 | 106 | 0xff54 | 0xff99 -> (* j (kp) down *)
5284 begin match state.autoscroll with
5285 | None ->
5286 begin match state.mode with
5287 | Birdseye beye -> downbirdseye 1 beye
5288 | _ ->
5289 if ctrl
5290 then gotoy_and_clear_text (clamp (state.winh/2))
5291 else gotoy_and_clear_text (clamp conf.scrollstep)
5293 | Some n ->
5294 setautoscrollspeed n true
5297 | 0xff51 | 0xff53 | 0xff96 | 0xff98
5298 when not (Wsi.withalt mask) -> (* (kp) left / right *)
5299 if canpan ()
5300 then
5301 let dx =
5302 if ctrl
5303 then state.winw / 2
5304 else conf.hscrollstep
5306 let dx = if key = 0xff51 or key = 0xff96 then dx else -dx in
5307 state.x <- state.x + dx;
5308 gotoy_and_clear_text state.y
5309 else (
5310 state.text <- "";
5311 G.postRedisplay "lef/right"
5314 | 0xff55 | 0xff9a -> (* (kp) prior *)
5315 let y =
5316 if ctrl
5317 then
5318 match state.layout with
5319 | [] -> state.y
5320 | l :: _ -> state.y - l.pagey
5321 else
5322 clamp (pgscale (-state.winh))
5324 gotoghyll y
5326 | 0xff56 | 0xff9b -> (* (kp) next *)
5327 let y =
5328 if ctrl
5329 then
5330 match List.rev state.layout with
5331 | [] -> state.y
5332 | l :: _ -> getpagey l.pageno
5333 else
5334 clamp (pgscale state.winh)
5336 gotoghyll y
5338 | 103 | 0xff50 | 0xff95 -> (* g (kp) home *)
5339 gotoghyll 0
5340 | 71 | 0xff57 | 0xff9c -> (* G (kp) end *)
5341 gotoghyll (clamp state.maxy)
5343 | 0xff53 | 0xff98
5344 when Wsi.withalt mask -> (* alt-(kp) right *)
5345 gotoghyll (getnav 1)
5346 | 0xff51 | 0xff96
5347 when Wsi.withalt mask -> (* alt-(kp) left *)
5348 gotoghyll (getnav ~-1)
5350 | 114 -> (* r *)
5351 reload ()
5353 | 118 when conf.debug -> (* v *)
5354 state.rects <- [];
5355 List.iter (fun l ->
5356 match getopaque l.pageno with
5357 | None -> ()
5358 | Some opaque ->
5359 let x0, y0, x1, y1 = pagebbox opaque in
5360 let a,b = float x0, float y0 in
5361 let c,d = float x1, float y0 in
5362 let e,f = float x1, float y1 in
5363 let h,j = float x0, float y1 in
5364 let rect = (a,b,c,d,e,f,h,j) in
5365 debugrect rect;
5366 state.rects <- (l.pageno, l.pageno mod 3, rect) :: state.rects;
5367 ) state.layout;
5368 G.postRedisplay "v";
5370 | _ ->
5371 vlog "huh? %s" (Wsi.keyname key)
5374 let linknavkeyboard key mask linknav =
5375 let getpage pageno =
5376 let rec loop = function
5377 | [] -> None
5378 | l :: _ when l.pageno = pageno -> Some l
5379 | _ :: rest -> loop rest
5380 in loop state.layout
5382 let doexact (pageno, n) =
5383 match getopaque pageno, getpage pageno with
5384 | Some opaque, Some l ->
5385 if key = 0xff0d || key = 0xff8d (* (kp)enter *)
5386 then
5387 let under = getlink opaque n in
5388 G.postRedisplay "link gotounder";
5389 gotounder under;
5390 state.mode <- View;
5391 else
5392 let opt, dir =
5393 match key with
5394 | 0xff50 -> (* home *)
5395 Some (findlink opaque LDfirst), -1
5397 | 0xff57 -> (* end *)
5398 Some (findlink opaque LDlast), 1
5400 | 0xff51 -> (* left *)
5401 Some (findlink opaque (LDleft n)), -1
5403 | 0xff53 -> (* right *)
5404 Some (findlink opaque (LDright n)), 1
5406 | 0xff52 -> (* up *)
5407 Some (findlink opaque (LDup n)), -1
5409 | 0xff54 -> (* down *)
5410 Some (findlink opaque (LDdown n)), 1
5412 | _ -> None, 0
5414 let pwl l dir =
5415 begin match findpwl l.pageno dir with
5416 | Pwlnotfound -> ()
5417 | Pwl pageno ->
5418 let notfound dir =
5419 state.mode <- LinkNav (Ltgendir dir);
5420 let y, h = getpageyh pageno in
5421 let y =
5422 if dir < 0
5423 then y + h - state.winh
5424 else y
5426 gotoy y
5428 begin match getopaque pageno, getpage pageno with
5429 | Some opaque, Some _ ->
5430 let link =
5431 let ld = if dir > 0 then LDfirst else LDlast in
5432 findlink opaque ld
5434 begin match link with
5435 | Lfound m ->
5436 showlinktype (getlink opaque m);
5437 state.mode <- LinkNav (Ltexact (pageno, m));
5438 G.postRedisplay "linknav jpage";
5439 | _ -> notfound dir
5440 end;
5441 | _ -> notfound dir
5442 end;
5443 end;
5445 begin match opt with
5446 | Some Lnotfound -> pwl l dir;
5447 | Some (Lfound m) ->
5448 if m = n
5449 then pwl l dir
5450 else (
5451 let _, y0, _, y1 = getlinkrect opaque m in
5452 if y0 < l.pagey
5453 then gotopage1 l.pageno y0
5454 else (
5455 let d = fstate.fontsize + 1 in
5456 if y1 - l.pagey > l.pagevh - d
5457 then gotopage1 l.pageno (y1 - state.winh - state.hscrollh + d)
5458 else G.postRedisplay "linknav";
5460 showlinktype (getlink opaque m);
5461 state.mode <- LinkNav (Ltexact (l.pageno, m));
5464 | None -> viewkeyboard key mask
5465 end;
5466 | _ -> viewkeyboard key mask
5468 if key = 0xff63
5469 then (
5470 state.mode <- View;
5471 G.postRedisplay "leave linknav"
5473 else
5474 match linknav with
5475 | Ltgendir _ -> viewkeyboard key mask
5476 | Ltexact exact -> doexact exact
5479 let keyboard key mask =
5480 if (key = 103 && Wsi.withctrl mask) && not (istextentry state.mode)
5481 then wcmd "interrupt"
5482 else state.uioh <- state.uioh#key key mask
5485 let birdseyekeyboard key mask
5486 ((oconf, leftx, pageno, hooverpageno, anchor) as beye) =
5487 let incr =
5488 match conf.columns with
5489 | Csingle _ -> 1
5490 | Cmulti ((c, _, _), _) -> c
5491 | Csplit _ -> failwith "bird's eye split mode"
5493 let pgh layout = List.fold_left (fun m l -> max l.pageh m) state.winh layout in
5494 match key with
5495 | 108 when Wsi.withctrl mask -> (* ctrl-l *)
5496 let y, h = getpageyh pageno in
5497 let top = (state.winh - h) / 2 in
5498 gotoy (max 0 (y - top))
5499 | 0xff0d (* enter *)
5500 | 0xff8d -> leavebirdseye beye false (* kp enter *)
5501 | 0xff1b -> leavebirdseye beye true (* escape *)
5502 | 0xff52 -> upbirdseye incr beye (* up *)
5503 | 0xff54 -> downbirdseye incr beye (* down *)
5504 | 0xff51 -> upbirdseye 1 beye (* left *)
5505 | 0xff53 -> downbirdseye 1 beye (* right *)
5507 | 0xff55 -> (* prior *)
5508 begin match state.layout with
5509 | l :: _ ->
5510 if l.pagey != 0
5511 then (
5512 state.mode <- Birdseye (
5513 oconf, leftx, l.pageno, hooverpageno, anchor
5515 gotopage1 l.pageno 0;
5517 else (
5518 let layout = layout (state.y-state.winh) (pgh state.layout) in
5519 match layout with
5520 | [] -> gotoy (clamp (-state.winh))
5521 | l :: _ ->
5522 state.mode <- Birdseye (
5523 oconf, leftx, l.pageno, hooverpageno, anchor
5525 gotopage1 l.pageno 0
5528 | [] -> gotoy (clamp (-state.winh))
5529 end;
5531 | 0xff56 -> (* next *)
5532 begin match List.rev state.layout with
5533 | l :: _ ->
5534 let layout = layout (state.y + (pgh state.layout)) state.winh in
5535 begin match layout with
5536 | [] ->
5537 let incr = l.pageh - l.pagevh in
5538 if incr = 0
5539 then (
5540 state.mode <-
5541 Birdseye (
5542 oconf, leftx, state.pagecount - 1, hooverpageno, anchor
5544 G.postRedisplay "birdseye pagedown";
5546 else gotoy (clamp (incr + conf.interpagespace*2));
5548 | l :: _ ->
5549 state.mode <-
5550 Birdseye (oconf, leftx, l.pageno, hooverpageno, anchor);
5551 gotopage1 l.pageno 0;
5554 | [] -> gotoy (clamp state.winh)
5555 end;
5557 | 0xff50 -> (* home *)
5558 state.mode <- Birdseye (oconf, leftx, 0, hooverpageno, anchor);
5559 gotopage1 0 0
5561 | 0xff57 -> (* end *)
5562 let pageno = state.pagecount - 1 in
5563 state.mode <- Birdseye (oconf, leftx, pageno, hooverpageno, anchor);
5564 if not (pagevisible state.layout pageno)
5565 then
5566 let h =
5567 match List.rev state.pdims with
5568 | [] -> state.winh
5569 | (_, _, h, _) :: _ -> h
5571 gotoy (max 0 (getpagey pageno - (state.winh - h - conf.interpagespace)))
5572 else G.postRedisplay "birdseye end";
5573 | _ -> viewkeyboard key mask
5576 let drawpage l linkindexbase =
5577 let color =
5578 match state.mode with
5579 | Textentry _ -> scalecolor 0.4
5580 | LinkNav _
5581 | View -> scalecolor 1.0
5582 | Birdseye (_, _, pageno, hooverpageno, _) ->
5583 if l.pageno = hooverpageno
5584 then scalecolor 0.9
5585 else (
5586 if l.pageno = pageno
5587 then scalecolor 1.0
5588 else scalecolor 0.8
5591 drawtiles l color;
5592 begin match getopaque l.pageno with
5593 | Some opaque ->
5594 if tileready l l.pagex l.pagey
5595 then
5596 let x = l.pagedispx - l.pagex
5597 and y = l.pagedispy - l.pagey in
5598 let hlmask =
5599 match conf.columns with
5600 | Csingle _ | Cmulti _ ->
5601 (if conf.hlinks then 1 else 0)
5602 + (if state.glinks
5603 && not (isbirdseye state.mode) then 2 else 0)
5604 | _ -> 0
5606 let s =
5607 match state.mode with
5608 | Textentry ((_, s, _, _, _, _), _) when state.glinks -> s
5609 | _ -> ""
5611 postprocess opaque hlmask x y (linkindexbase, s, conf.hfsize);
5612 else 0
5614 | _ -> 0
5615 end;
5618 let scrollindicator () =
5619 let sbw, ph, sh = state.uioh#scrollph in
5620 let sbh, pw, sw = state.uioh#scrollpw in
5622 GlDraw.color (0.64, 0.64, 0.64);
5623 GlDraw.rect
5624 (float (state.winw - sbw), 0.)
5625 (float state.winw, float state.winh)
5627 GlDraw.rect
5628 (0., float (state.winh - sbh))
5629 (float (state.winw - state.scrollw - 1), float state.winh)
5631 GlDraw.color (0.0, 0.0, 0.0);
5633 GlDraw.rect
5634 (float (state.winw - sbw), ph)
5635 (float state.winw, ph +. sh)
5637 GlDraw.rect
5638 (pw, float (state.winh - sbh))
5639 (pw +. sw, float state.winh)
5643 let showsel () =
5644 match state.mstate with
5645 | Mnone | Mscrolly | Mscrollx | Mpan _ | Mzoom _ | Mzoomrect _ ->
5648 | Msel ((x0, y0), (x1, y1)) ->
5649 let rec loop = function
5650 | l :: ls ->
5651 if ((y0 >= l.pagedispy && y0 <= (l.pagedispy + l.pagevh))
5652 || ((y1 >= l.pagedispy && y1 <= (l.pagedispy + l.pagevh))))
5653 && ((x0 >= l.pagedispx && x0 <= (l.pagedispx + l.pagevw))
5654 || ((x1 >= l.pagedispx && x1 <= (l.pagedispx + l.pagevw))))
5655 then
5656 match getopaque l.pageno with
5657 | Some opaque ->
5658 let x0, y0 = pagetranslatepoint l x0 y0 in
5659 let x1, y1 = pagetranslatepoint l x1 y1 in
5660 seltext opaque (x0, y0, x1, y1);
5661 | _ -> ()
5662 else loop ls
5663 | [] -> ()
5665 loop state.layout
5668 let showrects rects =
5669 Gl.enable `blend;
5670 GlDraw.color (0.0, 0.0, 1.0) ~alpha:0.5;
5671 GlDraw.polygon_mode `both `fill;
5672 GlFunc.blend_func `src_alpha `one_minus_src_alpha;
5673 List.iter
5674 (fun (pageno, c, (x0, y0, x1, y1, x2, y2, x3, y3)) ->
5675 List.iter (fun l ->
5676 if l.pageno = pageno
5677 then (
5678 let dx = float (l.pagedispx - l.pagex) in
5679 let dy = float (l.pagedispy - l.pagey) in
5680 GlDraw.color (0.0, 0.0, 1.0 /. float c) ~alpha:0.5;
5681 GlDraw.begins `quads;
5683 GlDraw.vertex2 (x0+.dx, y0+.dy);
5684 GlDraw.vertex2 (x1+.dx, y1+.dy);
5685 GlDraw.vertex2 (x2+.dx, y2+.dy);
5686 GlDraw.vertex2 (x3+.dx, y3+.dy);
5688 GlDraw.ends ();
5690 ) state.layout
5691 ) rects
5693 Gl.disable `blend;
5696 let display () =
5697 GlClear.color (scalecolor2 conf.bgcolor);
5698 GlClear.clear [`color];
5699 let rec loop linkindexbase = function
5700 | l :: rest ->
5701 let linkindexbase = linkindexbase + drawpage l linkindexbase in
5702 loop linkindexbase rest
5703 | [] -> ()
5705 loop 0 state.layout;
5706 let rects =
5707 match state.mode with
5708 | LinkNav (Ltexact (pageno, linkno)) ->
5709 begin match getopaque pageno with
5710 | Some opaque ->
5711 let x0, y0, x1, y1 = getlinkrect opaque linkno in
5712 (pageno, 5, (
5713 float x0, float y0,
5714 float x1, float y0,
5715 float x1, float y1,
5716 float x0, float y1)
5717 ) :: state.rects
5718 | None -> state.rects
5720 | _ -> state.rects
5722 showrects rects;
5723 showsel ();
5724 state.uioh#display;
5725 begin match state.mstate with
5726 | Mzoomrect ((x0, y0), (x1, y1)) ->
5727 Gl.enable `blend;
5728 GlDraw.color (0.3, 0.3, 0.3) ~alpha:0.5;
5729 GlFunc.blend_func `src_alpha `one_minus_src_alpha;
5730 GlDraw.rect (float x0, float y0)
5731 (float x1, float y1);
5732 Gl.disable `blend;
5733 | _ -> ()
5734 end;
5735 enttext ();
5736 scrollindicator ();
5737 Wsi.swapb ();
5740 let zoomrect x y x1 y1 =
5741 let x0 = min x x1
5742 and x1 = max x x1
5743 and y0 = min y y1 in
5744 gotoy (state.y + y0);
5745 state.anchor <- getanchor ();
5746 let zoom = (float state.winw *. conf.zoom) /. float (x1 - x0) in
5747 let margin =
5748 if state.w < state.winw - state.scrollw
5749 then (state.winw - state.scrollw - state.w) / 2
5750 else 0
5752 state.x <- (state.x + margin) - x0;
5753 setzoom zoom;
5754 Wsi.setcursor Wsi.CURSOR_INHERIT;
5755 state.mstate <- Mnone;
5758 let scrollx x =
5759 let winw = state.winw - state.scrollw - 1 in
5760 let s = float x /. float winw in
5761 let destx = truncate (float (state.w + winw) *. s) in
5762 state.x <- winw - destx;
5763 gotoy_and_clear_text state.y;
5764 state.mstate <- Mscrollx;
5767 let scrolly y =
5768 let s = float y /. float state.winh in
5769 let desty = truncate (float (state.maxy - state.winh) *. s) in
5770 gotoy_and_clear_text desty;
5771 state.mstate <- Mscrolly;
5774 let viewmouse button down x y mask =
5775 match button with
5776 | n when (n == 4 || n == 5) && not down ->
5777 if Wsi.withctrl mask
5778 then (
5779 match state.mstate with
5780 | Mzoom (oldn, i) ->
5781 if oldn = n
5782 then (
5783 if i = 2
5784 then
5785 let incr =
5786 match n with
5787 | 5 ->
5788 if conf.zoom +. 0.01 > 0.1 then 0.1 else 0.01
5789 | _ ->
5790 if conf.zoom -. 0.1 < 0.1 then -0.01 else -0.1
5792 let zoom = conf.zoom -. incr in
5793 setzoom zoom;
5794 state.mstate <- Mzoom (n, 0);
5795 else
5796 state.mstate <- Mzoom (n, i+1);
5798 else state.mstate <- Mzoom (n, 0)
5800 | _ -> state.mstate <- Mzoom (n, 0)
5802 else (
5803 match state.autoscroll with
5804 | Some step -> setautoscrollspeed step (n=4)
5805 | None ->
5806 if conf.wheelbypage
5807 then (
5808 if n = 4
5809 then prevpage ()
5810 else nextpage ()
5812 else
5813 let incr =
5814 if n = 4
5815 then -conf.scrollstep
5816 else conf.scrollstep
5818 let incr = incr * 2 in
5819 let y = clamp incr in
5820 gotoy_and_clear_text y
5823 | n when (n = 6 || n = 7) && not down && canpan () ->
5824 state.x <- state.x + (if n = 7 then -2 else 2) * conf.hscrollstep;
5825 gotoy_and_clear_text state.y
5827 | 1 when Wsi.withshift mask ->
5828 state.mstate <- Mnone;
5829 if not down then (
5830 match unproject x y with
5831 | Some (pageno, ux, uy) ->
5832 let cmd = Printf.sprintf
5833 "%s %s %d %d %d"
5834 conf.stcmd state.path pageno ux uy
5836 popen cmd []
5837 | None -> ()
5840 | 1 when Wsi.withctrl mask ->
5841 if down
5842 then (
5843 Wsi.setcursor Wsi.CURSOR_CROSSHAIR;
5844 state.mstate <- Mpan (x, y)
5846 else
5847 state.mstate <- Mnone
5849 | 3 ->
5850 if down
5851 then (
5852 Wsi.setcursor Wsi.CURSOR_CYCLE;
5853 let p = (x, y) in
5854 state.mstate <- Mzoomrect (p, p)
5856 else (
5857 match state.mstate with
5858 | Mzoomrect ((x0, y0), _) ->
5859 if abs (x-x0) > 10 && abs (y - y0) > 10
5860 then zoomrect x0 y0 x y
5861 else (
5862 state.mstate <- Mnone;
5863 Wsi.setcursor Wsi.CURSOR_INHERIT;
5864 G.postRedisplay "kill accidental zoom rect";
5866 | _ ->
5867 Wsi.setcursor Wsi.CURSOR_INHERIT;
5868 state.mstate <- Mnone
5871 | 1 when x > state.winw - state.scrollw ->
5872 if down
5873 then
5874 let _, position, sh = state.uioh#scrollph in
5875 if y > truncate position && y < truncate (position +. sh)
5876 then state.mstate <- Mscrolly
5877 else scrolly y
5878 else
5879 state.mstate <- Mnone
5881 | 1 when y > state.winh - state.hscrollh ->
5882 if down
5883 then
5884 let _, position, sw = state.uioh#scrollpw in
5885 if x > truncate position && x < truncate (position +. sw)
5886 then state.mstate <- Mscrollx
5887 else scrollx x
5888 else
5889 state.mstate <- Mnone
5891 | 1 ->
5892 let dest = if down then getunder x y else Unone in
5893 begin match dest with
5894 | Ulinkgoto _
5895 | Ulinkuri _
5896 | Uremote _
5897 | Uunexpected _ | Ulaunch _ | Unamed _ ->
5898 gotounder dest
5900 | Unone when down ->
5901 Wsi.setcursor Wsi.CURSOR_CROSSHAIR;
5902 state.mstate <- Mpan (x, y);
5904 | Unone | Utext _ ->
5905 if down
5906 then (
5907 if conf.angle mod 360 = 0
5908 then (
5909 state.mstate <- Msel ((x, y), (x, y));
5910 G.postRedisplay "mouse select";
5913 else (
5914 match state.mstate with
5915 | Mnone -> ()
5917 | Mzoom _ | Mscrollx | Mscrolly ->
5918 state.mstate <- Mnone
5920 | Mzoomrect ((x0, y0), _) ->
5921 zoomrect x0 y0 x y
5923 | Mpan _ ->
5924 Wsi.setcursor Wsi.CURSOR_INHERIT;
5925 state.mstate <- Mnone
5927 | Msel ((x0, y0), (x1, y1)) ->
5928 let rec loop = function
5929 | [] -> ()
5930 | l :: rest ->
5931 let inside =
5932 let a0 = l.pagedispy in
5933 let a1 = a0 + l.pagevh in
5934 let b0 = l.pagedispx in
5935 let b1 = b0 + l.pagevw in
5936 ((y0 >= a0 && y0 <= a1) || (y1 >= a0 && y1 <= a1))
5937 && ((x0 >= b0 && x0 <= b1) || (x1 >= b0 && x1 <= b1))
5939 if inside
5940 then
5941 match getopaque l.pageno with
5942 | Some opaque ->
5943 begin
5944 match Ne.pipe () with
5945 | Ne.Exn exn ->
5946 showtext '!'
5947 (Printf.sprintf
5948 "can not create sel pipe: %s"
5949 (exntos exn));
5950 | Ne.Res (r, w) ->
5951 let doclose what fd =
5952 Ne.clo fd (fun msg ->
5953 dolog "%s close failed: %s" what msg)
5956 popen conf.selcmd [r, 0; w, -1];
5957 copysel w opaque;
5958 doclose "pipe/r" r;
5959 G.postRedisplay "copysel";
5960 with exn ->
5961 dolog "can not execute %S: %s"
5962 conf.selcmd (exntos exn);
5963 doclose "pipe/r" r;
5964 doclose "pipe/w" w;
5966 | None -> ()
5967 else loop rest
5969 loop state.layout;
5970 Wsi.setcursor Wsi.CURSOR_INHERIT;
5971 state.mstate <- Mnone;
5975 | _ -> ()
5978 let birdseyemouse button down x y mask
5979 (conf, leftx, _, hooverpageno, anchor) =
5980 match button with
5981 | 1 when down ->
5982 let rec loop = function
5983 | [] -> ()
5984 | l :: rest ->
5985 if y > l.pagedispy && y < l.pagedispy + l.pagevh
5986 && x > l.pagedispx && x < l.pagedispx + l.pagevw
5987 then (
5988 leavebirdseye (conf, leftx, l.pageno, hooverpageno, anchor) false;
5990 else loop rest
5992 loop state.layout
5993 | 3 -> ()
5994 | _ -> viewmouse button down x y mask
5997 let mouse button down x y mask =
5998 state.uioh <- state.uioh#button button down x y mask;
6001 let motion ~x ~y =
6002 state.uioh <- state.uioh#motion x y
6005 let pmotion ~x ~y =
6006 state.uioh <- state.uioh#pmotion x y;
6009 let uioh = object
6010 method display = ()
6012 method key key mask =
6013 begin match state.mode with
6014 | Textentry textentry -> textentrykeyboard key mask textentry
6015 | Birdseye birdseye -> birdseyekeyboard key mask birdseye
6016 | View -> viewkeyboard key mask
6017 | LinkNav linknav -> linknavkeyboard key mask linknav
6018 end;
6019 state.uioh
6021 method button button bstate x y mask =
6022 begin match state.mode with
6023 | LinkNav _
6024 | View -> viewmouse button bstate x y mask
6025 | Birdseye beye -> birdseyemouse button bstate x y mask beye
6026 | Textentry _ -> ()
6027 end;
6028 state.uioh
6030 method motion x y =
6031 begin match state.mode with
6032 | Textentry _ -> ()
6033 | View | Birdseye _ | LinkNav _ ->
6034 match state.mstate with
6035 | Mzoom _ | Mnone -> ()
6037 | Mpan (x0, y0) ->
6038 let dx = x - x0
6039 and dy = y0 - y in
6040 state.mstate <- Mpan (x, y);
6041 if canpan ()
6042 then state.x <- state.x + dx;
6043 let y = clamp dy in
6044 gotoy_and_clear_text y
6046 | Msel (a, _) ->
6047 state.mstate <- Msel (a, (x, y));
6048 G.postRedisplay "motion select";
6050 | Mscrolly ->
6051 let y = min state.winh (max 0 y) in
6052 scrolly y
6054 | Mscrollx ->
6055 let x = min state.winw (max 0 x) in
6056 scrollx x
6058 | Mzoomrect (p0, _) ->
6059 state.mstate <- Mzoomrect (p0, (x, y));
6060 G.postRedisplay "motion zoomrect";
6061 end;
6062 state.uioh
6064 method pmotion x y =
6065 begin match state.mode with
6066 | Birdseye (conf, leftx, pageno, hooverpageno, anchor) ->
6067 let rec loop = function
6068 | [] ->
6069 if hooverpageno != -1
6070 then (
6071 state.mode <- Birdseye (conf, leftx, pageno, -1, anchor);
6072 G.postRedisplay "pmotion birdseye no hoover";
6074 | l :: rest ->
6075 if y > l.pagedispy && y < l.pagedispy + l.pagevh
6076 && x > l.pagedispx && x < l.pagedispx + l.pagevw
6077 then (
6078 state.mode <- Birdseye (conf, leftx, pageno, l.pageno, anchor);
6079 G.postRedisplay "pmotion birdseye hoover";
6081 else loop rest
6083 loop state.layout
6085 | Textentry _ -> ()
6087 | LinkNav _
6088 | View ->
6089 match state.mstate with
6090 | Mnone -> updateunder x y
6091 | Mpan _ | Msel _ | Mzoom _ | Mscrolly | Mscrollx | Mzoomrect _ ->
6093 end;
6094 state.uioh
6096 method infochanged _ = ()
6098 method scrollph =
6099 let maxy = state.maxy - (if conf.maxhfit then state.winh else 0) in
6100 let p, h = scrollph state.y maxy in
6101 state.scrollw, p, h
6103 method scrollpw =
6104 let winw = state.winw - state.scrollw - 1 in
6105 let fwinw = float winw in
6106 let sw =
6107 let sw = fwinw /. float state.w in
6108 let sw = fwinw *. sw in
6109 max sw (float conf.scrollh)
6111 let position, sw =
6112 let f = state.w+winw in
6113 let r = float (winw-state.x) /. float f in
6114 let p = fwinw *. r in
6115 p-.sw/.2., sw
6117 let sw =
6118 if position +. sw > fwinw
6119 then fwinw -. position
6120 else sw
6122 state.hscrollh, position, sw
6124 method modehash =
6125 let modename =
6126 match state.mode with
6127 | LinkNav _ -> "links"
6128 | Textentry _ -> "textentry"
6129 | Birdseye _ -> "birdseye"
6130 | View -> "view"
6132 findkeyhash conf modename
6133 end;;
6135 module Config =
6136 struct
6137 open Parser
6139 let fontpath = ref "";;
6141 module KeyMap =
6142 Map.Make (struct type t = (int * int) let compare = compare end);;
6144 let unent s =
6145 let l = String.length s in
6146 let b = Buffer.create l in
6147 unent b s 0 l;
6148 Buffer.contents b;
6151 let home =
6152 try Sys.getenv "HOME"
6153 with exn ->
6154 prerr_endline
6155 ("Can not determine home directory location: " ^ exntos exn);
6159 let modifier_of_string = function
6160 | "alt" -> Wsi.altmask
6161 | "shift" -> Wsi.shiftmask
6162 | "ctrl" | "control" -> Wsi.ctrlmask
6163 | "meta" -> Wsi.metamask
6164 | _ -> 0
6167 let key_of_string =
6168 let r = Str.regexp "-" in
6169 fun s ->
6170 let elems = Str.full_split r s in
6171 let f n k m =
6172 let g s =
6173 let m1 = modifier_of_string s in
6174 if m1 = 0
6175 then (Wsi.namekey s, m)
6176 else (k, m lor m1)
6177 in function
6178 | Str.Delim s when n land 1 = 0 -> g s
6179 | Str.Text s -> g s
6180 | Str.Delim _ -> (k, m)
6182 let rec loop n k m = function
6183 | [] -> (k, m)
6184 | x :: xs ->
6185 let k, m = f n k m x in
6186 loop (n+1) k m xs
6188 loop 0 0 0 elems
6191 let keys_of_string =
6192 let r = Str.regexp "[ \t]" in
6193 fun s ->
6194 let elems = Str.split r s in
6195 List.map key_of_string elems
6198 let copykeyhashes c =
6199 List.map (fun (k, v) -> k, Hashtbl.copy v) c.keyhashes;
6202 let config_of c attrs =
6203 let apply c k v =
6205 match k with
6206 | "scroll-bar-width" -> { c with scrollbw = max 0 (int_of_string v) }
6207 | "scroll-handle-height" -> { c with scrollh = max 0 (int_of_string v) }
6208 | "case-insensitive-search" -> { c with icase = bool_of_string v }
6209 | "preload" -> { c with preload = bool_of_string v }
6210 | "page-bias" -> { c with pagebias = int_of_string v }
6211 | "scroll-step" -> { c with scrollstep = max 1 (int_of_string v) }
6212 | "horizontal-scroll-step" ->
6213 { c with hscrollstep = max (int_of_string v) 1 }
6214 | "auto-scroll-step" ->
6215 { c with autoscrollstep = max 0 (int_of_string v) }
6216 | "max-height-fit" -> { c with maxhfit = bool_of_string v }
6217 | "crop-hack" -> { c with crophack = bool_of_string v }
6218 | "throttle" ->
6219 let mw =
6220 match String.lowercase v with
6221 | "true" -> Some infinity
6222 | "false" -> None
6223 | f -> Some (float_of_string f)
6225 { c with maxwait = mw}
6226 | "highlight-links" -> { c with hlinks = bool_of_string v }
6227 | "under-cursor-info" -> { c with underinfo = bool_of_string v }
6228 | "vertical-margin" ->
6229 { c with interpagespace = max 0 (int_of_string v) }
6230 | "zoom" ->
6231 let zoom = float_of_string v /. 100. in
6232 let zoom = max zoom 0.0 in
6233 { c with zoom = zoom }
6234 | "presentation" -> { c with presentation = bool_of_string v }
6235 | "rotation-angle" -> { c with angle = int_of_string v }
6236 | "width" -> { c with cwinw = max 20 (int_of_string v) }
6237 | "height" -> { c with cwinh = max 20 (int_of_string v) }
6238 | "persistent-bookmarks" -> { c with savebmarks = bool_of_string v }
6239 | "proportional-display" -> { c with proportional = bool_of_string v }
6240 | "pixmap-cache-size" ->
6241 { c with memlimit = max 2 (int_of_string_with_suffix v) }
6242 | "tex-count" -> { c with texcount = max 1 (int_of_string v) }
6243 | "slice-height" -> { c with sliceheight = max 2 (int_of_string v) }
6244 | "thumbnail-width" -> { c with thumbw = max 2 (int_of_string v) }
6245 | "persistent-location" -> { c with jumpback = bool_of_string v }
6246 | "background-color" -> { c with bgcolor = color_of_string v }
6247 | "scrollbar-in-presentation" ->
6248 { c with scrollbarinpm = bool_of_string v }
6249 | "tile-width" -> { c with tilew = max 2 (int_of_string v) }
6250 | "tile-height" -> { c with tileh = max 2 (int_of_string v) }
6251 | "mupdf-store-size" ->
6252 { c with mustoresize = max 1024 (int_of_string_with_suffix v) }
6253 | "checkers" -> { c with checkers = bool_of_string v }
6254 | "aalevel" -> { c with aalevel = max 0 (int_of_string v) }
6255 | "trim-margins" -> { c with trimmargins = bool_of_string v }
6256 | "trim-fuzz" -> { c with trimfuzz = irect_of_string v }
6257 | "uri-launcher" -> { c with urilauncher = unent v }
6258 | "path-launcher" -> { c with pathlauncher = unent v }
6259 | "color-space" -> { c with colorspace = colorspace_of_string v }
6260 | "invert-colors" -> { c with invert = bool_of_string v }
6261 | "brightness" -> { c with colorscale = float_of_string v }
6262 | "redirectstderr" -> { c with redirectstderr = bool_of_string v }
6263 | "ghyllscroll" ->
6264 { c with ghyllscroll = Some (ghyllscroll_of_string v) }
6265 | "columns" ->
6266 let (n, _, _) as nab = multicolumns_of_string v in
6267 if n < 0
6268 then { c with columns = Csplit (-n, [||]) }
6269 else { c with columns = Cmulti (nab, [||]) }
6270 | "birds-eye-columns" ->
6271 { c with beyecolumns = Some (max (int_of_string v) 2) }
6272 | "selection-command" -> { c with selcmd = unent v }
6273 | "synctex-command" -> { c with stcmd = unent v }
6274 | "update-cursor" -> { c with updatecurs = bool_of_string v }
6275 | "hint-font-size" -> { c with hfsize = bound (int_of_string v) 5 100 }
6276 | "page-scroll-scale" -> { c with pgscale = float_of_string v }
6277 | "use-pbo" -> { c with usepbo = bool_of_string v }
6278 | "wheel-scrolls-pages" -> { c with wheelbypage = bool_of_string v }
6279 | _ -> c
6280 with exn ->
6281 prerr_endline ("Error processing attribute (`" ^
6282 k ^ "'=`" ^ v ^ "'): " ^ exntos exn);
6285 let rec fold c = function
6286 | [] -> c
6287 | (k, v) :: rest ->
6288 let c = apply c k v in
6289 fold c rest
6291 fold { c with keyhashes = copykeyhashes c } attrs;
6294 let fromstring f pos n v d =
6295 try f v
6296 with exn ->
6297 dolog "Error processing attribute (%S=%S) at %d\n%s"
6298 n v pos (exntos exn)
6303 let bookmark_of attrs =
6304 let rec fold title page rely visy = function
6305 | ("title", v) :: rest -> fold v page rely visy rest
6306 | ("page", v) :: rest -> fold title v rely visy rest
6307 | ("rely", v) :: rest -> fold title page v visy rest
6308 | ("visy", v) :: rest -> fold title page rely v rest
6309 | _ :: rest -> fold title page rely visy rest
6310 | [] -> title, page, rely, visy
6312 fold "invalid" "0" "0" "0" attrs
6315 let doc_of attrs =
6316 let rec fold path page rely pan visy = function
6317 | ("path", v) :: rest -> fold v page rely pan visy rest
6318 | ("page", v) :: rest -> fold path v rely pan visy rest
6319 | ("rely", v) :: rest -> fold path page v pan visy rest
6320 | ("pan", v) :: rest -> fold path page rely v visy rest
6321 | ("visy", v) :: rest -> fold path page rely pan v rest
6322 | _ :: rest -> fold path page rely pan visy rest
6323 | [] -> path, page, rely, pan, visy
6325 fold "" "0" "0" "0" "0" attrs
6328 let map_of attrs =
6329 let rec fold rs ls = function
6330 | ("out", v) :: rest -> fold v ls rest
6331 | ("in", v) :: rest -> fold rs v rest
6332 | _ :: rest -> fold ls rs rest
6333 | [] -> ls, rs
6335 fold "" "" attrs
6338 let setconf dst src =
6339 dst.scrollbw <- src.scrollbw;
6340 dst.scrollh <- src.scrollh;
6341 dst.icase <- src.icase;
6342 dst.preload <- src.preload;
6343 dst.pagebias <- src.pagebias;
6344 dst.verbose <- src.verbose;
6345 dst.scrollstep <- src.scrollstep;
6346 dst.maxhfit <- src.maxhfit;
6347 dst.crophack <- src.crophack;
6348 dst.autoscrollstep <- src.autoscrollstep;
6349 dst.maxwait <- src.maxwait;
6350 dst.hlinks <- src.hlinks;
6351 dst.underinfo <- src.underinfo;
6352 dst.interpagespace <- src.interpagespace;
6353 dst.zoom <- src.zoom;
6354 dst.presentation <- src.presentation;
6355 dst.angle <- src.angle;
6356 dst.cwinw <- src.cwinw;
6357 dst.cwinh <- src.cwinh;
6358 dst.savebmarks <- src.savebmarks;
6359 dst.memlimit <- src.memlimit;
6360 dst.proportional <- src.proportional;
6361 dst.texcount <- src.texcount;
6362 dst.sliceheight <- src.sliceheight;
6363 dst.thumbw <- src.thumbw;
6364 dst.jumpback <- src.jumpback;
6365 dst.bgcolor <- src.bgcolor;
6366 dst.scrollbarinpm <- src.scrollbarinpm;
6367 dst.tilew <- src.tilew;
6368 dst.tileh <- src.tileh;
6369 dst.mustoresize <- src.mustoresize;
6370 dst.checkers <- src.checkers;
6371 dst.aalevel <- src.aalevel;
6372 dst.trimmargins <- src.trimmargins;
6373 dst.trimfuzz <- src.trimfuzz;
6374 dst.urilauncher <- src.urilauncher;
6375 dst.colorspace <- src.colorspace;
6376 dst.invert <- src.invert;
6377 dst.colorscale <- src.colorscale;
6378 dst.redirectstderr <- src.redirectstderr;
6379 dst.ghyllscroll <- src.ghyllscroll;
6380 dst.columns <- src.columns;
6381 dst.beyecolumns <- src.beyecolumns;
6382 dst.selcmd <- src.selcmd;
6383 dst.updatecurs <- src.updatecurs;
6384 dst.pathlauncher <- src.pathlauncher;
6385 dst.keyhashes <- copykeyhashes src;
6386 dst.hfsize <- src.hfsize;
6387 dst.hscrollstep <- src.hscrollstep;
6388 dst.pgscale <- src.pgscale;
6389 dst.usepbo <- src.usepbo;
6390 dst.wheelbypage <- src.wheelbypage;
6391 dst.stcmd <- src.stcmd;
6394 let get s =
6395 let h = Hashtbl.create 10 in
6396 let dc = { defconf with angle = defconf.angle } in
6397 let rec toplevel v t spos _ =
6398 match t with
6399 | Vdata | Vcdata | Vend -> v
6400 | Vopen ("llppconfig", _, closed) ->
6401 if closed
6402 then v
6403 else { v with f = llppconfig }
6404 | Vopen _ ->
6405 error "unexpected subelement at top level" s spos
6406 | Vclose _ -> error "unexpected close at top level" s spos
6408 and llppconfig v t spos _ =
6409 match t with
6410 | Vdata | Vcdata -> v
6411 | Vend -> error "unexpected end of input in llppconfig" s spos
6412 | Vopen ("defaults", attrs, closed) ->
6413 let c = config_of dc attrs in
6414 setconf dc c;
6415 if closed
6416 then v
6417 else { v with f = defaults }
6419 | Vopen ("ui-font", attrs, closed) ->
6420 let rec getsize size = function
6421 | [] -> size
6422 | ("size", v) :: rest ->
6423 let size =
6424 fromstring int_of_string spos "size" v fstate.fontsize in
6425 getsize size rest
6426 | l -> getsize size l
6428 fstate.fontsize <- getsize fstate.fontsize attrs;
6429 if closed
6430 then v
6431 else { v with f = uifont (Buffer.create 10) }
6433 | Vopen ("doc", attrs, closed) ->
6434 let pathent, spage, srely, span, svisy = doc_of attrs in
6435 let path = unent pathent
6436 and pageno = fromstring int_of_string spos "page" spage 0
6437 and rely = fromstring float_of_string spos "rely" srely 0.0
6438 and pan = fromstring int_of_string spos "pan" span 0
6439 and visy = fromstring float_of_string spos "visy" svisy 0.0 in
6440 let c = config_of dc attrs in
6441 let anchor = (pageno, rely, visy) in
6442 if closed
6443 then (Hashtbl.add h path (c, [], pan, anchor); v)
6444 else { v with f = doc path pan anchor c [] }
6446 | Vopen _ ->
6447 error "unexpected subelement in llppconfig" s spos
6449 | Vclose "llppconfig" -> { v with f = toplevel }
6450 | Vclose _ -> error "unexpected close in llppconfig" s spos
6452 and defaults v t spos _ =
6453 match t with
6454 | Vdata | Vcdata -> v
6455 | Vend -> error "unexpected end of input in defaults" s spos
6456 | Vopen ("keymap", attrs, closed) ->
6457 let modename =
6458 try List.assoc "mode" attrs
6459 with Not_found -> "global" in
6460 if closed
6461 then v
6462 else
6463 let ret keymap =
6464 let h = findkeyhash dc modename in
6465 KeyMap.iter (Hashtbl.replace h) keymap;
6466 defaults
6468 { v with f = pkeymap ret KeyMap.empty }
6470 | Vopen (_, _, _) ->
6471 error "unexpected subelement in defaults" s spos
6473 | Vclose "defaults" ->
6474 { v with f = llppconfig }
6476 | Vclose _ -> error "unexpected close in defaults" s spos
6478 and uifont b v t spos epos =
6479 match t with
6480 | Vdata | Vcdata ->
6481 Buffer.add_substring b s spos (epos - spos);
6483 | Vopen (_, _, _) ->
6484 error "unexpected subelement in ui-font" s spos
6485 | Vclose "ui-font" ->
6486 if String.length !fontpath = 0
6487 then fontpath := Buffer.contents b;
6488 { v with f = llppconfig }
6489 | Vclose _ -> error "unexpected close in ui-font" s spos
6490 | Vend -> error "unexpected end of input in ui-font" s spos
6492 and doc path pan anchor c bookmarks v t spos _ =
6493 match t with
6494 | Vdata | Vcdata -> v
6495 | Vend -> error "unexpected end of input in doc" s spos
6496 | Vopen ("bookmarks", _, closed) ->
6497 if closed
6498 then v
6499 else { v with f = pbookmarks path pan anchor c bookmarks }
6501 | Vopen ("keymap", attrs, closed) ->
6502 let modename =
6503 try List.assoc "mode" attrs
6504 with Not_found -> "global"
6506 if closed
6507 then v
6508 else
6509 let ret keymap =
6510 let h = findkeyhash c modename in
6511 KeyMap.iter (Hashtbl.replace h) keymap;
6512 doc path pan anchor c bookmarks
6514 { v with f = pkeymap ret KeyMap.empty }
6516 | Vopen (_, _, _) ->
6517 error "unexpected subelement in doc" s spos
6519 | Vclose "doc" ->
6520 Hashtbl.add h path (c, List.rev bookmarks, pan, anchor);
6521 { v with f = llppconfig }
6523 | Vclose _ -> error "unexpected close in doc" s spos
6525 and pkeymap ret keymap v t spos _ =
6526 match t with
6527 | Vdata | Vcdata -> v
6528 | Vend -> error "unexpected end of input in keymap" s spos
6529 | Vopen ("map", attrs, closed) ->
6530 let r, l = map_of attrs in
6531 let kss = fromstring keys_of_string spos "in" r [] in
6532 let lss = fromstring keys_of_string spos "out" l [] in
6533 let keymap =
6534 match kss with
6535 | [] -> keymap
6536 | ks :: [] -> KeyMap.add ks (KMinsrl lss) keymap
6537 | ks :: rest -> KeyMap.add ks (KMmulti (rest, lss)) keymap
6539 if closed
6540 then { v with f = pkeymap ret keymap }
6541 else
6542 let f () = v in
6543 { v with f = skip "map" f }
6545 | Vopen _ ->
6546 error "unexpected subelement in keymap" s spos
6548 | Vclose "keymap" ->
6549 { v with f = ret keymap }
6551 | Vclose _ -> error "unexpected close in keymap" s spos
6553 and pbookmarks path pan anchor c bookmarks v t spos _ =
6554 match t with
6555 | Vdata | Vcdata -> v
6556 | Vend -> error "unexpected end of input in bookmarks" s spos
6557 | Vopen ("item", attrs, closed) ->
6558 let titleent, spage, srely, svisy = bookmark_of attrs in
6559 let page = fromstring int_of_string spos "page" spage 0
6560 and rely = fromstring float_of_string spos "rely" srely 0.0
6561 and visy = fromstring float_of_string spos "visy" svisy 0.0 in
6562 let bookmarks =
6563 (unent titleent, 0, (page, rely, visy)) :: bookmarks
6565 if closed
6566 then { v with f = pbookmarks path pan anchor c bookmarks }
6567 else
6568 let f () = v in
6569 { v with f = skip "item" f }
6571 | Vopen _ ->
6572 error "unexpected subelement in bookmarks" s spos
6574 | Vclose "bookmarks" ->
6575 { v with f = doc path pan anchor c bookmarks }
6577 | Vclose _ -> error "unexpected close in bookmarks" s spos
6579 and skip tag f v t spos _ =
6580 match t with
6581 | Vdata | Vcdata -> v
6582 | Vend ->
6583 error ("unexpected end of input in skipped " ^ tag) s spos
6584 | Vopen (tag', _, closed) ->
6585 if closed
6586 then v
6587 else
6588 let f' () = { v with f = skip tag f } in
6589 { v with f = skip tag' f' }
6590 | Vclose ctag ->
6591 if tag = ctag
6592 then f ()
6593 else error ("unexpected close in skipped " ^ tag) s spos
6596 parse { f = toplevel; accu = () } s;
6597 h, dc;
6600 let do_load f ic =
6602 let len = in_channel_length ic in
6603 let s = String.create len in
6604 really_input ic s 0 len;
6605 f s;
6606 with
6607 | Parse_error (msg, s, pos) ->
6608 let subs = subs s pos in
6609 let s = Printf.sprintf "%s: at %d [..%s..]" msg pos subs in
6610 failwith ("parse error: " ^ s)
6612 | exn ->
6613 failwith ("config load error: " ^ exntos exn)
6616 let defconfpath =
6617 let dir =
6619 let dir = Filename.concat home ".config" in
6620 if Sys.is_directory dir then dir else home
6621 with _ -> home
6623 Filename.concat dir "llpp.conf"
6626 let confpath = ref defconfpath;;
6628 let load1 f =
6629 if Sys.file_exists !confpath
6630 then
6631 match
6632 (try Some (open_in_bin !confpath)
6633 with exn ->
6634 prerr_endline
6635 ("Error opening configuation file `" ^ !confpath ^ "': " ^
6636 exntos exn);
6637 None
6639 with
6640 | Some ic ->
6641 let success =
6643 f (do_load get ic)
6644 with exn ->
6645 prerr_endline
6646 ("Error loading configuation from `" ^ !confpath ^ "': " ^
6647 exntos exn);
6648 false
6650 close_in ic;
6651 success
6653 | None -> false
6654 else
6655 f (Hashtbl.create 0, defconf)
6658 let load () =
6659 let f (h, dc) =
6660 let pc, pb, px, pa =
6662 Hashtbl.find h (Filename.basename state.path)
6663 with Not_found -> dc, [], 0, emptyanchor
6665 setconf defconf dc;
6666 setconf conf pc;
6667 state.bookmarks <- pb;
6668 state.x <- px;
6669 state.scrollw <- conf.scrollbw;
6670 if conf.jumpback
6671 then state.anchor <- pa;
6672 cbput state.hists.nav pa;
6673 true
6675 load1 f
6678 let add_attrs bb always dc c =
6679 let ob s a b =
6680 if always || a != b
6681 then Printf.bprintf bb "\n %s='%b'" s a
6682 and oi s a b =
6683 if always || a != b
6684 then Printf.bprintf bb "\n %s='%d'" s a
6685 and oI s a b =
6686 if always || a != b
6687 then Printf.bprintf bb "\n %s='%s'" s (string_with_suffix_of_int a)
6688 and oz s a b =
6689 if always || a <> b
6690 then Printf.bprintf bb "\n %s='%g'" s (a*.100.)
6691 and oF s a b =
6692 if always || a <> b
6693 then Printf.bprintf bb "\n %s='%f'" s a
6694 and oc s a b =
6695 if always || a <> b
6696 then
6697 Printf.bprintf bb "\n %s='%s'" s (color_to_string a)
6698 and oC s a b =
6699 if always || a <> b
6700 then
6701 Printf.bprintf bb "\n %s='%s'" s (colorspace_to_string a)
6702 and oR s a b =
6703 if always || a <> b
6704 then
6705 Printf.bprintf bb "\n %s='%s'" s (irect_to_string a)
6706 and os s a b =
6707 if always || a <> b
6708 then
6709 Printf.bprintf bb "\n %s='%s'" s (enent a 0 (String.length a))
6710 and og s a b =
6711 if always || a <> b
6712 then
6713 match a with
6714 | None -> ()
6715 | Some (_N, _A, _B) ->
6716 Printf.bprintf bb "\n %s='%u,%u,%u'" s _N _A _B
6717 and oW s a b =
6718 if always || a <> b
6719 then
6720 let v =
6721 match a with
6722 | None -> "false"
6723 | Some f ->
6724 if f = infinity
6725 then "true"
6726 else string_of_float f
6728 Printf.bprintf bb "\n %s='%s'" s v
6729 and oco s a b =
6730 if always || a <> b
6731 then
6732 match a with
6733 | Cmulti ((n, a, b), _) when n > 1 ->
6734 Printf.bprintf bb "\n %s='%d,%d,%d'" s n a b
6735 | Csplit (n, _) when n > 1 ->
6736 Printf.bprintf bb "\n %s='%d'" s ~-n
6737 | _ -> ()
6738 and obeco s a b =
6739 if always || a <> b
6740 then
6741 match a with
6742 | Some c when c > 1 -> Printf.bprintf bb "\n %s='%d'" s c
6743 | _ -> ()
6745 oi "width" c.cwinw dc.cwinw;
6746 oi "height" c.cwinh dc.cwinh;
6747 oi "scroll-bar-width" c.scrollbw dc.scrollbw;
6748 oi "scroll-handle-height" c.scrollh dc.scrollh;
6749 ob "case-insensitive-search" c.icase dc.icase;
6750 ob "preload" c.preload dc.preload;
6751 oi "page-bias" c.pagebias dc.pagebias;
6752 oi "scroll-step" c.scrollstep dc.scrollstep;
6753 oi "auto-scroll-step" c.autoscrollstep dc.autoscrollstep;
6754 ob "max-height-fit" c.maxhfit dc.maxhfit;
6755 ob "crop-hack" c.crophack dc.crophack;
6756 oW "throttle" c.maxwait dc.maxwait;
6757 ob "highlight-links" c.hlinks dc.hlinks;
6758 ob "under-cursor-info" c.underinfo dc.underinfo;
6759 oi "vertical-margin" c.interpagespace dc.interpagespace;
6760 oz "zoom" c.zoom dc.zoom;
6761 ob "presentation" c.presentation dc.presentation;
6762 oi "rotation-angle" c.angle dc.angle;
6763 ob "persistent-bookmarks" c.savebmarks dc.savebmarks;
6764 ob "proportional-display" c.proportional dc.proportional;
6765 oI "pixmap-cache-size" c.memlimit dc.memlimit;
6766 oi "tex-count" c.texcount dc.texcount;
6767 oi "slice-height" c.sliceheight dc.sliceheight;
6768 oi "thumbnail-width" c.thumbw dc.thumbw;
6769 ob "persistent-location" c.jumpback dc.jumpback;
6770 oc "background-color" c.bgcolor dc.bgcolor;
6771 ob "scrollbar-in-presentation" c.scrollbarinpm dc.scrollbarinpm;
6772 oi "tile-width" c.tilew dc.tilew;
6773 oi "tile-height" c.tileh dc.tileh;
6774 oI "mupdf-store-size" c.mustoresize dc.mustoresize;
6775 ob "checkers" c.checkers dc.checkers;
6776 oi "aalevel" c.aalevel dc.aalevel;
6777 ob "trim-margins" c.trimmargins dc.trimmargins;
6778 oR "trim-fuzz" c.trimfuzz dc.trimfuzz;
6779 os "uri-launcher" c.urilauncher dc.urilauncher;
6780 os "path-launcher" c.pathlauncher dc.pathlauncher;
6781 oC "color-space" c.colorspace dc.colorspace;
6782 ob "invert-colors" c.invert dc.invert;
6783 oF "brightness" c.colorscale dc.colorscale;
6784 ob "redirectstderr" c.redirectstderr dc.redirectstderr;
6785 og "ghyllscroll" c.ghyllscroll dc.ghyllscroll;
6786 oco "columns" c.columns dc.columns;
6787 obeco "birds-eye-columns" c.beyecolumns dc.beyecolumns;
6788 os "selection-command" c.selcmd dc.selcmd;
6789 os "synctex-command" c.stcmd dc.stcmd;
6790 ob "update-cursor" c.updatecurs dc.updatecurs;
6791 oi "hint-font-size" c.hfsize dc.hfsize;
6792 oi "horizontal-scroll-step" c.hscrollstep dc.hscrollstep;
6793 oF "page-scroll-scale" c.pgscale dc.pgscale;
6794 ob "use-pbo" c.usepbo dc.usepbo;
6795 ob "wheel-scrolls-pages" c.wheelbypage dc.wheelbypage;
6798 let keymapsbuf always dc c =
6799 let bb = Buffer.create 16 in
6800 let rec loop = function
6801 | [] -> ()
6802 | (modename, h) :: rest ->
6803 let dh = findkeyhash dc modename in
6804 if always || h <> dh
6805 then (
6806 if Hashtbl.length h > 0
6807 then (
6808 if Buffer.length bb > 0
6809 then Buffer.add_char bb '\n';
6810 Printf.bprintf bb "<keymap mode='%s'>\n" modename;
6811 Hashtbl.iter (fun i o ->
6812 let isdifferent = always ||
6814 let dO = Hashtbl.find dh i in
6815 dO <> o
6816 with Not_found -> true
6818 if isdifferent
6819 then
6820 let addkm (k, m) =
6821 if Wsi.withctrl m then Buffer.add_string bb "ctrl-";
6822 if Wsi.withalt m then Buffer.add_string bb "alt-";
6823 if Wsi.withshift m then Buffer.add_string bb "shift-";
6824 if Wsi.withmeta m then Buffer.add_string bb "meta-";
6825 Buffer.add_string bb (Wsi.keyname k);
6827 let addkms l =
6828 let rec loop = function
6829 | [] -> ()
6830 | km :: [] -> addkm km
6831 | km :: rest -> addkm km; Buffer.add_char bb ' '; loop rest
6833 loop l
6835 Buffer.add_string bb "<map in='";
6836 addkm i;
6837 match o with
6838 | KMinsrt km ->
6839 Buffer.add_string bb "' out='";
6840 addkm km;
6841 Buffer.add_string bb "'/>\n"
6843 | KMinsrl kms ->
6844 Buffer.add_string bb "' out='";
6845 addkms kms;
6846 Buffer.add_string bb "'/>\n"
6848 | KMmulti (ins, kms) ->
6849 Buffer.add_char bb ' ';
6850 addkms ins;
6851 Buffer.add_string bb "' out='";
6852 addkms kms;
6853 Buffer.add_string bb "'/>\n"
6854 ) h;
6855 Buffer.add_string bb "</keymap>";
6858 loop rest
6860 loop c.keyhashes;
6864 let save () =
6865 let uifontsize = fstate.fontsize in
6866 let bb = Buffer.create 32768 in
6867 let w, h =
6868 List.fold_left
6869 (fun (w, h) ws ->
6870 match ws with
6871 | Wsi.Fullscreen -> (conf.cwinw, conf.cwinh)
6872 | Wsi.MaxVert -> (w, conf.cwinh)
6873 | Wsi.MaxHorz -> (conf.cwinw, h)
6875 (state.winw, state.winh) state.winstate
6877 conf.cwinw <- w;
6878 conf.cwinh <- h;
6879 let f (h, dc) =
6880 let dc = if conf.bedefault then conf else dc in
6881 Buffer.add_string bb "<llppconfig>\n";
6883 if String.length !fontpath > 0
6884 then
6885 Printf.bprintf bb "<ui-font size='%d'><![CDATA[%s]]></ui-font>\n"
6886 uifontsize
6887 !fontpath
6888 else (
6889 if uifontsize <> 14
6890 then
6891 Printf.bprintf bb "<ui-font size='%d'/>\n" uifontsize
6894 Buffer.add_string bb "<defaults ";
6895 add_attrs bb true dc dc;
6896 let kb = keymapsbuf true dc dc in
6897 if Buffer.length kb > 0
6898 then (
6899 Buffer.add_string bb ">\n";
6900 Buffer.add_buffer bb kb;
6901 Buffer.add_string bb "\n</defaults>\n";
6903 else Buffer.add_string bb "/>\n";
6905 let adddoc path pan anchor c bookmarks =
6906 if bookmarks == [] && c = dc && anchor = emptyanchor
6907 then ()
6908 else (
6909 Printf.bprintf bb "<doc path='%s'"
6910 (enent path 0 (String.length path));
6912 if anchor <> emptyanchor
6913 then (
6914 let n, rely, visy = anchor in
6915 Printf.bprintf bb " page='%d'" n;
6916 if rely > 1e-6
6917 then
6918 Printf.bprintf bb " rely='%f'" rely
6920 if abs_float visy > 1e-6
6921 then
6922 Printf.bprintf bb " visy='%f'" visy
6926 if pan != 0
6927 then Printf.bprintf bb " pan='%d'" pan;
6929 add_attrs bb false dc c;
6930 let kb = keymapsbuf false dc c in
6932 begin match bookmarks with
6933 | [] ->
6934 if Buffer.length kb > 0
6935 then (
6936 Buffer.add_string bb ">\n";
6937 Buffer.add_buffer bb kb;
6938 Buffer.add_string bb "\n</doc>\n";
6940 else Buffer.add_string bb "/>\n"
6941 | _ ->
6942 Buffer.add_string bb ">\n<bookmarks>\n";
6943 List.iter (fun (title, _level, (page, rely, visy)) ->
6944 Printf.bprintf bb
6945 "<item title='%s' page='%d'"
6946 (enent title 0 (String.length title))
6947 page
6949 if rely > 1e-6
6950 then
6951 Printf.bprintf bb " rely='%f'" rely
6953 if abs_float visy > 1e-6
6954 then
6955 Printf.bprintf bb " visy='%f'" visy
6957 Buffer.add_string bb "/>\n";
6958 ) bookmarks;
6959 Buffer.add_string bb "</bookmarks>";
6960 if Buffer.length kb > 0
6961 then (
6962 Buffer.add_string bb "\n";
6963 Buffer.add_buffer bb kb;
6965 Buffer.add_string bb "\n</doc>\n";
6966 end;
6970 let pan, conf =
6971 match state.mode with
6972 | Birdseye (c, pan, _, _, _) ->
6973 let beyecolumns =
6974 match conf.columns with
6975 | Cmulti ((c, _, _), _) -> Some c
6976 | Csingle _ -> None
6977 | Csplit _ -> None
6978 and columns =
6979 match c.columns with
6980 | Cmulti (c, _) -> Cmulti (c, [||])
6981 | Csingle _ -> Csingle [||]
6982 | Csplit _ -> failwith "quit from bird's eye while split"
6984 pan, { c with beyecolumns = beyecolumns; columns = columns }
6985 | _ -> state.x, conf
6987 let basename = Filename.basename state.path in
6988 adddoc basename pan (getanchor ())
6989 (let conf =
6990 let autoscrollstep =
6991 match state.autoscroll with
6992 | Some step -> step
6993 | None -> conf.autoscrollstep
6995 match state.mode with
6996 | Birdseye (bc, _, _, _, _) ->
6997 { conf with
6998 zoom = bc.zoom;
6999 presentation = bc.presentation;
7000 interpagespace = bc.interpagespace;
7001 maxwait = bc.maxwait;
7002 autoscrollstep = autoscrollstep }
7003 | _ -> { conf with autoscrollstep = autoscrollstep }
7004 in conf)
7005 (if conf.savebmarks then state.bookmarks else []);
7007 Hashtbl.iter (fun path (c, bookmarks, x, anchor) ->
7008 if basename <> path
7009 then adddoc path x anchor c bookmarks
7010 ) h;
7011 Buffer.add_string bb "</llppconfig>\n";
7012 true;
7014 if load1 f && Buffer.length bb > 0
7015 then
7017 let tmp = !confpath ^ ".tmp" in
7018 let oc = open_out_bin tmp in
7019 Buffer.output_buffer oc bb;
7020 close_out oc;
7021 Unix.rename tmp !confpath;
7022 with exn ->
7023 prerr_endline
7024 ("error while saving configuration: " ^ exntos exn)
7026 end;;
7028 let adderrmsg src msg =
7029 Buffer.add_string state.errmsgs msg;
7030 state.newerrmsgs <- true;
7031 G.postRedisplay src
7034 let adderrfmt src fmt =
7035 Format.kprintf (fun s -> adderrmsg src s) fmt;
7038 let ract cmds =
7039 let cl = splitatspace cmds in
7040 let scan s fmt f =
7041 try Scanf.sscanf s fmt f
7042 with exn ->
7043 adderrfmt "remote exec"
7044 "error processing '%S': %s\n" cmds (exntos exn)
7046 match cl with
7047 | "reload" :: [] -> reload ()
7048 | "goto" :: args :: [] ->
7049 scan args "%u %f %f"
7050 (fun pageno x y ->
7051 let cmd, _ = state.geomcmds in
7052 if String.length cmd = 0
7053 then gotopagexy pageno x y
7054 else
7055 let f prevf () =
7056 gotopagexy pageno x y;
7057 prevf ()
7059 state.reprf <- f state.reprf
7061 | "goto1" :: args :: [] -> scan args "%u %f" gotopage
7062 | "rect" :: args :: [] ->
7063 scan args "%u %u %f %f %f %f"
7064 (fun pageno color x0 y0 x1 y1 ->
7065 onpagerect pageno (fun w h ->
7066 let _,w1,h1,_ = getpagedim pageno in
7067 let sw = float w1 /. w
7068 and sh = float h1 /. h in
7069 let x0s = x0 *. sw
7070 and x1s = x1 *. sw
7071 and y0s = y0 *. sh
7072 and y1s = y1 *. sh in
7073 let rect = (x0s,y0s,x1s,y0s,x1s,y1s,x0s,y1s) in
7074 debugrect rect;
7075 state.rects <- (pageno, color, rect) :: state.rects;
7076 G.postRedisplay "rect";
7079 | "activatewin" :: [] -> Wsi.activatewin ()
7080 | "quit" :: [] -> raise Quit
7081 | _ ->
7082 adderrfmt "remote command"
7083 "error processing remote command: %S\n" cmds;
7086 let remote =
7087 let scratch = String.create 80 in
7088 let buf = Buffer.create 80 in
7089 fun fd ->
7090 let rec tempfr () =
7091 try Some (Unix.read fd scratch 0 80)
7092 with
7093 | Unix.Unix_error (Unix.EAGAIN, _, _) -> None
7094 | Unix.Unix_error (Unix.EINTR, _, _) -> tempfr ()
7095 | exn -> raise exn
7097 match tempfr () with
7098 | None -> Some fd
7099 | Some n ->
7100 if n = 0
7101 then (
7102 Unix.close fd;
7103 if Buffer.length buf > 0
7104 then (
7105 let s = Buffer.contents buf in
7106 Buffer.clear buf;
7107 ract s;
7109 None
7111 else
7112 let rec eat ppos =
7113 let nlpos =
7115 let pos = String.index_from scratch ppos '\n' in
7116 if pos >= n then -1 else pos
7117 with Not_found -> -1
7119 if nlpos >= 0
7120 then (
7121 Buffer.add_substring buf scratch ppos (nlpos-ppos);
7122 let s = Buffer.contents buf in
7123 Buffer.clear buf;
7124 ract s;
7125 eat (nlpos+1);
7127 else (
7128 Buffer.add_substring buf scratch ppos (n-ppos);
7129 Some fd
7131 in eat 0
7134 let remoteopen path =
7135 try Some (Unix.openfile path [Unix.O_NONBLOCK; Unix.O_RDONLY] 0o0)
7136 with exn ->
7137 adderrfmt "remoteopen" "error opening %S: %s" path (exntos exn);
7138 None
7141 let () =
7142 let trimcachepath = ref "" in
7143 let rcmdpath = ref "" in
7144 Arg.parse
7145 (Arg.align
7146 [("-p", Arg.String (fun s -> state.password <- s),
7147 "<password> Set password");
7149 ("-f", Arg.String (fun s -> Config.fontpath := s),
7150 "<path> Set path to the user interface font");
7152 ("-c", Arg.String (fun s -> Config.confpath := s),
7153 "<path> Set path to the configuration file");
7155 ("-tcf", Arg.String (fun s -> trimcachepath := s),
7156 "<path> Set path to the trim cache file");
7158 ("-dest", Arg.String (fun s -> state.nameddest <- s),
7159 "<named-destination> Set named destination");
7161 ("-wtmode", Arg.Set wtmode, " Operate in wt mode");
7163 ("-remote", Arg.String (fun s -> rcmdpath := s),
7164 "<path> Set path to the remote commands source");
7166 ("-v", Arg.Unit (fun () ->
7167 Printf.printf
7168 "%s\nconfiguration path: %s\n"
7169 (version ())
7170 Config.defconfpath
7172 exit 0), " Print version and exit");
7175 (fun s -> state.path <- s)
7176 ("Usage: " ^ Sys.argv.(0) ^ " [options] some.pdf\nOptions:")
7178 if String.length state.path = 0
7179 then (prerr_endline "file name missing"; exit 1);
7181 if not (Config.load ())
7182 then prerr_endline "failed to load configuration";
7184 let globalkeyhash = findkeyhash conf "global" in
7185 let wsfd, winw, winh = Wsi.init (object
7186 method expose =
7187 state.wthack <- false;
7188 if nogeomcmds state.geomcmds || platform == Posx
7189 then display ()
7190 else (
7191 GlClear.color (scalecolor2 conf.bgcolor);
7192 GlClear.clear [`color];
7194 method display = display ()
7195 method reshape w h = reshape w h
7196 method mouse b d x y m = mouse b d x y m
7197 method motion x y = state.mpos <- (x, y); motion x y
7198 method pmotion x y = state.mpos <- (x, y); pmotion x y
7199 method key k m =
7200 let mascm = m land (
7201 Wsi.altmask + Wsi.shiftmask + Wsi.ctrlmask + Wsi.metamask
7202 ) in
7203 match state.keystate with
7204 | KSnone ->
7205 let km = k, mascm in
7206 begin
7207 match
7208 let modehash = state.uioh#modehash in
7209 try Hashtbl.find modehash km
7210 with Not_found ->
7211 try Hashtbl.find globalkeyhash km
7212 with Not_found -> KMinsrt (k, m)
7213 with
7214 | KMinsrt (k, m) -> keyboard k m
7215 | KMinsrl l -> List.iter (fun (k, m) -> keyboard k m) l
7216 | KMmulti (l, r) -> state.keystate <- KSinto (l, r)
7218 | KSinto ((k', m') :: [], insrt) when k'=k && m' land mascm = m' ->
7219 List.iter (fun (k, m) -> keyboard k m) insrt;
7220 state.keystate <- KSnone
7221 | KSinto ((k', m') :: keys, insrt) when k'=k && m' land mascm = m' ->
7222 state.keystate <- KSinto (keys, insrt)
7223 | _ ->
7224 state.keystate <- KSnone
7226 method enter x y = state.mpos <- (x, y); pmotion x y
7227 method leave = state.mpos <- (-1, -1)
7228 method winstate wsl = state.winstate <- wsl
7229 method quit = raise Quit
7230 end) conf.cwinw conf.cwinh (platform = Posx) in
7232 state.wsfd <- wsfd;
7234 if not (
7235 List.exists GlMisc.check_extension
7236 [ "GL_ARB_texture_rectangle"
7237 ; "GL_EXT_texture_recangle"
7238 ; "GL_NV_texture_rectangle" ]
7240 then (prerr_endline "OpenGL does not suppport rectangular textures"; exit 1);
7242 let cr, sw =
7243 match Ne.pipe () with
7244 | Ne.Exn exn ->
7245 Printf.eprintf "pipe/crsw failed: %s" (exntos exn);
7246 exit 1
7247 | Ne.Res rw -> rw
7248 and sr, cw =
7249 match Ne.pipe () with
7250 | Ne.Exn exn ->
7251 Printf.eprintf "pipe/srcw failed: %s" (exntos exn);
7252 exit 1
7253 | Ne.Res rw -> rw
7256 cloexec cr;
7257 cloexec sw;
7258 cloexec sr;
7259 cloexec cw;
7261 setcheckers conf.checkers;
7262 redirectstderr ();
7264 init (cr, cw) (
7265 conf.angle, conf.proportional, (conf.trimmargins, conf.trimfuzz),
7266 conf.texcount, conf.sliceheight, conf.mustoresize, conf.colorspace,
7267 !Config.fontpath, !trimcachepath,
7268 GlMisc.check_extension "GL_ARB_pixel_buffer_object"
7270 state.sr <- sr;
7271 state.sw <- sw;
7272 state.text <- "Opening " ^ (mbtoutf8 state.path);
7273 reshape winw winh;
7274 opendoc state.path state.password;
7275 state.uioh <- uioh;
7277 Sys.set_signal Sys.sighup (Sys.Signal_handle (fun _ -> reload ()));
7278 let optrfd =
7279 ref (
7280 if String.length !rcmdpath > 0
7281 then remoteopen !rcmdpath
7282 else None
7286 let rec loop deadline =
7287 let r =
7288 match state.errfd with
7289 | None -> [state.sr; state.wsfd]
7290 | Some fd -> [state.sr; state.wsfd; fd]
7292 let r =
7293 match !optrfd with
7294 | None -> r
7295 | Some fd -> fd :: r
7297 if state.redisplay && not state.wthack
7298 then (
7299 state.redisplay <- false;
7300 display ();
7302 let timeout =
7303 let now = now () in
7304 if deadline > now
7305 then (
7306 if deadline = infinity
7307 then ~-.1.0
7308 else max 0.0 (deadline -. now)
7310 else 0.0
7312 let r, _, _ =
7313 try Unix.select r [] [] timeout
7314 with Unix.Unix_error (Unix.EINTR, _, _) -> [], [], []
7316 begin match r with
7317 | [] ->
7318 state.ghyll None;
7319 let newdeadline =
7320 if state.ghyll == noghyll
7321 then
7322 match state.autoscroll with
7323 | Some step when step != 0 ->
7324 let y = state.y + step in
7325 let y =
7326 if y < 0
7327 then state.maxy
7328 else if y >= state.maxy then 0 else y
7330 gotoy y;
7331 if state.mode = View
7332 then state.text <- "";
7333 deadline +. 0.01
7334 | _ -> infinity
7335 else deadline +. 0.01
7337 loop newdeadline
7339 | l ->
7340 let rec checkfds = function
7341 | [] -> ()
7342 | fd :: rest when fd = state.sr ->
7343 let cmd = readcmd state.sr in
7344 act cmd;
7345 checkfds rest
7347 | fd :: rest when fd = state.wsfd ->
7348 Wsi.readresp fd;
7349 checkfds rest
7351 | fd :: rest when Some fd = !optrfd ->
7352 begin match remote fd with
7353 | None -> optrfd := remoteopen !rcmdpath;
7354 | opt -> optrfd := opt
7355 end;
7356 checkfds rest
7358 | fd :: rest ->
7359 let s = String.create 80 in
7360 let n = tempfailureretry (Unix.read fd s 0) 80 in
7361 if conf.redirectstderr
7362 then (
7363 Buffer.add_substring state.errmsgs s 0 n;
7364 state.newerrmsgs <- true;
7365 state.redisplay <- true;
7367 else (
7368 prerr_string (String.sub s 0 n);
7369 flush stderr;
7371 checkfds rest
7373 checkfds l;
7374 let newdeadline =
7375 let deadline1 =
7376 if deadline = infinity
7377 then now () +. 0.01
7378 else deadline
7380 match state.autoscroll with
7381 | Some step when step != 0 -> deadline1
7382 | _ -> if state.ghyll == noghyll then infinity else deadline1
7384 loop newdeadline
7385 end;
7388 loop infinity;
7389 with Quit ->
7390 Config.save ();