Whoops (as expected/predicted)
[llpp.git] / main.ml
blob754fdec1107f4be659fc6f9337537c79afcc5ae0
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 mark =
17 | Mark_page
18 | Mark_block
19 | Mark_line
20 | Mark_word
23 type params = (angle * fitmodel * trimparams
24 * texcount * sliceheight * memsize
25 * colorspace * fontpath * trimcachepath
26 * haspbo)
27 and pageno = int
28 and width = int
29 and height = int
30 and leftx = int
31 and opaque = string
32 and recttype = int
33 and pixmapsize = int
34 and angle = int
35 and trimmargins = bool
36 and interpagespace = int
37 and texcount = int
38 and sliceheight = int
39 and gen = int
40 and top = float
41 and dtop = float
42 and fontpath = string
43 and trimcachepath = string
44 and memsize = int
45 and aalevel = int
46 and irect = (int * int * int * int)
47 and trimparams = (trimmargins * irect)
48 and colorspace = | Rgb | Bgr | Gray
49 and fitmodel = | FitWidth | FitProportional | FitPage
50 and haspbo = bool
53 type x = int
54 and y = int
55 and tilex = int
56 and tiley = int
57 and tileparams = (x * y * width * height * tilex * tiley)
60 type link =
61 | Lnotfound
62 | Lfound of int
63 and linkdir =
64 | LDfirst
65 | LDlast
66 | LDfirstvisible of (int * int * int)
67 | LDleft of int
68 | LDright of int
69 | LDdown of int
70 | LDup of int
73 type pagewithlinks =
74 | Pwlnotfound
75 | Pwl of int
78 type keymap =
79 | KMinsrt of key
80 | KMinsrl of key list
81 | KMmulti of key list * key list
82 and key = int * int
83 and keyhash = (key, keymap) Hashtbl.t
84 and keystate =
85 | KSnone
86 | KSinto of (key list * key list)
89 type platform = | Punknown | Plinux | Posx | Psun | Pfreebsd
90 | Pdragonflybsd | Popenbsd | Pnetbsd | Pcygwin;;
92 type pipe = (Unix.file_descr * Unix.file_descr);;
94 external init : pipe -> params -> unit = "ml_init";;
95 external seltext : string -> (int * int * int * int) -> unit = "ml_seltext";;
96 external copysel : Unix.file_descr -> opaque -> bool -> unit = "ml_copysel";;
97 external getpdimrect : int -> float array = "ml_getpdimrect";;
98 external whatsunder : string -> int -> int -> under = "ml_whatsunder";;
99 external markunder : string -> int -> int -> mark -> bool = "ml_markunder";;
100 external zoomforh : int -> int -> int -> int -> float = "ml_zoom_for_height";;
101 external drawstr : int -> int -> int -> string -> float = "ml_draw_string";;
102 external measurestr : int -> string -> float = "ml_measure_string";;
103 external postprocess :
104 opaque -> int -> int -> int -> (int * string * int) -> int
105 = "ml_postprocess";;
106 external pagebbox : opaque -> (int * int * int * int) = "ml_getpagebox";;
107 external platform : unit -> platform = "ml_platform";;
108 external setaalevel : int -> unit = "ml_setaalevel";;
109 external realloctexts : int -> bool = "ml_realloctexts";;
110 external findlink : opaque -> linkdir -> link = "ml_findlink";;
111 external getlink : opaque -> int -> under = "ml_getlink";;
112 external getlinkrect : opaque -> int -> irect = "ml_getlinkrect";;
113 external getlinkcount : opaque -> int = "ml_getlinkcount";;
114 external findpwl : int -> int -> pagewithlinks = "ml_find_page_with_links"
115 external popen : string -> (Unix.file_descr * int) list -> unit = "ml_popen";;
116 external getpbo : width -> height -> colorspace -> string = "ml_getpbo";;
117 external freepbo : string -> unit = "ml_freepbo";;
118 external unmappbo : string -> unit = "ml_unmappbo";;
119 external pbousable : unit -> bool = "ml_pbo_usable";;
120 external unproject : opaque -> int -> int -> (int * int) option
121 = "ml_unproject";;
122 external drawtile : tileparams -> opaque -> unit = "ml_drawtile";;
124 let platform_to_string = function
125 | Punknown -> "unknown"
126 | Plinux -> "Linux"
127 | Posx -> "OSX"
128 | Psun -> "Sun"
129 | Pfreebsd -> "FreeBSD"
130 | Pdragonflybsd -> "DragonflyBSD"
131 | Popenbsd -> "OpenBSD"
132 | Pnetbsd -> "NetBSD"
133 | Pcygwin -> "Cygwin"
136 let platform = platform ();;
138 let now = Unix.gettimeofday;;
140 let selfexec = ref "";;
142 let popen cmd fda =
143 if platform = Pcygwin
144 then (
145 let sh = "/bin/sh" in
146 let args = [|sh; "-c"; cmd|] in
147 let rec std si so se = function
148 | [] -> si, so, se
149 | (fd, 0) :: rest -> std fd so se rest
150 | (fd, -1) :: rest ->
151 Unix.set_close_on_exec fd;
152 std si so se rest
153 | (_, n) :: _ ->
154 failwith ("unexpected fdn in cygwin popen " ^ string_of_int n)
156 let si, so, se = std Unix.stdin Unix.stdout Unix.stderr fda in
157 ignore (Unix.create_process sh args si so se)
159 else popen cmd fda;
162 type mpos = int * int
163 and mstate =
164 | Msel of (mpos * mpos)
165 | Mpan of mpos
166 | Mscrolly | Mscrollx
167 | Mzoom of (int * int)
168 | Mzoomrect of (mpos * mpos)
169 | Mnone
172 type textentry = string * string * onhist option * onkey * ondone * cancelonempty
173 and onkey = string -> int -> te
174 and ondone = string -> unit
175 and histcancel = unit -> unit
176 and onhist = ((histcmd -> string) * histcancel)
177 and histcmd = HCnext | HCprev | HCfirst | HClast
178 and cancelonempty = bool
179 and te =
180 | TEstop
181 | TEdone of string
182 | TEcont of string
183 | TEswitch of textentry
186 type 'a circbuf =
187 { store : 'a array
188 ; mutable rc : int
189 ; mutable wc : int
190 ; mutable len : int
194 let bound v minv maxv =
195 max minv (min maxv v);
198 let cbnew n v =
199 { store = Array.create n v
200 ; rc = 0
201 ; wc = 0
202 ; len = 0
206 let cbcap b = Array.length b.store;;
208 let cbput b v =
209 let cap = cbcap b in
210 b.store.(b.wc) <- v;
211 b.wc <- (b.wc + 1) mod cap;
212 b.rc <- b.wc;
213 b.len <- min (b.len + 1) cap;
216 let cbempty b = b.len = 0;;
218 let cbgetg b circular dir =
219 if cbempty b
220 then b.store.(0)
221 else
222 let rc = b.rc + dir in
223 let rc =
224 if circular
225 then (
226 if rc = -1
227 then b.len-1
228 else (
229 if rc >= b.len
230 then 0
231 else rc
234 else bound rc 0 (b.len-1)
236 b.rc <- rc;
237 b.store.(rc);
240 let cbget b = cbgetg b false;;
241 let cbgetc b = cbgetg b true;;
243 let drawstring size x y s =
244 Gl.enable `blend;
245 Gl.enable `texture_2d;
246 GlFunc.blend_func `src_alpha `one_minus_src_alpha;
247 ignore (drawstr size x y s);
248 Gl.disable `blend;
249 Gl.disable `texture_2d;
252 let drawstring1 size x y s =
253 drawstr size x y s;
256 let drawstring2 size x y fmt =
257 Printf.kprintf (drawstring size (x+1) (y+size+1)) fmt
260 type page =
261 { pageno : int
262 ; pagedimno : int
263 ; pagew : int
264 ; pageh : int
265 ; pagex : int
266 ; pagey : int
267 ; pagevw : int
268 ; pagevh : int
269 ; pagedispx : int
270 ; pagedispy : int
271 ; pagecol : int
275 let debugl l =
276 dolog "l %d dim=%d {" l.pageno l.pagedimno;
277 dolog " WxH %dx%d" l.pagew l.pageh;
278 dolog " vWxH %dx%d" l.pagevw l.pagevh;
279 dolog " pagex,y %d,%d" l.pagex l.pagey;
280 dolog " dispx,y %d,%d" l.pagedispx l.pagedispy;
281 dolog " column %d" l.pagecol;
282 dolog "}";
285 let debugrect (x0, y0, x1, y1, x2, y2, x3, y3) =
286 dolog "rect {";
287 dolog " x0,y0=(% f, % f)" x0 y0;
288 dolog " x1,y1=(% f, % f)" x1 y1;
289 dolog " x2,y2=(% f, % f)" x2 y2;
290 dolog " x3,y3=(% f, % f)" x3 y3;
291 dolog "}";
294 type multicolumns = multicol * pagegeom
295 and singlecolumn = pagegeom
296 and splitcolumns = columncount * pagegeom
297 and pagegeom = ((pdimno * x * y * (pageno * width * height * leftx)) array)
298 and multicol = columncount * covercount * covercount
299 and pdimno = int
300 and columncount = int
301 and covercount = int;;
303 type scrollb = int;;
304 let scrollbvv = 1;;
305 let scrollbhv = 2;;
307 type conf =
308 { mutable scrollbw : int
309 ; mutable scrollh : int
310 ; mutable scrollb : scrollb
311 ; mutable icase : bool
312 ; mutable preload : bool
313 ; mutable pagebias : int
314 ; mutable verbose : bool
315 ; mutable debug : bool
316 ; mutable scrollstep : int
317 ; mutable hscrollstep : int
318 ; mutable maxhfit : bool
319 ; mutable crophack : bool
320 ; mutable autoscrollstep : int
321 ; mutable maxwait : float option
322 ; mutable hlinks : bool
323 ; mutable underinfo : bool
324 ; mutable interpagespace : interpagespace
325 ; mutable zoom : float
326 ; mutable presentation : bool
327 ; mutable angle : angle
328 ; mutable cwinw : int
329 ; mutable cwinh : int
330 ; mutable savebmarks : bool
331 ; mutable fitmodel : fitmodel
332 ; mutable trimmargins : trimmargins
333 ; mutable trimfuzz : irect
334 ; mutable memlimit : memsize
335 ; mutable texcount : texcount
336 ; mutable sliceheight : sliceheight
337 ; mutable thumbw : width
338 ; mutable jumpback : bool
339 ; mutable bgcolor : (float * float * float)
340 ; mutable bedefault : bool
341 ; mutable tilew : int
342 ; mutable tileh : int
343 ; mutable mustoresize : memsize
344 ; mutable checkers : bool
345 ; mutable aalevel : int
346 ; mutable urilauncher : string
347 ; mutable pathlauncher : string
348 ; mutable colorspace : colorspace
349 ; mutable invert : bool
350 ; mutable colorscale : float
351 ; mutable redirectstderr : bool
352 ; mutable ghyllscroll : (int * int * int) option
353 ; mutable columns : columns
354 ; mutable beyecolumns : columncount option
355 ; mutable selcmd : string
356 ; mutable paxcmd : string
357 ; mutable updatecurs : bool
358 ; mutable keyhashes : (string * keyhash) list
359 ; mutable hfsize : int
360 ; mutable pgscale : float
361 ; mutable usepbo : bool
362 ; mutable wheelbypage : bool
363 ; mutable stcmd : string
364 ; mutable riani : bool
365 ; mutable pax : (float * int * int) ref option
366 ; mutable paxmark : mark
368 and columns =
369 | Csingle of singlecolumn
370 | Cmulti of multicolumns
371 | Csplit of splitcolumns
374 type anchor = pageno * top * dtop;;
376 type outline = string * int * anchor;;
378 type rect = float * float * float * float * float * float * float * float;;
380 type tile = opaque * pixmapsize * elapsed
381 and elapsed = float;;
382 type pagemapkey = pageno * gen;;
383 type tilemapkey = pageno * gen * colorspace * angle * width * height * col * row
384 and row = int
385 and col = int;;
387 let emptyanchor = (0, 0.0, 0.0);;
389 type infochange = | Memused | Docinfo | Pdim;;
391 class type uioh = object
392 method display : unit
393 method key : int -> int -> uioh
394 method button : int -> bool -> int -> int -> int -> uioh
395 method motion : int -> int -> uioh
396 method pmotion : int -> int -> uioh
397 method infochanged : infochange -> unit
398 method scrollpw : (int * float * float)
399 method scrollph : (int * float * float)
400 method modehash : keyhash
401 method eformsgs : bool
402 end;;
404 type mode =
405 | Birdseye of (conf * leftx * pageno * pageno * anchor)
406 | Textentry of (textentry * onleave)
407 | View
408 | LinkNav of linktarget
409 and onleave = leavetextentrystatus -> unit
410 and leavetextentrystatus = | Cancel | Confirm
411 and helpitem = string * int * action
412 and action =
413 | Noaction
414 | Action of (uioh -> uioh)
415 and linktarget =
416 | Ltexact of (pageno * int)
417 | Ltgendir of int
420 let isbirdseye = function Birdseye _ -> true | _ -> false;;
421 let istextentry = function Textentry _ -> true | _ -> false;;
423 type currently =
424 | Idle
425 | Loading of (page * gen)
426 | Tiling of (
427 page * opaque * colorspace * angle * gen * col * row * width * height
429 | Outlining of outline list
432 let emptykeyhash = Hashtbl.create 0;;
433 let nouioh : uioh = object (self)
434 method display = ()
435 method key _ _ = self
436 method button _ _ _ _ _ = self
437 method motion _ _ = self
438 method pmotion _ _ = self
439 method infochanged _ = ()
440 method scrollpw = (0, nan, nan)
441 method scrollph = (0, nan, nan)
442 method modehash = emptykeyhash
443 method eformsgs = false
444 end;;
446 type state =
447 { mutable sr : Unix.file_descr
448 ; mutable sw : Unix.file_descr
449 ; mutable wsfd : Unix.file_descr
450 ; mutable errfd : Unix.file_descr option
451 ; mutable stderr : Unix.file_descr
452 ; mutable errmsgs : Buffer.t
453 ; mutable newerrmsgs : bool
454 ; mutable w : int
455 ; mutable x : int
456 ; mutable y : int
457 ; mutable anchor : anchor
458 ; mutable ranchors : (string * string * anchor * string) list
459 ; mutable maxy : int
460 ; mutable layout : page list
461 ; pagemap : (pagemapkey, opaque) Hashtbl.t
462 ; tilemap : (tilemapkey, tile) Hashtbl.t
463 ; tilelru : (tilemapkey * opaque * pixmapsize) Queue.t
464 ; mutable pdims : (pageno * width * height * leftx) list
465 ; mutable pagecount : int
466 ; mutable currently : currently
467 ; mutable mstate : mstate
468 ; mutable searchpattern : string
469 ; mutable rects : (pageno * recttype * rect) list
470 ; mutable rects1 : (pageno * recttype * rect) list
471 ; mutable text : string
472 ; mutable winstate : Wsi.winstate list
473 ; mutable mode : mode
474 ; mutable uioh : uioh
475 ; mutable outlines : outline array
476 ; mutable bookmarks : outline list
477 ; mutable path : string
478 ; mutable password : string
479 ; mutable nameddest : string
480 ; mutable geomcmds : (string * ((string * (unit -> unit)) list))
481 ; mutable memused : memsize
482 ; mutable gen : gen
483 ; mutable throttle : (page list * int * float) option
484 ; mutable autoscroll : int option
485 ; mutable ghyll : (int option -> unit)
486 ; mutable help : helpitem array
487 ; mutable docinfo : (int * string) list
488 ; mutable texid : GlTex.texture_id option
489 ; hists : hists
490 ; mutable prevzoom : float
491 ; mutable progress : float
492 ; mutable redisplay : bool
493 ; mutable mpos : mpos
494 ; mutable keystate : keystate
495 ; mutable glinks : bool
496 ; mutable prevcolumns : (columns * float) option
497 ; mutable winw : int
498 ; mutable winh : int
499 ; mutable reprf : (unit -> unit)
500 ; mutable origin : string
501 ; mutable roam : (unit -> unit)
503 and hists =
504 { pat : string circbuf
505 ; pag : string circbuf
506 ; nav : anchor circbuf
507 ; sel : string circbuf
511 let defconf =
512 { scrollbw = 7
513 ; scrollh = 12
514 ; scrollb = scrollbhv lor scrollbvv
515 ; icase = true
516 ; preload = true
517 ; pagebias = 0
518 ; verbose = false
519 ; debug = false
520 ; scrollstep = 24
521 ; hscrollstep = 24
522 ; maxhfit = true
523 ; crophack = false
524 ; autoscrollstep = 2
525 ; maxwait = None
526 ; hlinks = false
527 ; underinfo = false
528 ; interpagespace = 2
529 ; zoom = 1.0
530 ; presentation = false
531 ; angle = 0
532 ; cwinw = 900
533 ; cwinh = 900
534 ; savebmarks = true
535 ; fitmodel = FitProportional
536 ; trimmargins = false
537 ; trimfuzz = (0,0,0,0)
538 ; memlimit = 32 lsl 20
539 ; texcount = 256
540 ; sliceheight = 24
541 ; thumbw = 76
542 ; jumpback = true
543 ; bgcolor = (0.5, 0.5, 0.5)
544 ; bedefault = false
545 ; tilew = 2048
546 ; tileh = 2048
547 ; mustoresize = 256 lsl 20
548 ; checkers = true
549 ; aalevel = 8
550 ; urilauncher =
551 (match platform with
552 | Plinux | Pfreebsd | Pdragonflybsd
553 | Popenbsd | Pnetbsd | Psun -> "xdg-open \"%s\""
554 | Posx -> "open \"%s\""
555 | Pcygwin -> "cygstart \"%s\""
556 | Punknown -> "echo %s")
557 ; pathlauncher = "lp \"%s\""
558 ; selcmd =
559 (match platform with
560 | Plinux | Pfreebsd | Pdragonflybsd
561 | Popenbsd | Pnetbsd | Psun -> "xsel -i"
562 | Posx -> "pbcopy"
563 | Pcygwin -> "wsel"
564 | Punknown -> "cat")
565 ; paxcmd = "cat"
566 ; colorspace = Rgb
567 ; invert = false
568 ; colorscale = 1.0
569 ; redirectstderr = false
570 ; ghyllscroll = None
571 ; columns = Csingle [||]
572 ; beyecolumns = None
573 ; updatecurs = false
574 ; hfsize = 12
575 ; pgscale = 1.0
576 ; usepbo = false
577 ; wheelbypage = false
578 ; stcmd = "echo SyncTex"
579 ; riani = false
580 ; pax = None
581 ; paxmark = Mark_word
582 ; keyhashes =
583 let mk n = (n, Hashtbl.create 1) in
584 [ mk "global"
585 ; mk "info"
586 ; mk "help"
587 ; mk "outline"
588 ; mk "listview"
589 ; mk "birdseye"
590 ; mk "textentry"
591 ; mk "links"
592 ; mk "view"
597 let wtmode = ref false;;
599 let findkeyhash c name =
600 try List.assoc name c.keyhashes
601 with Not_found -> failwith ("invalid mode name `" ^ name ^ "'")
604 let conf = { defconf with angle = defconf.angle };;
606 let pgscale h = truncate (float h *. conf.pgscale);;
608 type fontstate =
609 { mutable fontsize : int
610 ; mutable wwidth : float
611 ; mutable maxrows : int
615 let fstate =
616 { fontsize = 14
617 ; wwidth = nan
618 ; maxrows = -1
622 let geturl s =
623 let colonpos = try String.index s ':' with Not_found -> -1 in
624 let len = String.length s in
625 if colonpos >= 0 && colonpos + 3 < len
626 then (
627 if s.[colonpos+1] = '/' && s.[colonpos+2] = '/'
628 then
629 let schemestartpos =
630 try String.rindex_from s colonpos ' '
631 with Not_found -> -1
633 let scheme =
634 String.sub s (schemestartpos+1) (colonpos-1-schemestartpos)
636 match scheme with
637 | "http" | "ftp" | "mailto" ->
638 let epos =
639 try String.index_from s colonpos ' '
640 with Not_found -> len
642 String.sub s (schemestartpos+1) (epos-1-schemestartpos)
643 | _ -> ""
644 else ""
646 else ""
649 let gotouri uri =
650 if String.length conf.urilauncher = 0
651 then print_endline uri
652 else (
653 let url = geturl uri in
654 if String.length url = 0
655 then Printf.eprintf "obtained empty url from uri %S" uri
656 else
657 let re = Str.regexp "%s" in
658 let command = Str.global_replace re url conf.urilauncher in
659 try popen command []
660 with exn ->
661 Printf.eprintf
662 "failed to execute `%s': %s\n" command (exntos exn);
663 flush stderr;
667 let version () =
668 Printf.sprintf "llpp version %s (%s/%dbit, ocaml %s)" Help.version
669 (platform_to_string platform) Sys.word_size Sys.ocaml_version
672 let makehelp () =
673 let strings = version () :: "" :: Help.keys in
674 Array.of_list (
675 List.map (fun s ->
676 let url = geturl s in
677 if String.length url > 0
678 then (s, 0, Action (fun u -> gotouri url; u))
679 else (s, 0, Noaction)
680 ) strings);
683 let noghyll _ = ();;
684 let firstgeomcmds = "", [];;
685 let noreprf () = ();;
687 let state =
688 { sr = Unix.stdin
689 ; sw = Unix.stdin
690 ; wsfd = Unix.stdin
691 ; errfd = None
692 ; stderr = Unix.stderr
693 ; errmsgs = Buffer.create 0
694 ; newerrmsgs = false
695 ; x = 0
696 ; y = 0
697 ; w = 0
698 ; anchor = emptyanchor
699 ; ranchors = []
700 ; layout = []
701 ; maxy = max_int
702 ; tilelru = Queue.create ()
703 ; pagemap = Hashtbl.create 10
704 ; tilemap = Hashtbl.create 10
705 ; pdims = []
706 ; pagecount = 0
707 ; currently = Idle
708 ; mstate = Mnone
709 ; rects = []
710 ; rects1 = []
711 ; text = ""
712 ; mode = View
713 ; winstate = []
714 ; searchpattern = ""
715 ; outlines = [||]
716 ; bookmarks = []
717 ; path = ""
718 ; password = ""
719 ; nameddest = ""
720 ; geomcmds = firstgeomcmds
721 ; hists =
722 { nav = cbnew 10 emptyanchor
723 ; pat = cbnew 10 ""
724 ; pag = cbnew 10 ""
725 ; sel = cbnew 10 ""
727 ; memused = 0
728 ; gen = 0
729 ; throttle = None
730 ; autoscroll = None
731 ; ghyll = noghyll
732 ; help = makehelp ()
733 ; docinfo = []
734 ; texid = None
735 ; prevzoom = 1.0
736 ; progress = -1.0
737 ; uioh = nouioh
738 ; redisplay = true
739 ; mpos = (-1, -1)
740 ; keystate = KSnone
741 ; glinks = false
742 ; prevcolumns = None
743 ; winw = -1
744 ; winh = -1
745 ; reprf = noreprf
746 ; origin = ""
747 ; roam = (fun () -> ())
751 let hscrollh () =
752 if (conf.scrollb land scrollbhv = 0)
753 || (state.x = 0 && state.w <= state.winw - conf.scrollbw)
754 then 0
755 else conf.scrollbw
758 let vscrollw () =
759 if (conf.scrollb land scrollbvv = 0)
760 then 0
761 else conf.scrollbw
764 let wadjsb w = w - vscrollw ();;
766 let setfontsize n =
767 fstate.fontsize <- n;
768 fstate.wwidth <- measurestr fstate.fontsize "w";
769 fstate.maxrows <- (state.winh - fstate.fontsize - 1) / (fstate.fontsize + 1);
772 let vlog fmt =
773 if conf.verbose
774 then
775 Printf.kprintf prerr_endline fmt
776 else
777 Printf.kprintf ignore fmt
780 let launchpath () =
781 if String.length conf.pathlauncher = 0
782 then print_endline state.path
783 else (
784 let re = Str.regexp "%s" in
785 let command = Str.global_replace re state.path conf.pathlauncher in
786 try popen command []
787 with exn ->
788 Printf.eprintf "failed to execute `%s': %s\n" command (exntos exn);
789 flush stderr;
793 module Ne = struct
794 type 'a t = | Res of 'a | Exn of exn;;
796 let pipe () =
797 try Res (Unix.pipe ())
798 with exn -> Exn exn
801 let clo fd f =
802 try tempfailureretry Unix.close fd
803 with exn -> f (exntos exn)
806 let dup fd =
807 try Res (tempfailureretry Unix.dup fd)
808 with exn -> Exn exn
811 let dup2 fd1 fd2 =
812 try Res (tempfailureretry (Unix.dup2 fd1) fd2)
813 with exn -> Exn exn
815 end;;
817 let redirectstderr () =
818 let clofail what errmsg = dolog "failed to close %s: %s" what errmsg in
819 if conf.redirectstderr
820 then
821 match Ne.pipe () with
822 | Ne.Exn exn ->
823 dolog "failed to create stderr redirection pipes: %s" (exntos exn)
825 | Ne.Res (r, w) ->
826 begin match Ne.dup Unix.stderr with
827 | Ne.Exn exn ->
828 dolog "failed to dup stderr: %s" (exntos exn);
829 Ne.clo r (clofail "pipe/r");
830 Ne.clo w (clofail "pipe/w");
832 | Ne.Res dupstderr ->
833 begin match Ne.dup2 w Unix.stderr with
834 | Ne.Exn exn ->
835 dolog "failed to dup2 to stderr: %s" (exntos exn);
836 Ne.clo dupstderr (clofail "stderr duplicate");
837 Ne.clo r (clofail "redir pipe/r");
838 Ne.clo w (clofail "redir pipe/w");
840 | Ne.Res () ->
841 state.stderr <- dupstderr;
842 state.errfd <- Some r;
843 end;
845 else (
846 state.newerrmsgs <- false;
847 begin match state.errfd with
848 | Some fd ->
849 begin match Ne.dup2 state.stderr Unix.stderr with
850 | Ne.Exn exn ->
851 dolog "failed to dup2 original stderr: %s" (exntos exn)
852 | Ne.Res () ->
853 Ne.clo fd (clofail "dup of stderr");
854 state.errfd <- None;
855 end;
856 | None -> ()
857 end;
858 prerr_string (Buffer.contents state.errmsgs);
859 flush stderr;
860 Buffer.clear state.errmsgs;
864 module G =
865 struct
866 let postRedisplay who =
867 if conf.verbose
868 then prerr_endline ("redisplay for " ^ who);
869 state.redisplay <- true;
871 end;;
873 let getopaque pageno =
874 try Some (Hashtbl.find state.pagemap (pageno, state.gen))
875 with Not_found -> None
878 let putopaque pageno opaque =
879 Hashtbl.replace state.pagemap (pageno, state.gen) opaque
882 let pagetranslatepoint l x y =
883 let dy = y - l.pagedispy in
884 let y = dy + l.pagey in
885 let dx = x - l.pagedispx in
886 let x = dx + l.pagex in
887 (x, y);
890 let onppundermouse g x y d =
891 let rec f = function
892 | l :: rest ->
893 begin match getopaque l.pageno with
894 | Some opaque ->
895 let x0 = l.pagedispx in
896 let x1 = x0 + l.pagevw in
897 let y0 = l.pagedispy in
898 let y1 = y0 + l.pagevh in
899 if y >= y0 && y <= y1 && x >= x0 && x <= x1
900 then
901 let px, py = pagetranslatepoint l x y in
902 match g opaque l px py with
903 | Some res -> res
904 | None -> f rest
905 else f rest
906 | _ ->
907 f rest
909 | [] -> d
911 f state.layout
914 let getunder x y =
915 let g opaque _ px py =
916 match whatsunder opaque px py with
917 | Unone -> None
918 | under -> Some under
920 onppundermouse g x y Unone
923 let unproject x y =
924 let g opaque l x y =
925 match unproject opaque x y with
926 | Some (x, y) -> Some (Some (l.pageno, x, y))
927 | None -> None
929 onppundermouse g x y None;
932 let showtext c s =
933 state.text <- Printf.sprintf "%c%s" c s;
934 G.postRedisplay "showtext";
937 let paxunder x y =
938 let g opaque l px py =
939 if markunder opaque px py conf.paxmark
940 then (
941 Some (fun () ->
942 match getopaque l.pageno with
943 | None -> ()
944 | Some opaque ->
945 match Ne.pipe () with
946 | Ne.Exn exn ->
947 showtext '!'
948 (Printf.sprintf
949 "can not create mark pipe: %s"
950 (exntos exn));
951 | Ne.Res (r, w) ->
952 let doclose what fd =
953 Ne.clo fd (fun msg ->
954 dolog "%s close failed: %s" what msg)
957 popen conf.paxcmd [r, 0; w, -1];
958 copysel w opaque false;
959 doclose "pipe/r" r;
960 G.postRedisplay "paxunder";
961 with exn ->
962 dolog "can not execute %S: %s"
963 conf.paxcmd (exntos exn);
964 doclose "pipe/r" r;
965 doclose "pipe/w" w;
968 else None
970 G.postRedisplay "paxunder";
971 state.roam <-
972 onppundermouse g x y (fun () -> showtext '!' "Whoopsie daisy");
975 let selstring s =
976 match Ne.pipe () with
977 | Ne.Exn exn ->
978 showtext '!' (Printf.sprintf "pipe failed: %s" (exntos exn))
979 | Ne.Res (r, w) ->
980 let popened =
981 try popen conf.selcmd [r, 0; w, -1]; true
982 with exn ->
983 showtext '!'
984 (Printf.sprintf "failed to execute %s: %s"
985 conf.selcmd (exntos exn));
986 false
988 let clo cap fd =
989 Ne.clo fd (fun msg ->
990 showtext '!' (Printf.sprintf "failed to close %s: %s" cap msg)
993 if popened
994 then
995 (try
996 let l = String.length s in
997 let n = tempfailureretry (Unix.write w s 0) l in
998 if n != l
999 then
1000 showtext '!'
1001 (Printf.sprintf
1002 "failed to write %d characters to sel pipe, wrote %d"
1005 with exn ->
1006 showtext '!'
1007 (Printf.sprintf "failed to write to sel pipe: %s"
1008 (exntos exn)
1011 else dolog "%s" s;
1012 clo "pipe/r" r;
1013 clo "pipe/w" w;
1016 let undertext = function
1017 | Unone -> "none"
1018 | Ulinkuri s -> s
1019 | Ulinkgoto (pageno, _) -> Printf.sprintf "%s: page %d" state.path (pageno+1)
1020 | Utext s -> "font: " ^ s
1021 | Uunexpected s -> "unexpected: " ^ s
1022 | Ulaunch s -> "launch: " ^ s
1023 | Unamed s -> "named: " ^ s
1024 | Uremote (filename, pageno) ->
1025 Printf.sprintf "%s: page %d" filename (pageno+1)
1028 let updateunder x y =
1029 match getunder x y with
1030 | Unone -> Wsi.setcursor Wsi.CURSOR_INHERIT
1031 | Ulinkuri uri ->
1032 if conf.underinfo then showtext 'u' ("ri: " ^ uri);
1033 Wsi.setcursor Wsi.CURSOR_INFO
1034 | Ulinkgoto (pageno, _) ->
1035 if conf.underinfo
1036 then showtext 'p' ("age: " ^ string_of_int (pageno+1));
1037 Wsi.setcursor Wsi.CURSOR_INFO
1038 | Utext s ->
1039 if conf.underinfo then showtext 'f' ("ont: " ^ s);
1040 Wsi.setcursor Wsi.CURSOR_TEXT
1041 | Uunexpected s ->
1042 if conf.underinfo then showtext 'u' ("nexpected: " ^ s);
1043 Wsi.setcursor Wsi.CURSOR_INHERIT
1044 | Ulaunch s ->
1045 if conf.underinfo then showtext 'l' ("aunch: " ^ s);
1046 Wsi.setcursor Wsi.CURSOR_INHERIT
1047 | Unamed s ->
1048 if conf.underinfo then showtext 'n' ("amed: " ^ s);
1049 Wsi.setcursor Wsi.CURSOR_INHERIT
1050 | Uremote (filename, pageno) ->
1051 if conf.underinfo then showtext 'r'
1052 (Printf.sprintf "emote: %s (%d)" filename (pageno+1));
1053 Wsi.setcursor Wsi.CURSOR_INFO
1056 let showlinktype under =
1057 if conf.underinfo
1058 then
1059 match under with
1060 | Unone -> ()
1061 | under ->
1062 let s = undertext under in
1063 showtext ' ' s
1066 let addchar s c =
1067 let b = Buffer.create (String.length s + 1) in
1068 Buffer.add_string b s;
1069 Buffer.add_char b c;
1070 Buffer.contents b;
1073 module type TextEnumType =
1075 type t
1076 val name : string
1077 val names : string array
1078 end;;
1080 module TextEnumMake (Ten : TextEnumType) =
1081 struct
1082 let names = Ten.names;;
1083 let to_int (t : Ten.t) = Obj.magic t;;
1084 let to_string t = names.(to_int t);;
1085 let of_int n : Ten.t = Obj.magic n;;
1086 let of_string s =
1087 let rec find i =
1088 if i = Array.length names
1089 then failwith ("invalid " ^ Ten.name ^ ": " ^ s)
1090 else (
1091 if Ten.names.(i) = s
1092 then of_int i
1093 else find (i+1)
1095 in find 0;;
1096 end;;
1098 module CSTE = TextEnumMake (struct
1099 type t = colorspace;;
1100 let name = "colorspace";;
1101 let names = [|"rgb"; "bgr"; "gray"|];;
1102 end);;
1104 module MTE = TextEnumMake (struct
1105 type t = mark;;
1106 let name = "mark";;
1107 let names = [|"page"; "block"; "line"; "word"|];;
1108 end);;
1110 module FMTE = TextEnumMake (struct
1111 type t= fitmodel;;
1112 let name = "fitmodel";;
1113 let names = [|"width"; "proportional"; "page"|];;
1114 end);;
1116 let intentry_with_suffix text key =
1117 let c =
1118 if key >= 32 && key < 127
1119 then Char.chr key
1120 else '\000'
1122 match Char.lowercase c with
1123 | '0' .. '9' ->
1124 let text = addchar text c in
1125 TEcont text
1127 | 'k' | 'm' | 'g' ->
1128 let text = addchar text c in
1129 TEcont text
1131 | _ ->
1132 state.text <- Printf.sprintf "invalid char (%d, `%c')" key c;
1133 TEcont text
1136 let multicolumns_to_string (n, a, b) =
1137 if a = 0 && b = 0
1138 then Printf.sprintf "%d" n
1139 else Printf.sprintf "%d,%d,%d" n a b;
1142 let multicolumns_of_string s =
1144 (int_of_string s, 0, 0)
1145 with _ ->
1146 Scanf.sscanf s "%u,%u,%u" (fun n a b ->
1147 if a > 1 || b > 1
1148 then failwith "subtly broken"; (n, a, b)
1152 let readcmd fd =
1153 let s = "xxxx" in
1154 let n = tempfailureretry (Unix.read fd s 0) 4 in
1155 if n != 4 then failwith "incomplete read(len)";
1156 let len = 0
1157 lor (Char.code s.[0] lsl 24)
1158 lor (Char.code s.[1] lsl 16)
1159 lor (Char.code s.[2] lsl 8)
1160 lor (Char.code s.[3] lsl 0)
1162 let s = String.create len in
1163 let n = tempfailureretry (Unix.read fd s 0) len in
1164 if n != len then failwith "incomplete read(data)";
1168 let btod b = if b then 1 else 0;;
1170 let wcmd fmt =
1171 let b = Buffer.create 16 in
1172 Buffer.add_string b "llll";
1173 Printf.kbprintf
1174 (fun b ->
1175 let s = Buffer.contents b in
1176 let n = String.length s in
1177 let len = n - 4 in
1178 (* dolog "wcmd %S" (String.sub s 4 len); *)
1179 s.[0] <- Char.chr ((len lsr 24) land 0xff);
1180 s.[1] <- Char.chr ((len lsr 16) land 0xff);
1181 s.[2] <- Char.chr ((len lsr 8) land 0xff);
1182 s.[3] <- Char.chr (len land 0xff);
1183 let n' = tempfailureretry (Unix.write state.sw s 0) n in
1184 if n' != n then failwith "write failed";
1185 ) b fmt;
1188 let calcips h =
1189 let d = state.winh - h in
1190 max conf.interpagespace ((d + 1) / 2)
1193 let rowyh (c, coverA, coverB) b n =
1194 if c = 1 || (n < coverA || n >= state.pagecount - coverB)
1195 then
1196 let _, _, vy, (_, _, h, _) = b.(n) in
1197 (vy, h)
1198 else
1199 let n' = n - coverA in
1200 let d = n' mod c in
1201 let s = n - d in
1202 let e = min state.pagecount (s + c) in
1203 let rec find m miny maxh = if m = e then miny, maxh else
1204 let _, _, y, (_, _, h, _) = b.(m) in
1205 let miny = min miny y in
1206 let maxh = max maxh h in
1207 find (m+1) miny maxh
1208 in find s max_int 0
1211 let calcheight () =
1212 match conf.columns with
1213 | Cmulti ((_, _, _) as cl, b) ->
1214 if Array.length b > 0
1215 then
1216 let y, h = rowyh cl b (Array.length b - 1) in
1217 y + h + (if conf.presentation then calcips h else 0)
1218 else 0
1219 | Csingle b ->
1220 if Array.length b > 0
1221 then
1222 let (_, _, y, (_, _, h, _)) = b.(Array.length b - 1) in
1223 y + h + (if conf.presentation then calcips h else 0)
1224 else 0
1225 | Csplit (_, b) ->
1226 if Array.length b > 0
1227 then
1228 let (_, _, y, (_, _, h, _)) = b.(Array.length b - 1) in
1229 y + h
1230 else 0
1233 let getpageyh pageno =
1234 let pageno = bound pageno 0 (state.pagecount-1) in
1235 match conf.columns with
1236 | Csingle b ->
1237 if Array.length b = 0
1238 then 0, 0
1239 else
1240 let (_, _, y, (_, _, h, _)) = b.(pageno) in
1241 let y =
1242 if conf.presentation
1243 then y - calcips h
1244 else y
1246 y, h
1247 | Cmulti (cl, b) ->
1248 if Array.length b = 0
1249 then 0, 0
1250 else
1251 let y, h = rowyh cl b pageno in
1252 let y =
1253 if conf.presentation
1254 then y - calcips h
1255 else y
1257 y, h
1258 | Csplit (c, b) ->
1259 if Array.length b = 0
1260 then 0, 0
1261 else
1262 let n = pageno*c in
1263 let (_, _, y, (_, _, h, _)) = b.(n) in
1264 y, h
1267 let getpagedim pageno =
1268 let rec f ppdim l =
1269 match l with
1270 | (n, _, _, _) as pdim :: rest ->
1271 if n >= pageno
1272 then (if n = pageno then pdim else ppdim)
1273 else f pdim rest
1275 | [] -> ppdim
1277 f (-1, -1, -1, -1) state.pdims
1280 let getpagey pageno = fst (getpageyh pageno);;
1282 let nogeomcmds cmds =
1283 match cmds with
1284 | s, [] -> String.length s = 0
1285 | _ -> false
1288 let page_of_y y =
1289 let ((c, coverA, coverB) as cl), b =
1290 match conf.columns with
1291 | Csingle b -> (1, 0, 0), b
1292 | Cmulti (c, b) -> c, b
1293 | Csplit (_, b) -> (1, 0, 0), b
1295 if Array.length b = 0
1296 then -1
1297 else
1298 let rec bsearch nmin nmax =
1299 if nmin > nmax
1300 then bound nmin 0 (state.pagecount-1)
1301 else
1302 let n = (nmax + nmin) / 2 in
1303 let vy, h = rowyh cl b n in
1304 let y0, y1 =
1305 if conf.presentation
1306 then
1307 let ips = calcips h in
1308 let y0 = vy - ips in
1309 let y1 = vy + h + ips in
1310 y0, y1
1311 else (
1312 if n = 0
1313 then 0, vy + h + conf.interpagespace
1314 else
1315 let y0 = vy - conf.interpagespace in
1316 y0, y0 + h + conf.interpagespace
1319 if y >= y0 && y < y1
1320 then (
1321 if c = 1
1322 then n
1323 else (
1324 if n > coverA
1325 then
1326 if n < state.pagecount - coverB
1327 then ((n-coverA)/c)*c + coverA
1328 else n
1329 else n
1332 else (
1333 if y > y0
1334 then bsearch (n+1) nmax
1335 else bsearch nmin (n-1)
1338 let r = bsearch 0 (state.pagecount-1) in
1342 let layoutN ((columns, coverA, coverB), b) y sh =
1343 let sh = sh - (hscrollh ()) in
1344 let rec fold accu n =
1345 if n = Array.length b
1346 then accu
1347 else
1348 let pdimno, dx, vy, (_, w, h, xoff) = b.(n) in
1349 if (vy - y) > sh &&
1350 (n = coverA - 1
1351 || n = state.pagecount - coverB
1352 || (n - coverA) mod columns = columns - 1)
1353 then accu
1354 else
1355 let accu =
1356 if vy + h > y
1357 then
1358 let pagey = max 0 (y - vy) in
1359 let pagedispy = if pagey > 0 then 0 else vy - y in
1360 let pagedispx, pagex =
1361 let pdx =
1362 if n = coverA - 1 || n = state.pagecount - coverB
1363 then state.x + (wadjsb state.winw - w) / 2
1364 else dx + xoff + state.x
1366 if pdx < 0
1367 then 0, -pdx
1368 else pdx, 0
1370 let pagevw =
1371 let vw = wadjsb state.winw - pagedispx in
1372 let pw = w - pagex in
1373 min vw pw
1375 let pagevh = min (h - pagey) (sh - pagedispy) in
1376 if pagevw > 0 && pagevh > 0
1377 then
1378 let e =
1379 { pageno = n
1380 ; pagedimno = pdimno
1381 ; pagew = w
1382 ; pageh = h
1383 ; pagex = pagex
1384 ; pagey = pagey
1385 ; pagevw = pagevw
1386 ; pagevh = pagevh
1387 ; pagedispx = pagedispx
1388 ; pagedispy = pagedispy
1389 ; pagecol = 0
1392 e :: accu
1393 else
1394 accu
1395 else
1396 accu
1398 fold accu (n+1)
1400 List.rev (fold [] (page_of_y y));
1403 let layoutS (columns, b) y sh =
1404 let sh = sh - hscrollh () in
1405 let rec fold accu n =
1406 if n = Array.length b
1407 then accu
1408 else
1409 let pdimno, px, vy, (_, pagew, pageh, xoff) = b.(n) in
1410 if (vy - y) > sh
1411 then accu
1412 else
1413 let accu =
1414 if vy + pageh > y
1415 then
1416 let x = xoff + state.x in
1417 let pagey = max 0 (y - vy) in
1418 let pagedispy = if pagey > 0 then 0 else vy - y in
1419 let pagedispx, pagex =
1420 if px = 0
1421 then (
1422 if x < 0
1423 then 0, -x
1424 else x, 0
1426 else (
1427 let px = px - x in
1428 if px < 0
1429 then -px, 0
1430 else 0, px
1433 let pagecolw = pagew/columns in
1434 let pagedispx =
1435 if pagecolw < state.winw
1436 then pagedispx + ((wadjsb state.winw - pagecolw) / 2)
1437 else pagedispx
1439 let pagevw =
1440 let vw = wadjsb state.winw - pagedispx in
1441 let pw = pagew - pagex in
1442 min vw pw
1444 let pagevw = min pagevw pagecolw in
1445 let pagevh = min (pageh - pagey) (sh - pagedispy) in
1446 if pagevw > 0 && pagevh > 0
1447 then
1448 let e =
1449 { pageno = n/columns
1450 ; pagedimno = pdimno
1451 ; pagew = pagew
1452 ; pageh = pageh
1453 ; pagex = pagex
1454 ; pagey = pagey
1455 ; pagevw = pagevw
1456 ; pagevh = pagevh
1457 ; pagedispx = pagedispx
1458 ; pagedispy = pagedispy
1459 ; pagecol = n mod columns
1462 e :: accu
1463 else
1464 accu
1465 else
1466 accu
1468 fold accu (n+1)
1470 List.rev (fold [] 0)
1473 let layout y sh =
1474 if nogeomcmds state.geomcmds
1475 then
1476 match conf.columns with
1477 | Csingle b -> layoutN ((1, 0, 0), b) y sh
1478 | Cmulti c -> layoutN c y sh
1479 | Csplit s -> layoutS s y sh
1480 else []
1483 let clamp incr =
1484 let y = state.y + incr in
1485 let y = max 0 y in
1486 let y = min y (state.maxy - (if conf.maxhfit then state.winh else 0)) in
1490 let itertiles l f =
1491 let tilex = l.pagex mod conf.tilew in
1492 let tiley = l.pagey mod conf.tileh in
1494 let col = l.pagex / conf.tilew in
1495 let row = l.pagey / conf.tileh in
1497 let rec rowloop row y0 dispy h =
1498 if h = 0
1499 then ()
1500 else (
1501 let dh = conf.tileh - y0 in
1502 let dh = min h dh in
1503 let rec colloop col x0 dispx w =
1504 if w = 0
1505 then ()
1506 else (
1507 let dw = conf.tilew - x0 in
1508 let dw = min w dw in
1510 f col row dispx dispy x0 y0 dw dh;
1511 colloop (col+1) 0 (dispx+dw) (w-dw)
1514 colloop col tilex l.pagedispx l.pagevw;
1515 rowloop (row+1) 0 (dispy+dh) (h-dh)
1518 if l.pagevw > 0 && l.pagevh > 0
1519 then rowloop row tiley l.pagedispy l.pagevh;
1522 let gettileopaque l col row =
1523 let key =
1524 l.pageno, state.gen, conf.colorspace, conf.angle, l.pagew, l.pageh, col, row
1526 try Some (Hashtbl.find state.tilemap key)
1527 with Not_found -> None
1530 let puttileopaque l col row gen colorspace angle opaque size elapsed =
1531 let key = l.pageno, gen, colorspace, angle, l.pagew, l.pageh, col, row in
1532 Hashtbl.add state.tilemap key (opaque, size, elapsed)
1535 let drawtiles l color =
1536 GlDraw.color color;
1537 let f col row x y tilex tiley w h =
1538 match gettileopaque l col row with
1539 | Some (opaque, _, t) ->
1540 let params = x, y, w, h, tilex, tiley in
1541 if conf.invert
1542 then (
1543 Gl.enable `blend;
1544 GlFunc.blend_func `zero `one_minus_src_color;
1546 drawtile params opaque;
1547 if conf.invert
1548 then Gl.disable `blend;
1549 if conf.debug
1550 then (
1551 let s = Printf.sprintf
1552 "%d[%d,%d] %f sec"
1553 l.pageno col row t
1555 let w = measurestr fstate.fontsize s in
1556 GlMisc.push_attrib [`current];
1557 GlDraw.color (0.0, 0.0, 0.0);
1558 GlDraw.rect
1559 (float (x-2), float (y-2))
1560 (float (x+2) +. w, float (y + fstate.fontsize + 2));
1561 GlDraw.color (1.0, 1.0, 1.0);
1562 drawstring fstate.fontsize x (y + fstate.fontsize - 1) s;
1563 GlMisc.pop_attrib ();
1566 | _ ->
1567 let w =
1568 let lw = wadjsb state.winw - x in
1569 min lw w
1570 and h =
1571 let lh = state.winh - y in
1572 min lh h
1574 begin match state.texid with
1575 | Some id ->
1576 Gl.enable `texture_2d;
1577 GlTex.bind_texture `texture_2d id;
1578 let x0 = float x
1579 and y0 = float y
1580 and x1 = float (x+w)
1581 and y1 = float (y+h) in
1583 let tw = float w /. 16.0
1584 and th = float h /. 16.0 in
1585 let tx0 = float tilex /. 16.0
1586 and ty0 = float tiley /. 16.0 in
1587 let tx1 = tx0 +. tw
1588 and ty1 = ty0 +. th in
1589 GlDraw.begins `quads;
1590 GlTex.coord2 (tx0, ty0); GlDraw.vertex2 (x0, y0);
1591 GlTex.coord2 (tx0, ty1); GlDraw.vertex2 (x0, y1);
1592 GlTex.coord2 (tx1, ty1); GlDraw.vertex2 (x1, y1);
1593 GlTex.coord2 (tx1, ty0); GlDraw.vertex2 (x1, y0);
1594 GlDraw.ends ();
1596 Gl.disable `texture_2d;
1597 | None ->
1598 GlDraw.color (1.0, 1.0, 1.0);
1599 GlDraw.rect
1600 (float x, float y)
1601 (float (x+w), float (y+h));
1602 end;
1603 if w > 128 && h > fstate.fontsize + 10
1604 then (
1605 GlDraw.color (0.0, 0.0, 0.0);
1606 let c, r =
1607 if conf.verbose
1608 then (col*conf.tilew, row*conf.tileh)
1609 else col, row
1611 drawstring2 fstate.fontsize x y "Loading %d [%d,%d]" l.pageno c r;
1613 GlDraw.color color;
1615 itertiles l f
1618 let pagevisible layout n = List.exists (fun l -> l.pageno = n) layout;;
1620 let tilevisible1 l x y =
1621 let ax0 = l.pagex
1622 and ax1 = l.pagex + l.pagevw
1623 and ay0 = l.pagey
1624 and ay1 = l.pagey + l.pagevh in
1626 let bx0 = x
1627 and by0 = y in
1628 let bx1 = min (bx0 + conf.tilew) l.pagew
1629 and by1 = min (by0 + conf.tileh) l.pageh in
1631 let rx0 = max ax0 bx0
1632 and ry0 = max ay0 by0
1633 and rx1 = min ax1 bx1
1634 and ry1 = min ay1 by1 in
1636 let nonemptyintersection = rx1 > rx0 && ry1 > ry0 in
1637 nonemptyintersection
1640 let tilevisible layout n x y =
1641 let rec findpageinlayout m = function
1642 | l :: rest when l.pageno = n ->
1643 tilevisible1 l x y || (
1644 match conf.columns with
1645 | Csplit (c, _) when c > m -> findpageinlayout (m+1) rest
1646 | _ -> false
1648 | _ :: rest -> findpageinlayout 0 rest
1649 | [] -> false
1651 findpageinlayout 0 layout;
1654 let tileready l x y =
1655 tilevisible1 l x y &&
1656 gettileopaque l (x/conf.tilew) (y/conf.tileh) != None
1659 let tilepage n p layout =
1660 let rec loop = function
1661 | l :: rest ->
1662 if l.pageno = n
1663 then
1664 let f col row _ _ _ _ _ _ =
1665 if state.currently = Idle
1666 then
1667 match gettileopaque l col row with
1668 | Some _ -> ()
1669 | None ->
1670 let x = col*conf.tilew
1671 and y = row*conf.tileh in
1672 let w =
1673 let w = l.pagew - x in
1674 min w conf.tilew
1676 let h =
1677 let h = l.pageh - y in
1678 min h conf.tileh
1680 let pbo =
1681 if conf.usepbo
1682 then getpbo w h conf.colorspace
1683 else "0"
1685 wcmd "tile %s %d %d %d %d %s" p x y w h pbo;
1686 state.currently <-
1687 Tiling (
1688 l, p, conf.colorspace, conf.angle, state.gen, col, row,
1689 conf.tilew, conf.tileh
1692 itertiles l f;
1693 else
1694 loop rest
1696 | [] -> ()
1698 if nogeomcmds state.geomcmds
1699 then loop layout;
1702 let preloadlayout y =
1703 let y = if y < state.winh then 0 else y - state.winh in
1704 let h = state.winh*3 in
1705 layout y h;
1708 let load pages =
1709 let rec loop pages =
1710 if state.currently != Idle
1711 then ()
1712 else
1713 match pages with
1714 | l :: rest ->
1715 begin match getopaque l.pageno with
1716 | None ->
1717 wcmd "page %d %d" l.pageno l.pagedimno;
1718 state.currently <- Loading (l, state.gen);
1719 | Some opaque ->
1720 tilepage l.pageno opaque pages;
1721 loop rest
1722 end;
1723 | _ -> ()
1725 if nogeomcmds state.geomcmds
1726 then loop pages
1729 let preload pages =
1730 load pages;
1731 if conf.preload && state.currently = Idle
1732 then load (preloadlayout state.y);
1735 let layoutready layout =
1736 let rec fold all ls =
1737 all && match ls with
1738 | l :: rest ->
1739 let seen = ref false in
1740 let allvisible = ref true in
1741 let foo col row _ _ _ _ _ _ =
1742 seen := true;
1743 allvisible := !allvisible &&
1744 begin match gettileopaque l col row with
1745 | Some _ -> true
1746 | None -> false
1749 itertiles l foo;
1750 fold (!seen && !allvisible) rest
1751 | [] -> true
1753 let alltilesvisible = fold true layout in
1754 alltilesvisible;
1757 let gotoy y =
1758 let y = bound y 0 state.maxy in
1759 let y, layout, proceed =
1760 match conf.maxwait with
1761 | Some time when state.ghyll == noghyll ->
1762 begin match state.throttle with
1763 | None ->
1764 let layout = layout y state.winh in
1765 let ready = layoutready layout in
1766 if not ready
1767 then (
1768 load layout;
1769 state.throttle <- Some (layout, y, now ());
1771 else G.postRedisplay "gotoy showall (None)";
1772 y, layout, ready
1773 | Some (_, _, started) ->
1774 let dt = now () -. started in
1775 if dt > time
1776 then (
1777 state.throttle <- None;
1778 let layout = layout y state.winh in
1779 load layout;
1780 G.postRedisplay "maxwait";
1781 y, layout, true
1783 else -1, [], false
1786 | _ ->
1787 let layout = layout y state.winh in
1788 if not !wtmode || layoutready layout
1789 then G.postRedisplay "gotoy ready";
1790 y, layout, true
1792 if proceed
1793 then (
1794 state.y <- y;
1795 state.layout <- layout;
1796 begin match state.mode with
1797 | LinkNav (Ltexact (pageno, linkno)) ->
1798 let rec loop = function
1799 | [] ->
1800 state.mode <- LinkNav (Ltgendir 0)
1801 | l :: _ when l.pageno = pageno ->
1802 begin match getopaque pageno with
1803 | None ->
1804 state.mode <- LinkNav (Ltgendir 0)
1805 | Some opaque ->
1806 let x0, y0, x1, y1 = getlinkrect opaque linkno in
1807 if not (x0 >= l.pagex && x1 <= l.pagex + l.pagevw
1808 && y0 >= l.pagey && y1 <= l.pagey + l.pagevh)
1809 then state.mode <- LinkNav (Ltgendir 0)
1811 | _ :: rest -> loop rest
1813 loop layout
1814 | _ -> ()
1815 end;
1816 begin match state.mode with
1817 | Birdseye (conf, leftx, pageno, hooverpageno, anchor) ->
1818 if not (pagevisible layout pageno)
1819 then (
1820 match state.layout with
1821 | [] -> ()
1822 | l :: _ ->
1823 state.mode <- Birdseye (
1824 conf, leftx, l.pageno, hooverpageno, anchor
1827 | LinkNav (Ltgendir dir as lt) ->
1828 let linknav =
1829 let rec loop = function
1830 | [] -> lt
1831 | l :: rest ->
1832 match getopaque l.pageno with
1833 | None -> loop rest
1834 | Some opaque ->
1835 let link =
1836 let ld =
1837 if dir = 0
1838 then LDfirstvisible (l.pagex, l.pagey, dir)
1839 else (
1840 if dir > 0 then LDfirst else LDlast
1843 findlink opaque ld
1845 match link with
1846 | Lnotfound -> loop rest
1847 | Lfound n ->
1848 showlinktype (getlink opaque n);
1849 Ltexact (l.pageno, n)
1851 loop state.layout
1853 state.mode <- LinkNav linknav
1854 | _ -> ()
1855 end;
1856 preload layout;
1858 state.ghyll <- noghyll;
1859 if conf.updatecurs
1860 then (
1861 let mx, my = state.mpos in
1862 updateunder mx my;
1866 let conttiling pageno opaque =
1867 tilepage pageno opaque
1868 (if conf.preload then preloadlayout state.y else state.layout)
1871 let gotoy_and_clear_text y =
1872 if not conf.verbose then state.text <- "";
1873 gotoy y;
1876 let getanchor1 l =
1877 let top =
1878 let coloff = l.pagecol * l.pageh in
1879 float (l.pagey + coloff) /. float l.pageh
1881 let dtop =
1882 if l.pagedispy = 0
1883 then
1885 else (
1886 if conf.presentation
1887 then float l.pagedispy /. float (calcips l.pageh)
1888 else float l.pagedispy /. float conf.interpagespace
1891 (l.pageno, top, dtop)
1894 let getanchor () =
1895 match state.layout with
1896 | l :: _ -> getanchor1 l
1897 | [] ->
1898 let n = page_of_y state.y in
1899 if n = -1
1900 then state.anchor
1901 else
1902 let y, h = getpageyh n in
1903 let dy = y - state.y in
1904 let dtop =
1905 if conf.presentation
1906 then
1907 let ips = calcips h in
1908 float (dy + ips) /. float ips
1909 else
1910 float dy /. float conf.interpagespace
1912 (n, 0.0, dtop)
1915 let getanchory (n, top, dtop) =
1916 let y, h = getpageyh n in
1917 if conf.presentation
1918 then
1919 let ips = calcips h in
1920 y + truncate (top*.float h -. dtop*.float ips) + ips;
1921 else
1922 y + truncate (top*.float h -. dtop*.float conf.interpagespace)
1925 let gotoanchor anchor =
1926 gotoy (getanchory anchor);
1929 let addnav () =
1930 cbput state.hists.nav (getanchor ());
1933 let getnav dir =
1934 let anchor = cbgetc state.hists.nav dir in
1935 getanchory anchor;
1938 let gotoghyll y =
1939 let scroll f n a b =
1940 (* http://devmaster.net/forums/topic/9796-ease-in-ease-out-algorithm/ *)
1941 let snake f a b =
1942 let s x = 3.0*.x**2.0 -. 2.0*.x**3.0 in
1943 if f < a
1944 then s (float f /. float a)
1945 else (
1946 if f > b
1947 then 1.0 -. s ((float (f-b) /. float (n-b)))
1948 else 1.0
1951 snake f a b
1952 and summa f n a b =
1953 (* courtesy: (calc-eval "integ(3x^2-2x^3,x)") *)
1954 let iv x = x**3.-.0.5*.x**4. in
1955 let iv1 = iv f in
1956 let ins = float a *. iv1
1957 and outs = float (n-b) *. iv1 in
1958 let ones = b - a in
1959 ins +. outs +. float ones
1961 let rec set (_N, _A, _B) y sy =
1962 let sum = summa 1.0 _N _A _B in
1963 let dy = float (y - sy) in
1964 state.ghyll <- (
1965 let rec gf n y1 o =
1966 if n >= _N
1967 then state.ghyll <- noghyll
1968 else
1969 let go n =
1970 let s = scroll n _N _A _B in
1971 let y1 = y1 +. ((s *. dy) /. sum) in
1972 gotoy_and_clear_text (truncate y1);
1973 state.ghyll <- gf (n+1) y1;
1975 match o with
1976 | None -> go n
1977 | Some y' -> set (_N/2, 1, 1) y' state.y
1979 gf 0 (float state.y)
1982 match conf.ghyllscroll with
1983 | None ->
1984 gotoy_and_clear_text y
1985 | Some nab ->
1986 if state.ghyll == noghyll
1987 then set nab y state.y
1988 else state.ghyll (Some y)
1991 let gotopage n top =
1992 let y, h = getpageyh n in
1993 let y = y + (truncate (top *. float h)) in
1994 gotoghyll y
1997 let gotopage1 n top =
1998 let y = getpagey n in
1999 let y = y + top in
2000 gotoghyll y
2003 let invalidate s f =
2004 state.layout <- [];
2005 state.pdims <- [];
2006 state.rects <- [];
2007 state.rects1 <- [];
2008 match state.geomcmds with
2009 | ps, [] when String.length ps = 0 ->
2010 f ();
2011 state.geomcmds <- s, [];
2013 | ps, [] ->
2014 state.geomcmds <- ps, [s, f];
2016 | ps, (s', _) :: rest when s' = s ->
2017 state.geomcmds <- ps, ((s, f) :: rest);
2019 | ps, cmds ->
2020 state.geomcmds <- ps, ((s, f) :: cmds);
2023 let flushpages () =
2024 Hashtbl.iter (fun _ opaque ->
2025 wcmd "freepage %s" opaque;
2026 ) state.pagemap;
2027 Hashtbl.clear state.pagemap;
2030 let flushtiles () =
2031 if not (Queue.is_empty state.tilelru)
2032 then (
2033 Queue.iter (fun (k, p, s) ->
2034 wcmd "freetile %s" p;
2035 state.memused <- state.memused - s;
2036 Hashtbl.remove state.tilemap k;
2037 ) state.tilelru;
2038 state.uioh#infochanged Memused;
2039 Queue.clear state.tilelru;
2041 load state.layout;
2044 let stateh h =
2045 let h = truncate (float h*.conf.zoom) in
2046 let d = conf.interpagespace lsl (if conf.presentation then 1 else 0) in
2047 h - d
2050 let opendoc path password =
2051 state.path <- path;
2052 state.password <- password;
2053 state.gen <- state.gen + 1;
2054 state.docinfo <- [];
2056 flushpages ();
2057 setaalevel conf.aalevel;
2058 let titlepath =
2059 if String.length state.origin = 0
2060 then path
2061 else state.origin
2063 Wsi.settitle ("llpp " ^ (mbtoutf8 (Filename.basename titlepath)));
2064 wcmd "open %d %s\000%s\000" (btod !wtmode) path password;
2065 invalidate "reqlayout"
2066 (fun () ->
2067 wcmd "reqlayout %d %d %d %s\000"
2068 conf.angle (FMTE.to_int conf.fitmodel)
2069 (stateh state.winh) state.nameddest
2073 let reload () =
2074 state.anchor <- getanchor ();
2075 opendoc state.path state.password;
2078 let scalecolor c =
2079 let c = c *. conf.colorscale in
2080 (c, c, c);
2083 let scalecolor2 (r, g, b) =
2084 (r *. conf.colorscale, g *. conf.colorscale, b *. conf.colorscale);
2087 let docolumns = function
2088 | Csingle _ ->
2089 let a = Array.make state.pagecount (-1, -1, -1, (-1, -1, -1, -1)) in
2090 let rec loop pageno pdimno pdim y ph pdims =
2091 if pageno = state.pagecount
2092 then ()
2093 else
2094 let pdimno, ((_, w, h, xoff) as pdim), pdims =
2095 match pdims with
2096 | ((pageno', _, _, _) as pdim) :: rest when pageno' = pageno ->
2097 pdimno+1, pdim, rest
2098 | _ ->
2099 pdimno, pdim, pdims
2101 let x = max 0 (((wadjsb state.winw - w) / 2) - xoff) in
2102 let y = y +
2103 (if conf.presentation
2104 then (if pageno = 0 then calcips h else calcips ph + calcips h)
2105 else (if pageno = 0 then 0 else conf.interpagespace)
2108 a.(pageno) <- (pdimno, x, y, pdim);
2109 loop (pageno+1) pdimno pdim (y + h) h pdims
2111 loop 0 ~-1 (-1,-1,-1,-1) 0 0 state.pdims;
2112 conf.columns <- Csingle a;
2114 | Cmulti ((columns, coverA, coverB), _) ->
2115 let a = Array.make state.pagecount (-1, -1, -1, (-1, -1, -1, -1)) in
2116 let rec loop pageno pdimno pdim x y rowh pdims =
2117 let rec fixrow m = if m = pageno then () else
2118 let (pdimno, x, y, ((_, _, h, _) as pdim)) = a.(m) in
2119 if h < rowh
2120 then (
2121 let y = y + (rowh - h) / 2 in
2122 a.(m) <- (pdimno, x, y, pdim);
2124 fixrow (m+1)
2126 if pageno = state.pagecount
2127 then fixrow (((pageno - 1) / columns) * columns)
2128 else
2129 let pdimno, ((_, w, h, xoff) as pdim), pdims =
2130 match pdims with
2131 | ((pageno', _, _, _) as pdim) :: rest when pageno' = pageno ->
2132 pdimno+1, pdim, rest
2133 | _ ->
2134 pdimno, pdim, pdims
2136 let x, y, rowh' =
2137 if pageno = coverA - 1 || pageno = state.pagecount - coverB
2138 then (
2139 let x = (wadjsb state.winw - w) / 2 in
2140 let ips =
2141 if conf.presentation then calcips h else conf.interpagespace in
2142 x, y + ips + rowh, h
2144 else (
2145 if (pageno - coverA) mod columns = 0
2146 then (
2147 let x = max 0 (wadjsb state.winw - state.w) / 2 in
2148 let y =
2149 if conf.presentation
2150 then
2151 let ips = calcips h in
2152 y + (if pageno = 0 then 0 else calcips rowh + ips)
2153 else
2154 y + (if pageno = 0 then 0 else conf.interpagespace)
2156 x, y + rowh, h
2158 else x, y, max rowh h
2161 let y =
2162 if pageno > 1 && (pageno - coverA) mod columns = 0
2163 then (
2164 let y =
2165 if pageno = columns && conf.presentation
2166 then (
2167 let ips = calcips rowh in
2168 for i = 0 to pred columns
2170 let (pdimno, x, y, pdim) = a.(i) in
2171 a.(i) <- (pdimno, x, y+ips, pdim)
2172 done;
2173 y+ips;
2175 else y
2177 fixrow (pageno - columns);
2180 else y
2182 a.(pageno) <- (pdimno, x, y, pdim);
2183 let x = x + w + xoff*2 + conf.interpagespace in
2184 loop (pageno+1) pdimno pdim x y rowh' pdims
2186 loop 0 ~-1 (-1,-1,-1,-1) 0 0 0 state.pdims;
2187 conf.columns <- Cmulti ((columns, coverA, coverB), a);
2189 | Csplit (c, _) ->
2190 let a = Array.make (state.pagecount*c) (-1, -1, -1, (-1, -1, -1, -1)) in
2191 let rec loop pageno pdimno pdim y pdims =
2192 if pageno = state.pagecount
2193 then ()
2194 else
2195 let pdimno, ((_, w, h, _) as pdim), pdims =
2196 match pdims with
2197 | ((pageno', _, _, _) as pdim) :: rest when pageno' = pageno ->
2198 pdimno+1, pdim, rest
2199 | _ ->
2200 pdimno, pdim, pdims
2202 let cw = w / c in
2203 let rec loop1 n x y =
2204 if n = c then y else (
2205 a.(pageno*c + n) <- (pdimno, x, y, pdim);
2206 loop1 (n+1) (x+cw) (y + h + conf.interpagespace)
2209 let y = loop1 0 0 y in
2210 loop (pageno+1) pdimno pdim y pdims
2212 loop 0 ~-1 (-1,-1,-1,-1) 0 state.pdims;
2213 conf.columns <- Csplit (c, a);
2216 let represent () =
2217 docolumns conf.columns;
2218 state.maxy <- calcheight ();
2219 if state.reprf == noreprf
2220 then (
2221 match state.mode with
2222 | Birdseye (_, _, pageno, _, _) ->
2223 let y, h = getpageyh pageno in
2224 let top = (state.winh - h) / 2 in
2225 gotoy (max 0 (y - top))
2226 | _ -> gotoanchor state.anchor
2228 else (
2229 state.reprf ();
2230 state.reprf <- noreprf;
2234 let reshape w h =
2235 GlDraw.viewport 0 0 w h;
2236 let firsttime = state.geomcmds == firstgeomcmds in
2237 if not firsttime && nogeomcmds state.geomcmds
2238 then state.anchor <- getanchor ();
2240 state.winw <- w;
2241 let w = wadjsb (truncate (float w *. conf.zoom)) in
2242 let w = max w 2 in
2243 state.winh <- h;
2244 setfontsize fstate.fontsize;
2245 GlMat.mode `modelview;
2246 GlMat.load_identity ();
2248 GlMat.mode `projection;
2249 GlMat.load_identity ();
2250 GlMat.rotate ~x:1.0 ~angle:180.0 ();
2251 GlMat.translate ~x:~-.1.0 ~y:~-.1.0 ();
2252 GlMat.scale3 (2.0 /. float state.winw, 2.0 /. float state.winh, 1.0);
2254 let relx =
2255 if conf.zoom <= 1.0
2256 then 0.0
2257 else float state.x /. float state.w
2259 invalidate "geometry"
2260 (fun () ->
2261 state.w <- w;
2262 if not firsttime
2263 then state.x <- truncate (relx *. float w);
2264 let w =
2265 match conf.columns with
2266 | Csingle _ -> w
2267 | Cmulti ((c, _, _), _) -> (w - (c-1)*conf.interpagespace) / c
2268 | Csplit (c, _) -> w * c
2270 wcmd "geometry %d %d %d"
2271 w (stateh h) (FMTE.to_int conf.fitmodel)
2275 let enttext () =
2276 let len = String.length state.text in
2277 let drawstring s =
2278 let hscrollh =
2279 match state.mode with
2280 | Textentry _ | View | LinkNav _ ->
2281 let h, _, _ = state.uioh#scrollpw in
2283 | _ -> 0
2285 let rect x w =
2286 GlDraw.rect
2287 (x, float (state.winh - (fstate.fontsize + 4) - hscrollh))
2288 (x+.w, float (state.winh - hscrollh))
2291 let w = float (wadjsb state.winw - 1) in
2292 if state.progress >= 0.0 && state.progress < 1.0
2293 then (
2294 GlDraw.color (0.3, 0.3, 0.3);
2295 let w1 = w *. state.progress in
2296 rect 0.0 w1;
2297 GlDraw.color (0.0, 0.0, 0.0);
2298 rect w1 (w-.w1)
2300 else (
2301 GlDraw.color (0.0, 0.0, 0.0);
2302 rect 0.0 w;
2305 GlDraw.color (1.0, 1.0, 1.0);
2306 drawstring fstate.fontsize
2307 (if len > 0 then 8 else 2) (state.winh - hscrollh - 5) s;
2309 let s =
2310 match state.mode with
2311 | Textentry ((prefix, text, _, _, _, _), _) ->
2312 let s =
2313 if len > 0
2314 then
2315 Printf.sprintf "%s%s_ [%s]" prefix text state.text
2316 else
2317 Printf.sprintf "%s%s_" prefix text
2321 | _ -> state.text
2323 let s =
2324 if state.newerrmsgs
2325 then (
2326 if not (istextentry state.mode) && state.uioh#eformsgs
2327 then
2328 let s1 = "(press 'e' to review error messasges)" in
2329 if String.length s > 0 then s ^ " " ^ s1 else s1
2330 else s
2332 else s
2334 if String.length s > 0
2335 then drawstring s
2338 let gctiles () =
2339 let len = Queue.length state.tilelru in
2340 let layout = lazy (
2341 match state.throttle with
2342 | None ->
2343 if conf.preload
2344 then preloadlayout state.y
2345 else state.layout
2346 | Some (layout, _, _) ->
2347 layout
2348 ) in
2349 let rec loop qpos =
2350 if state.memused <= conf.memlimit
2351 then ()
2352 else (
2353 if qpos < len
2354 then
2355 let (k, p, s) as lruitem = Queue.pop state.tilelru in
2356 let n, gen, colorspace, angle, pagew, pageh, col, row = k in
2357 let (_, pw, ph, _) = getpagedim n in
2359 gen = state.gen
2360 && colorspace = conf.colorspace
2361 && angle = conf.angle
2362 && pagew = pw
2363 && pageh = ph
2364 && (
2365 let x = col*conf.tilew
2366 and y = row*conf.tileh in
2367 tilevisible (Lazy.force_val layout) n x y
2369 then Queue.push lruitem state.tilelru
2370 else (
2371 freepbo p;
2372 wcmd "freetile %s" p;
2373 state.memused <- state.memused - s;
2374 state.uioh#infochanged Memused;
2375 Hashtbl.remove state.tilemap k;
2377 loop (qpos+1)
2380 loop 0
2383 let logcurrently = function
2384 | Idle -> dolog "Idle"
2385 | Loading (l, gen) ->
2386 dolog "Loading %d gen=%d curgen=%d" l.pageno gen state.gen
2387 | Tiling (l, pageopaque, colorspace, angle, gen, col, row, tilew, tileh) ->
2388 dolog
2389 "Tiling %d[%d,%d] page=%s cs=%s angle"
2390 l.pageno col row pageopaque
2391 (CSTE.to_string colorspace)
2393 dolog "gen=(%d,%d) (%d,%d) tile=(%d,%d) (%d,%d)"
2394 angle gen conf.angle state.gen
2395 tilew tileh
2396 conf.tilew conf.tileh
2398 | Outlining _ ->
2399 dolog "outlining"
2402 let splitatspace =
2403 let r = Str.regexp " " in
2404 fun s -> Str.bounded_split r s 2;
2407 let onpagerect pageno f =
2408 let b =
2409 match conf.columns with
2410 | Cmulti (_, b) -> b
2411 | Csingle b -> b
2412 | Csplit (_, b) -> b
2414 if pageno >= 0 && pageno < Array.length b
2415 then
2416 let (pdimno, _, _, (_, _, _, _)) = b.(pageno) in
2417 let r = getpdimrect pdimno in
2418 f (r.(1)-.r.(0)) (r.(3)-.r.(2))
2421 let gotopagexy1 pageno x y =
2422 onpagerect pageno (fun w h ->
2423 let top = y /. h in
2424 let _,w1,_,leftx = getpagedim pageno in
2425 let wh = state.winh - hscrollh () in
2426 let sw = float w1 /. w in
2427 let x = sw *. x in
2428 let x = leftx + state.x + truncate x in
2429 let sx =
2430 if x < 0 || x >= wadjsb state.winw
2431 then state.x - x
2432 else state.x
2434 let py, h = getpageyh pageno in
2435 let pdy = truncate (top *. float h) in
2436 let y' = py + pdy in
2437 let dy = y' - state.y in
2438 let sy =
2439 if x != state.x || not (dy > 0 && dy < wh)
2440 then (
2441 if conf.presentation
2442 then
2443 if abs (py - y') > wh
2444 then y'
2445 else py
2446 else y';
2448 else state.y
2450 if state.x != sx || state.y != sy
2451 then (
2452 let x, y =
2453 if !wtmode
2454 then (
2455 let ww = wadjsb state.winw in
2456 let qx = sx / ww
2457 and qy = pdy / wh in
2458 let x = qx * ww
2459 and y = py + qy * wh in
2460 let x = if -x + ww > w1 then -(w1-ww) else x
2461 and y' = if y + wh > state.maxy then state.maxy - wh else y in
2462 let y =
2463 if conf.presentation
2464 then
2465 if abs (py - y') > wh
2466 then y'
2467 else py
2468 else y';
2470 (x, y)
2472 else (sx, sy)
2474 state.x <- x;
2475 gotoy_and_clear_text y;
2477 else gotoy_and_clear_text state.y;
2481 let gotopagexy pageno x y =
2482 match state.mode with
2483 | Birdseye _ -> gotopage pageno 0.0
2484 | _ -> gotopagexy1 pageno x y
2487 let act cmds =
2488 (* dolog "%S" cmds; *)
2489 let cl = splitatspace cmds in
2490 let scan s fmt f =
2491 try Scanf.sscanf s fmt f
2492 with exn ->
2493 dolog "error processing '%S': %s" cmds (exntos exn);
2494 exit 1
2496 match cl with
2497 | "clear" :: [] ->
2498 state.uioh#infochanged Pdim;
2499 state.pdims <- [];
2501 | "clearrects" :: [] ->
2502 state.rects <- state.rects1;
2503 G.postRedisplay "clearrects";
2505 | "continue" :: args :: [] ->
2506 let n = scan args "%u" (fun n -> n) in
2507 state.pagecount <- n;
2508 begin match state.currently with
2509 | Outlining l ->
2510 state.currently <- Idle;
2511 state.outlines <- Array.of_list (List.rev l)
2512 | _ -> ()
2513 end;
2515 let cur, cmds = state.geomcmds in
2516 if String.length cur = 0
2517 then failwith "umpossible";
2519 begin match List.rev cmds with
2520 | [] ->
2521 state.geomcmds <- "", [];
2522 represent ();
2523 | (s, f) :: rest ->
2524 f ();
2525 state.geomcmds <- s, List.rev rest;
2526 end;
2527 if conf.maxwait = None && not !wtmode
2528 then G.postRedisplay "continue";
2530 | "title" :: args :: [] ->
2531 Wsi.settitle args
2533 | "msg" :: args :: [] ->
2534 showtext ' ' args
2536 | "vmsg" :: args :: [] ->
2537 if conf.verbose
2538 then showtext ' ' args
2540 | "emsg" :: args :: [] ->
2541 Buffer.add_string state.errmsgs args;
2542 state.newerrmsgs <- true;
2543 G.postRedisplay "error message"
2545 | "progress" :: args :: [] ->
2546 let progress, text =
2547 scan args "%f %n"
2548 (fun f pos ->
2549 f, String.sub args pos (String.length args - pos))
2551 state.text <- text;
2552 state.progress <- progress;
2553 G.postRedisplay "progress"
2555 | "firstmatch" :: args :: [] ->
2556 let pageno, c, x0, y0, x1, y1, x2, y2, x3, y3 =
2557 scan args "%u %d %f %f %f %f %f %f %f %f"
2558 (fun p c x0 y0 x1 y1 x2 y2 x3 y3 ->
2559 (p, c, x0, y0, x1, y1, x2, y2, x3, y3))
2561 let y = (getpagey pageno) + truncate y0 in
2562 addnav ();
2563 gotoy y;
2564 state.rects1 <- [pageno, c, (x0, y0, x1, y1, x2, y2, x3, y3)]
2566 | "match" :: args :: [] ->
2567 let pageno, c, x0, y0, x1, y1, x2, y2, x3, y3 =
2568 scan args "%u %d %f %f %f %f %f %f %f %f"
2569 (fun p c x0 y0 x1 y1 x2 y2 x3 y3 ->
2570 (p, c, x0, y0, x1, y1, x2, y2, x3, y3))
2572 state.rects1 <-
2573 (pageno, c, (x0, y0, x1, y1, x2, y2, x3, y3)) :: state.rects1
2575 | "page" :: args :: [] ->
2576 let pageopaque, t = scan args "%s %f" (fun p t -> p, t) in
2577 begin match state.currently with
2578 | Loading (l, gen) ->
2579 vlog "page %d took %f sec" l.pageno t;
2580 Hashtbl.replace state.pagemap (l.pageno, gen) pageopaque;
2581 begin match state.throttle with
2582 | None ->
2583 let preloadedpages =
2584 if conf.preload
2585 then preloadlayout state.y
2586 else state.layout
2588 let evict () =
2589 let set =
2590 List.fold_left (fun s l -> IntSet.add l.pageno s)
2591 IntSet.empty preloadedpages
2593 let evictedpages =
2594 Hashtbl.fold (fun ((pageno, _) as key) opaque accu ->
2595 if not (IntSet.mem pageno set)
2596 then (
2597 wcmd "freepage %s" opaque;
2598 key :: accu
2600 else accu
2601 ) state.pagemap []
2603 List.iter (Hashtbl.remove state.pagemap) evictedpages;
2605 evict ();
2606 state.currently <- Idle;
2607 if gen = state.gen
2608 then (
2609 tilepage l.pageno pageopaque state.layout;
2610 load state.layout;
2611 load preloadedpages;
2612 if pagevisible state.layout l.pageno
2613 && layoutready state.layout
2614 then G.postRedisplay "page";
2617 | Some (layout, _, _) ->
2618 state.currently <- Idle;
2619 tilepage l.pageno pageopaque layout;
2620 load state.layout
2621 end;
2623 | _ ->
2624 dolog "Inconsistent loading state";
2625 logcurrently state.currently;
2626 exit 1
2629 | "tile" :: args :: [] ->
2630 let (x, y, opaque, size, t) =
2631 scan args "%u %u %s %u %f"
2632 (fun x y p size t -> (x, y, p, size, t))
2634 begin match state.currently with
2635 | Tiling (l, pageopaque, cs, angle, gen, col, row, tilew, tileh) ->
2636 vlog "tile %d [%d,%d] took %f sec" l.pageno col row t;
2638 unmappbo opaque;
2639 if tilew != conf.tilew || tileh != conf.tileh
2640 then (
2641 wcmd "freetile %s" opaque;
2642 state.currently <- Idle;
2643 load state.layout;
2645 else (
2646 puttileopaque l col row gen cs angle opaque size t;
2647 state.memused <- state.memused + size;
2648 state.uioh#infochanged Memused;
2649 gctiles ();
2650 Queue.push ((l.pageno, gen, cs, angle, l.pagew, l.pageh, col, row),
2651 opaque, size) state.tilelru;
2653 let layout =
2654 match state.throttle with
2655 | None -> state.layout
2656 | Some (layout, _, _) -> layout
2659 state.currently <- Idle;
2660 if gen = state.gen
2661 && conf.colorspace = cs
2662 && conf.angle = angle
2663 && tilevisible layout l.pageno x y
2664 then conttiling l.pageno pageopaque;
2666 begin match state.throttle with
2667 | None ->
2668 preload state.layout;
2669 if gen = state.gen
2670 && conf.colorspace = cs
2671 && conf.angle = angle
2672 && tilevisible state.layout l.pageno x y
2673 && (not !wtmode || layoutready state.layout)
2674 then G.postRedisplay "tile nothrottle";
2676 | Some (layout, y, _) ->
2677 let ready = layoutready layout in
2678 if ready
2679 then (
2680 state.y <- y;
2681 state.layout <- layout;
2682 state.throttle <- None;
2683 G.postRedisplay "throttle";
2685 else load layout;
2686 end;
2689 | _ ->
2690 dolog "Inconsistent tiling state";
2691 logcurrently state.currently;
2692 exit 1
2695 | "pdim" :: args :: [] ->
2696 let (n, w, h, _) as pdim =
2697 scan args "%u %u %u %u" (fun n w h x -> n, w, h, x)
2699 let pdim =
2700 match conf.fitmodel, conf.columns with
2701 | (FitPage | FitProportional), Csplit _ -> (n, w, h, 0)
2702 | _ -> pdim
2704 state.uioh#infochanged Pdim;
2705 state.pdims <- pdim :: state.pdims
2707 | "o" :: args :: [] ->
2708 let (l, n, t, h, pos) =
2709 scan args "%u %u %d %u %n"
2710 (fun l n t h pos -> l, n, t, h, pos)
2712 let s = String.sub args pos (String.length args - pos) in
2713 let outline = (s, l, (n, float t /. float h, 0.0)) in
2714 begin match state.currently with
2715 | Outlining outlines ->
2716 state.currently <- Outlining (outline :: outlines)
2717 | Idle ->
2718 state.currently <- Outlining [outline]
2719 | currently ->
2720 dolog "invalid outlining state";
2721 logcurrently currently
2724 | "a" :: args :: [] ->
2725 let (n, l, t) =
2726 scan args "%u %d %d" (fun n l t -> n, l, t)
2728 state.reprf <- (fun () -> gotopagexy n (float l) (float t))
2730 | "info" :: args :: [] ->
2731 state.docinfo <- (1, args) :: state.docinfo
2733 | "infoend" :: [] ->
2734 state.uioh#infochanged Docinfo;
2735 state.docinfo <- List.rev state.docinfo
2737 | _ ->
2738 failwith (Printf.sprintf "unknown cmd `%S'" cmds)
2741 let onhist cb =
2742 let rc = cb.rc in
2743 let action = function
2744 | HCprev -> cbget cb ~-1
2745 | HCnext -> cbget cb 1
2746 | HCfirst -> cbget cb ~-(cb.rc)
2747 | HClast -> cbget cb (cb.len - 1 - cb.rc)
2748 and cancel () = cb.rc <- rc
2749 in (action, cancel)
2752 let search pattern forward =
2753 match conf.columns with
2754 | Csplit _ ->
2755 showtext '!' "searching does not work properly in split columns mode"
2756 | _ ->
2757 if String.length pattern > 0
2758 then
2759 let pn, py =
2760 match state.layout with
2761 | [] -> 0, 0
2762 | l :: _ ->
2763 l.pageno, (l.pagey + if forward then 0 else 0*l.pagevh)
2765 wcmd "search %d %d %d %d,%s\000"
2766 (btod conf.icase) pn py (btod forward) pattern;
2769 let intentry text key =
2770 let c =
2771 if key >= 32 && key < 127
2772 then Char.chr key
2773 else '\000'
2775 match c with
2776 | '0' .. '9' ->
2777 let text = addchar text c in
2778 TEcont text
2780 | _ ->
2781 state.text <- Printf.sprintf "invalid char (%d, `%c')" key c;
2782 TEcont text
2785 let linknentry text key =
2786 let c =
2787 if key >= 32 && key < 127
2788 then Char.chr key
2789 else '\000'
2791 match c with
2792 | 'a' .. 'z' ->
2793 let text = addchar text c in
2794 TEcont text
2796 | _ ->
2797 state.text <- Printf.sprintf "invalid char (%d, `%c')" key c;
2798 TEcont text
2801 let linkndone f s =
2802 if String.length s > 0
2803 then (
2804 let n =
2805 let l = String.length s in
2806 let rec loop pos n = if pos = l then n else
2807 let m = Char.code s.[pos] - (if pos = 0 && l > 1 then 96 else 97) in
2808 loop (pos+1) (n*26 + m)
2809 in loop 0 0
2811 let rec loop n = function
2812 | [] -> ()
2813 | l :: rest ->
2814 match getopaque l.pageno with
2815 | None -> loop n rest
2816 | Some opaque ->
2817 let m = getlinkcount opaque in
2818 if n < m
2819 then (
2820 let under = getlink opaque n in
2821 f under
2823 else loop (n-m) rest
2825 loop n state.layout;
2829 let textentry text key =
2830 if key land 0xff00 = 0xff00
2831 then TEcont text
2832 else TEcont (text ^ toutf8 key)
2835 let reqlayout angle fitmodel =
2836 match state.throttle with
2837 | None ->
2838 if nogeomcmds state.geomcmds
2839 then state.anchor <- getanchor ();
2840 conf.angle <- angle mod 360;
2841 if conf.angle != 0
2842 then (
2843 match state.mode with
2844 | LinkNav _ -> state.mode <- View
2845 | _ -> ()
2847 conf.fitmodel <- fitmodel;
2848 invalidate "reqlayout"
2849 (fun () ->
2850 wcmd "reqlayout %d %d %d"
2851 conf.angle (FMTE.to_int conf.fitmodel) (stateh state.winh)
2853 | _ -> ()
2856 let settrim trimmargins trimfuzz =
2857 if nogeomcmds state.geomcmds
2858 then state.anchor <- getanchor ();
2859 conf.trimmargins <- trimmargins;
2860 conf.trimfuzz <- trimfuzz;
2861 let x0, y0, x1, y1 = trimfuzz in
2862 invalidate "settrim"
2863 (fun () ->
2864 wcmd "settrim %d %d %d %d %d" (btod conf.trimmargins) x0 y0 x1 y1);
2865 flushpages ();
2868 let setzoom zoom =
2869 match state.throttle with
2870 | None ->
2871 let zoom = max 0.0001 zoom in
2872 if zoom <> conf.zoom
2873 then (
2874 state.prevzoom <- conf.zoom;
2875 conf.zoom <- zoom;
2876 reshape state.winw state.winh;
2877 state.text <- Printf.sprintf "zoom is now %-5.2f" (zoom *. 100.0);
2880 | Some (layout, y, started) ->
2881 let time =
2882 match conf.maxwait with
2883 | None -> 0.0
2884 | Some t -> t
2886 let dt = now () -. started in
2887 if dt > time
2888 then (
2889 state.y <- y;
2890 load layout;
2894 let setcolumns mode columns coverA coverB =
2895 state.prevcolumns <- Some (conf.columns, conf.zoom);
2896 if columns < 0
2897 then (
2898 if isbirdseye mode
2899 then showtext '!' "split mode doesn't work in bird's eye"
2900 else (
2901 conf.columns <- Csplit (-columns, [||]);
2902 state.x <- 0;
2903 conf.zoom <- 1.0;
2906 else (
2907 if columns < 2
2908 then (
2909 conf.columns <- Csingle [||];
2910 state.x <- 0;
2911 setzoom 1.0;
2913 else (
2914 conf.columns <- Cmulti ((columns, coverA, coverB), [||]);
2915 conf.zoom <- 1.0;
2918 reshape state.winw state.winh;
2921 let enterbirdseye () =
2922 let zoom = float conf.thumbw /. float state.winw in
2923 let birdseyepageno =
2924 let cy = state.winh / 2 in
2925 let fold = function
2926 | [] -> 0
2927 | l :: rest ->
2928 let rec fold best = function
2929 | [] -> best.pageno
2930 | l :: rest ->
2931 let d = cy - (l.pagedispy + l.pagevh/2)
2932 and dbest = cy - (best.pagedispy + best.pagevh/2) in
2933 if abs d < abs dbest
2934 then fold l rest
2935 else best.pageno
2936 in fold l rest
2938 fold state.layout
2940 state.mode <- Birdseye (
2941 { conf with zoom = conf.zoom }, state.x, birdseyepageno, -1, getanchor ()
2943 conf.zoom <- zoom;
2944 conf.presentation <- false;
2945 conf.interpagespace <- 10;
2946 conf.hlinks <- false;
2947 conf.fitmodel <- FitProportional;
2948 state.x <- 0;
2949 state.mstate <- Mnone;
2950 conf.maxwait <- None;
2951 conf.columns <- (
2952 match conf.beyecolumns with
2953 | Some c ->
2954 conf.zoom <- 1.0;
2955 Cmulti ((c, 0, 0), [||])
2956 | None -> Csingle [||]
2958 Wsi.setcursor Wsi.CURSOR_INHERIT;
2959 if conf.verbose
2960 then
2961 state.text <- Printf.sprintf "birds eye mode on (zoom %3.1f%%)"
2962 (100.0*.zoom)
2963 else
2964 state.text <- ""
2966 reshape state.winw state.winh;
2969 let leavebirdseye (c, leftx, pageno, _, anchor) goback =
2970 state.mode <- View;
2971 conf.zoom <- c.zoom;
2972 conf.presentation <- c.presentation;
2973 conf.interpagespace <- c.interpagespace;
2974 conf.maxwait <- c.maxwait;
2975 conf.hlinks <- c.hlinks;
2976 conf.fitmodel <- c.fitmodel;
2977 conf.beyecolumns <- (
2978 match conf.columns with
2979 | Cmulti ((c, _, _), _) -> Some c
2980 | Csingle _ -> None
2981 | Csplit _ -> failwith "leaving bird's eye split mode"
2983 conf.columns <- (
2984 match c.columns with
2985 | Cmulti (c, _) -> Cmulti (c, [||])
2986 | Csingle _ -> Csingle [||]
2987 | Csplit (c, _) -> Csplit (c, [||])
2989 state.x <- leftx;
2990 if conf.verbose
2991 then
2992 state.text <- Printf.sprintf "birds eye mode off (zoom %3.1f%%)"
2993 (100.0*.conf.zoom)
2995 reshape state.winw state.winh;
2996 state.anchor <- if goback then anchor else (pageno, 0.0, 1.0);
2999 let togglebirdseye () =
3000 match state.mode with
3001 | Birdseye vals -> leavebirdseye vals true
3002 | View -> enterbirdseye ()
3003 | _ -> ()
3006 let upbirdseye incr (conf, leftx, pageno, hooverpageno, anchor) =
3007 let pageno = max 0 (pageno - incr) in
3008 let rec loop = function
3009 | [] -> gotopage1 pageno 0
3010 | l :: _ when l.pageno = pageno ->
3011 if l.pagedispy >= 0 && l.pagey = 0
3012 then G.postRedisplay "upbirdseye"
3013 else gotopage1 pageno 0
3014 | _ :: rest -> loop rest
3016 loop state.layout;
3017 state.mode <- Birdseye (conf, leftx, pageno, hooverpageno, anchor)
3020 let downbirdseye incr (conf, leftx, pageno, hooverpageno, anchor) =
3021 let pageno = min (state.pagecount - 1) (pageno + incr) in
3022 state.mode <- Birdseye (conf, leftx, pageno, hooverpageno, anchor);
3023 let rec loop = function
3024 | [] ->
3025 let y, h = getpageyh pageno in
3026 let dy = (y - state.y) - (state.winh - h - conf.interpagespace) in
3027 gotoy (clamp dy)
3028 | l :: _ when l.pageno = pageno ->
3029 if l.pagevh != l.pageh
3030 then gotoy (clamp (l.pageh - l.pagevh + conf.interpagespace))
3031 else G.postRedisplay "downbirdseye"
3032 | _ :: rest -> loop rest
3034 loop state.layout
3037 let optentry mode _ key =
3038 let btos b = if b then "on" else "off" in
3039 if key >= 32 && key < 127
3040 then
3041 let c = Char.chr key in
3042 match c with
3043 | 's' ->
3044 let ondone s =
3045 try conf.scrollstep <- int_of_string s with exc ->
3046 state.text <- Printf.sprintf "bad integer `%s': %s" s (exntos exc)
3048 TEswitch ("scroll step: ", "", None, intentry, ondone, true)
3050 | 'A' ->
3051 let ondone s =
3053 conf.autoscrollstep <- int_of_string s;
3054 if state.autoscroll <> None
3055 then state.autoscroll <- Some conf.autoscrollstep
3056 with exc ->
3057 state.text <- Printf.sprintf "bad integer `%s': %s" s (exntos exc)
3059 TEswitch ("auto scroll step: ", "", None, intentry, ondone, true)
3061 | 'C' ->
3062 let ondone s =
3064 let n, a, b = multicolumns_of_string s in
3065 setcolumns mode n a b;
3066 with exc ->
3067 state.text <- Printf.sprintf "bad columns `%s': %s" s (exntos exc)
3069 TEswitch ("columns: ", "", None, textentry, ondone, true)
3071 | 'Z' ->
3072 let ondone s =
3074 let zoom = float (int_of_string s) /. 100.0 in
3075 setzoom zoom
3076 with exc ->
3077 state.text <- Printf.sprintf "bad integer `%s': %s" s (exntos exc)
3079 TEswitch ("zoom: ", "", None, intentry, ondone, true)
3081 | 't' ->
3082 let ondone s =
3084 conf.thumbw <- bound (int_of_string s) 2 4096;
3085 state.text <-
3086 Printf.sprintf "thumbnail width is set to %d" conf.thumbw;
3087 begin match mode with
3088 | Birdseye beye ->
3089 leavebirdseye beye false;
3090 enterbirdseye ();
3091 | _ -> ();
3093 with exc ->
3094 state.text <- Printf.sprintf "bad integer `%s': %s" s (exntos exc)
3096 TEswitch ("thumbnail width: ", "", None, intentry, ondone, true)
3098 | 'R' ->
3099 let ondone s =
3100 match try
3101 Some (int_of_string s)
3102 with exc ->
3103 state.text <- Printf.sprintf "bad integer `%s': %s"
3104 s (exntos exc);
3105 None
3106 with
3107 | Some angle -> reqlayout angle conf.fitmodel
3108 | None -> ()
3110 TEswitch ("rotation: ", "", None, intentry, ondone, true)
3112 | 'i' ->
3113 conf.icase <- not conf.icase;
3114 TEdone ("case insensitive search " ^ (btos conf.icase))
3116 | 'p' ->
3117 conf.preload <- not conf.preload;
3118 gotoy state.y;
3119 TEdone ("preload " ^ (btos conf.preload))
3121 | 'v' ->
3122 conf.verbose <- not conf.verbose;
3123 TEdone ("verbose " ^ (btos conf.verbose))
3125 | 'd' ->
3126 conf.debug <- not conf.debug;
3127 TEdone ("debug " ^ (btos conf.debug))
3129 | 'h' ->
3130 conf.maxhfit <- not conf.maxhfit;
3131 state.maxy <- calcheight ();
3132 TEdone ("maxhfit " ^ (btos conf.maxhfit))
3134 | 'c' ->
3135 conf.crophack <- not conf.crophack;
3136 TEdone ("crophack " ^ btos conf.crophack)
3138 | 'a' ->
3139 let s =
3140 match conf.maxwait with
3141 | None ->
3142 conf.maxwait <- Some infinity;
3143 "always wait for page to complete"
3144 | Some _ ->
3145 conf.maxwait <- None;
3146 "show placeholder if page is not ready"
3148 TEdone s
3150 | 'f' ->
3151 conf.underinfo <- not conf.underinfo;
3152 TEdone ("underinfo " ^ btos conf.underinfo)
3154 | 'P' ->
3155 conf.savebmarks <- not conf.savebmarks;
3156 TEdone ("persistent bookmarks " ^ btos conf.savebmarks)
3158 | 'S' ->
3159 let ondone s =
3161 let pageno, py =
3162 match state.layout with
3163 | [] -> 0, 0
3164 | l :: _ ->
3165 l.pageno, l.pagey
3167 conf.interpagespace <- int_of_string s;
3168 docolumns conf.columns;
3169 state.maxy <- calcheight ();
3170 let y = getpagey pageno in
3171 gotoy (y + py)
3172 with exc ->
3173 state.text <- Printf.sprintf "bad integer `%s': %s" s (exntos exc)
3175 TEswitch ("vertical margin: ", "", None, intentry, ondone, true)
3177 | 'l' ->
3178 let fm =
3179 match conf.fitmodel with
3180 | FitProportional -> FitWidth
3181 | _ -> FitProportional
3183 reqlayout conf.angle fm;
3184 TEdone ("proportional display " ^ btos (fm == FitProportional))
3186 | 'T' ->
3187 settrim (not conf.trimmargins) conf.trimfuzz;
3188 TEdone ("trim margins " ^ btos conf.trimmargins)
3190 | 'I' ->
3191 conf.invert <- not conf.invert;
3192 TEdone ("invert colors " ^ btos conf.invert)
3194 | 'x' ->
3195 let ondone s =
3196 cbput state.hists.sel s;
3197 conf.selcmd <- s;
3199 TEswitch ("selection command: ", "", Some (onhist state.hists.sel),
3200 textentry, ondone, true)
3202 | 'M' ->
3203 if conf.pax == None
3204 then conf.pax <- Some (ref (0.0, 0, 0))
3205 else conf.pax <- None;
3206 TEdone ("PAX " ^ btos (conf.pax != None))
3208 | _ ->
3209 state.text <- Printf.sprintf "bad option %d `%c'" key c;
3210 TEstop
3211 else
3212 TEcont state.text
3215 class type lvsource = object
3216 method getitemcount : int
3217 method getitem : int -> (string * int)
3218 method hasaction : int -> bool
3219 method exit :
3220 uioh:uioh ->
3221 cancel:bool ->
3222 active:int ->
3223 first:int ->
3224 pan:int ->
3225 qsearch:string ->
3226 uioh option
3227 method getactive : int
3228 method getfirst : int
3229 method getqsearch : string
3230 method setqsearch : string -> unit
3231 method getpan : int
3232 end;;
3234 class virtual lvsourcebase = object
3235 val mutable m_active = 0
3236 val mutable m_first = 0
3237 val mutable m_qsearch = ""
3238 val mutable m_pan = 0
3239 method getactive = m_active
3240 method getfirst = m_first
3241 method getqsearch = m_qsearch
3242 method getpan = m_pan
3243 method setqsearch s = m_qsearch <- s
3244 end;;
3246 let withoutlastutf8 s =
3247 let len = String.length s in
3248 if len = 0
3249 then s
3250 else
3251 let rec find pos =
3252 if pos = 0
3253 then pos
3254 else
3255 let b = Char.code s.[pos] in
3256 if b land 0b11000000 = 0b11000000
3257 then pos
3258 else find (pos-1)
3260 let first =
3261 if Char.code s.[len-1] land 0x80 = 0
3262 then len-1
3263 else find (len-1)
3265 String.sub s 0 first;
3268 let textentrykeyboard
3269 key _mask ((c, text, opthist, onkey, ondone, cancelonempty), onleave) =
3270 let key =
3271 if key >= 0xffb0 && key <= 0xffb9
3272 then key - 0xffb0 + 48 else key
3274 let enttext te =
3275 state.mode <- Textentry (te, onleave);
3276 state.text <- "";
3277 enttext ();
3278 G.postRedisplay "textentrykeyboard enttext";
3280 let histaction cmd =
3281 match opthist with
3282 | None -> ()
3283 | Some (action, _) ->
3284 state.mode <- Textentry (
3285 (c, action cmd, opthist, onkey, ondone, cancelonempty), onleave
3287 G.postRedisplay "textentry histaction"
3289 match key with
3290 | 0xff08 -> (* backspace *)
3291 let s = withoutlastutf8 text in
3292 let len = String.length s in
3293 if cancelonempty && len = 0
3294 then (
3295 onleave Cancel;
3296 G.postRedisplay "textentrykeyboard after cancel";
3298 else (
3299 enttext (c, s, opthist, onkey, ondone, cancelonempty)
3302 | 0xff0d | 0xff8d -> (* (kp) enter *)
3303 ondone text;
3304 onleave Confirm;
3305 G.postRedisplay "textentrykeyboard after confirm"
3307 | 0xff52 | 0xff97 -> histaction HCprev (* (kp) up *)
3308 | 0xff54 | 0xff99 -> histaction HCnext (* (kp) down *)
3309 | 0xff50 | 0xff95 -> histaction HCfirst (* (kp) home) *)
3310 | 0xff57 | 0xff9c -> histaction HClast (* (kp) end *)
3312 | 0xff1b -> (* escape*)
3313 if String.length text = 0
3314 then (
3315 begin match opthist with
3316 | None -> ()
3317 | Some (_, onhistcancel) -> onhistcancel ()
3318 end;
3319 onleave Cancel;
3320 state.text <- "";
3321 G.postRedisplay "textentrykeyboard after cancel2"
3323 else (
3324 enttext (c, "", opthist, onkey, ondone, cancelonempty)
3327 | 0xff9f | 0xffff -> () (* delete *)
3329 | _ when key != 0
3330 && key land 0xff00 != 0xff00 (* keyboard *)
3331 && key land 0xfe00 != 0xfe00 (* xkb *)
3332 && key land 0xfd00 != 0xfd00 (* 3270 *)
3334 begin match onkey text key with
3335 | TEdone text ->
3336 ondone text;
3337 onleave Confirm;
3338 G.postRedisplay "textentrykeyboard after confirm2";
3340 | TEcont text ->
3341 enttext (c, text, opthist, onkey, ondone, cancelonempty);
3343 | TEstop ->
3344 onleave Cancel;
3345 G.postRedisplay "textentrykeyboard after cancel3"
3347 | TEswitch te ->
3348 state.mode <- Textentry (te, onleave);
3349 G.postRedisplay "textentrykeyboard switch";
3350 end;
3352 | _ ->
3353 vlog "unhandled key %s" (Wsi.keyname key)
3356 let firstof first active =
3357 if first > active || abs (first - active) > fstate.maxrows - 1
3358 then max 0 (active - (fstate.maxrows/2))
3359 else first
3362 let calcfirst first active =
3363 if active > first
3364 then
3365 let rows = active - first in
3366 if rows > fstate.maxrows then active - fstate.maxrows else first
3367 else active
3370 let scrollph y maxy =
3371 let sh = float (maxy + state.winh) /. float state.winh in
3372 let sh = float state.winh /. sh in
3373 let sh = max sh (float conf.scrollh) in
3375 let percent = float y /. float maxy in
3376 let position = (float state.winh -. sh) *. percent in
3378 let position =
3379 if position +. sh > float state.winh
3380 then float state.winh -. sh
3381 else position
3383 position, sh;
3386 let coe s = (s :> uioh);;
3388 class listview ~(source:lvsource) ~trusted ~modehash =
3389 object (self)
3390 val m_pan = source#getpan
3391 val m_first = source#getfirst
3392 val m_active = source#getactive
3393 val m_qsearch = source#getqsearch
3394 val m_prev_uioh = state.uioh
3396 method private elemunder y =
3397 let n = y / (fstate.fontsize+1) in
3398 if m_first + n < source#getitemcount
3399 then (
3400 if source#hasaction (m_first + n)
3401 then Some (m_first + n)
3402 else None
3404 else None
3406 method display =
3407 Gl.enable `blend;
3408 GlFunc.blend_func `src_alpha `one_minus_src_alpha;
3409 GlDraw.color (0., 0., 0.) ~alpha:0.85;
3410 GlDraw.rect (0., 0.) (float state.winw, float state.winh);
3411 GlDraw.color (1., 1., 1.);
3412 Gl.enable `texture_2d;
3413 let fs = fstate.fontsize in
3414 let nfs = fs + 1 in
3415 let ww = fstate.wwidth in
3416 let tabw = 30.0*.ww in
3417 let itemcount = source#getitemcount in
3418 let rec loop row =
3419 if (row - m_first) > fstate.maxrows
3420 then ()
3421 else (
3422 if row >= 0 && row < itemcount
3423 then (
3424 let (s, level) = source#getitem row in
3425 let y = (row - m_first) * nfs in
3426 let x = 5.0 +. float (level + m_pan) *. ww in
3427 if row = m_active
3428 then (
3429 Gl.disable `texture_2d;
3430 GlDraw.polygon_mode `both `line;
3431 let alpha = if source#hasaction row then 0.9 else 0.3 in
3432 GlDraw.color (1., 1., 1.) ~alpha;
3433 GlDraw.rect (1., float (y + 1))
3434 (float (state.winw - conf.scrollbw - 1), float (y + fs + 3));
3435 GlDraw.polygon_mode `both `fill;
3436 GlDraw.color (1., 1., 1.);
3437 Gl.enable `texture_2d;
3440 let drawtabularstring s =
3441 let drawstr x s = drawstring1 fs (truncate x) (y+nfs) s in
3442 if trusted
3443 then
3444 let tabpos = try String.index s '\t' with Not_found -> -1 in
3445 if tabpos > 0
3446 then
3447 let len = String.length s - tabpos - 1 in
3448 let s1 = String.sub s 0 tabpos
3449 and s2 = String.sub s (tabpos + 1) len in
3450 let nx = drawstr x s1 in
3451 let sw = nx -. x in
3452 let x = x +. (max tabw sw) in
3453 drawstr x s2
3454 else
3455 drawstr x s
3456 else
3457 drawstr x s
3459 let _ = drawtabularstring s in
3460 loop (row+1)
3464 loop m_first;
3465 Gl.disable `blend;
3466 Gl.disable `texture_2d;
3468 method updownlevel incr =
3469 let len = source#getitemcount in
3470 let curlevel =
3471 if m_active >= 0 && m_active < len
3472 then snd (source#getitem m_active)
3473 else -1
3475 let rec flow i =
3476 if i = len then i-1 else if i = -1 then 0 else
3477 let _, l = source#getitem i in
3478 if l != curlevel then i else flow (i+incr)
3480 let active = flow m_active in
3481 let first = calcfirst m_first active in
3482 G.postRedisplay "outline updownlevel";
3483 {< m_active = active; m_first = first >}
3485 method private key1 key mask =
3486 let set1 active first qsearch =
3487 coe {< m_active = active; m_first = first; m_qsearch = qsearch >}
3489 let search active pattern incr =
3490 let active = if active = -1 then m_first else active in
3491 let dosearch re =
3492 let rec loop n =
3493 if n >= 0 && n < source#getitemcount
3494 then (
3495 let s, _ = source#getitem n in
3497 (try ignore (Str.search_forward re s 0); true
3498 with Not_found -> false)
3499 then Some n
3500 else loop (n + incr)
3502 else None
3504 loop active
3507 let re = Str.regexp_case_fold pattern in
3508 dosearch re
3509 with Failure s ->
3510 state.text <- s;
3511 None
3513 let itemcount = source#getitemcount in
3514 let find start incr =
3515 let rec find i =
3516 if i = -1 || i = itemcount
3517 then -1
3518 else (
3519 if source#hasaction i
3520 then i
3521 else find (i + incr)
3524 find start
3526 let set active first =
3527 let first = bound first 0 (itemcount - fstate.maxrows) in
3528 state.text <- "";
3529 coe {< m_active = active; m_first = first; m_qsearch = "" >}
3531 let navigate incr =
3532 let isvisible first n = n >= first && n - first <= fstate.maxrows in
3533 let active, first =
3534 let incr1 = if incr > 0 then 1 else -1 in
3535 if isvisible m_first m_active
3536 then
3537 let next =
3538 let next = m_active + incr in
3539 let next =
3540 if next < 0 || next >= itemcount
3541 then -1
3542 else find next incr1
3544 if abs (m_active - next) > fstate.maxrows
3545 then -1
3546 else next
3548 if next = -1
3549 then
3550 let first = m_first + incr in
3551 let first = bound first 0 (itemcount - fstate.maxrows) in
3552 let next =
3553 let next = m_active + incr in
3554 let next = bound next 0 (itemcount - 1) in
3555 find next ~-incr1
3557 let active =
3558 if next = -1
3559 then m_active
3560 else (
3561 if isvisible first next
3562 then next
3563 else m_active
3566 active, first
3567 else
3568 let first = min next m_first in
3569 let first =
3570 if abs (next - first) > fstate.maxrows
3571 then first + incr
3572 else first
3574 next, first
3575 else
3576 let first = m_first + incr in
3577 let first = bound first 0 (itemcount - 1) in
3578 let active =
3579 let next = m_active + incr in
3580 let next = bound next 0 (itemcount - 1) in
3581 let next = find next incr1 in
3582 let active =
3583 if next = -1 || abs (m_active - first) > fstate.maxrows
3584 then (
3585 let active = if m_active = -1 then next else m_active in
3586 active
3588 else next
3590 if isvisible first active
3591 then active
3592 else -1
3594 active, first
3596 G.postRedisplay "listview navigate";
3597 set active first;
3599 match key with
3600 | (0x72|0x73) when Wsi.withctrl mask -> (* ctrl-r/ctlr-s *)
3601 let incr = if key = 0x72 then -1 else 1 in
3602 let active, first =
3603 match search (m_active + incr) m_qsearch incr with
3604 | None ->
3605 state.text <- m_qsearch ^ " [not found]";
3606 m_active, m_first
3607 | Some active ->
3608 state.text <- m_qsearch;
3609 active, firstof m_first active
3611 G.postRedisplay "listview ctrl-r/s";
3612 set1 active first m_qsearch;
3614 | 0xff63 when Wsi.withctrl mask -> (* ctrl-insert *)
3615 if m_active >= 0 && m_active < source#getitemcount
3616 then (
3617 let s, _ = source#getitem m_active in
3618 selstring s;
3620 coe self
3622 | 0xff08 -> (* backspace *)
3623 if String.length m_qsearch = 0
3624 then coe self
3625 else (
3626 let qsearch = withoutlastutf8 m_qsearch in
3627 let len = String.length qsearch in
3628 if len = 0
3629 then (
3630 state.text <- "";
3631 G.postRedisplay "listview empty qsearch";
3632 set1 m_active m_first "";
3634 else
3635 let active, first =
3636 match search m_active qsearch ~-1 with
3637 | None ->
3638 state.text <- qsearch ^ " [not found]";
3639 m_active, m_first
3640 | Some active ->
3641 state.text <- qsearch;
3642 active, firstof m_first active
3644 G.postRedisplay "listview backspace qsearch";
3645 set1 active first qsearch
3648 | key when (key != 0 && key land 0xff00 != 0xff00) ->
3649 let pattern = m_qsearch ^ toutf8 key in
3650 let active, first =
3651 match search m_active pattern 1 with
3652 | None ->
3653 state.text <- pattern ^ " [not found]";
3654 m_active, m_first
3655 | Some active ->
3656 state.text <- pattern;
3657 active, firstof m_first active
3659 G.postRedisplay "listview qsearch add";
3660 set1 active first pattern;
3662 | 0xff1b -> (* escape *)
3663 state.text <- "";
3664 if String.length m_qsearch = 0
3665 then (
3666 G.postRedisplay "list view escape";
3667 begin
3668 match
3669 source#exit (coe self) true m_active m_first m_pan m_qsearch
3670 with
3671 | None -> m_prev_uioh
3672 | Some uioh -> uioh
3675 else (
3676 G.postRedisplay "list view kill qsearch";
3677 source#setqsearch "";
3678 coe {< m_qsearch = "" >}
3681 | 0xff0d | 0xff8d -> (* (kp) enter *)
3682 state.text <- "";
3683 let self = {< m_qsearch = "" >} in
3684 source#setqsearch "";
3685 let opt =
3686 G.postRedisplay "listview enter";
3687 if m_active >= 0 && m_active < source#getitemcount
3688 then (
3689 source#exit (coe self) false m_active m_first m_pan "";
3691 else (
3692 source#exit (coe self) true m_active m_first m_pan "";
3695 begin match opt with
3696 | None -> m_prev_uioh
3697 | Some uioh -> uioh
3700 | 0xff9f | 0xffff -> (* (kp) delete *)
3701 coe self
3703 | 0xff52 | 0xff97 -> navigate ~-1 (* (kp) up *)
3704 | 0xff54 | 0xff99 -> navigate 1 (* (kp) down *)
3705 | 0xff55 | 0xff9a -> navigate ~-(fstate.maxrows) (* (kp) prior *)
3706 | 0xff56 | 0xff9b -> navigate fstate.maxrows (* (kp) next *)
3708 | 0xff53 | 0xff98 -> (* (kp) right *)
3709 state.text <- "";
3710 G.postRedisplay "listview right";
3711 coe {< m_pan = m_pan - 1 >}
3713 | 0xff51 | 0xff96 -> (* (kp) left *)
3714 state.text <- "";
3715 G.postRedisplay "listview left";
3716 coe {< m_pan = m_pan + 1 >}
3718 | 0xff50 | 0xff95 -> (* (kp) home *)
3719 let active = find 0 1 in
3720 G.postRedisplay "listview home";
3721 set active 0;
3723 | 0xff57 | 0xff9c -> (* (kp) end *)
3724 let first = max 0 (itemcount - fstate.maxrows) in
3725 let active = find (itemcount - 1) ~-1 in
3726 G.postRedisplay "listview end";
3727 set active first;
3729 | key when (key = 0 || key land 0xff00 = 0xff00) ->
3730 coe self
3732 | _ ->
3733 dolog "listview unknown key %#x" key; coe self
3735 method key key mask =
3736 match state.mode with
3737 | Textentry te -> textentrykeyboard key mask te; coe self
3738 | _ -> self#key1 key mask
3740 method button button down x y _ =
3741 let opt =
3742 match button with
3743 | 1 when x > state.winw - conf.scrollbw ->
3744 G.postRedisplay "listview scroll";
3745 if down
3746 then
3747 let _, position, sh = self#scrollph in
3748 if y > truncate position && y < truncate (position +. sh)
3749 then (
3750 state.mstate <- Mscrolly;
3751 Some (coe self)
3753 else
3754 let s = float (max 0 (y - conf.scrollh)) /. float state.winh in
3755 let first = truncate (s *. float source#getitemcount) in
3756 let first = min source#getitemcount first in
3757 Some (coe {< m_first = first; m_active = first >})
3758 else (
3759 state.mstate <- Mnone;
3760 Some (coe self);
3762 | 1 when not down ->
3763 begin match self#elemunder y with
3764 | Some n ->
3765 G.postRedisplay "listview click";
3766 source#exit
3767 (coe {< m_active = n >}) false n m_first m_pan m_qsearch
3768 | _ ->
3769 Some (coe self)
3771 | n when (n == 4 || n == 5) && not down ->
3772 let len = source#getitemcount in
3773 let first =
3774 if n = 5 && m_first + fstate.maxrows >= len
3775 then
3776 m_first
3777 else
3778 let first = m_first + (if n == 4 then -1 else 1) in
3779 bound first 0 (len - 1)
3781 G.postRedisplay "listview wheel";
3782 Some (coe {< m_first = first >})
3783 | n when (n = 6 || n = 7) && not down ->
3784 let inc = m_first + (if n = 7 then -1 else 1) in
3785 G.postRedisplay "listview hwheel";
3786 Some (coe {< m_pan = m_pan + inc >})
3787 | _ ->
3788 Some (coe self)
3790 match opt with
3791 | None -> m_prev_uioh
3792 | Some uioh -> uioh
3794 method motion _ y =
3795 match state.mstate with
3796 | Mscrolly ->
3797 let s = float (max 0 (y - conf.scrollh)) /. float state.winh in
3798 let first = truncate (s *. float source#getitemcount) in
3799 let first = min source#getitemcount first in
3800 G.postRedisplay "listview motion";
3801 coe {< m_first = first; m_active = first >}
3802 | _ -> coe self
3804 method pmotion x y =
3805 if x < state.winw - conf.scrollbw
3806 then
3807 let n =
3808 match self#elemunder y with
3809 | None -> Wsi.setcursor Wsi.CURSOR_INHERIT; m_active
3810 | Some n -> Wsi.setcursor Wsi.CURSOR_INFO; n
3812 let o =
3813 if n != m_active
3814 then (G.postRedisplay "listview pmotion"; {< m_active = n >})
3815 else self
3817 coe o
3818 else (
3819 Wsi.setcursor Wsi.CURSOR_INHERIT;
3820 coe self
3823 method infochanged _ = ()
3825 method scrollpw = (0, 0.0, 0.0)
3826 method scrollph =
3827 let nfs = fstate.fontsize + 1 in
3828 let y = m_first * nfs in
3829 let itemcount = source#getitemcount in
3830 let maxi = max 0 (itemcount - fstate.maxrows) in
3831 let maxy = maxi * nfs in
3832 let p, h = scrollph y maxy in
3833 conf.scrollbw, p, h
3835 method modehash = modehash
3836 method eformsgs = false
3837 end;;
3839 class outlinelistview ~source =
3840 object (self)
3841 inherit listview
3842 ~source:(source :> lvsource)
3843 ~trusted:false
3844 ~modehash:(findkeyhash conf "outline")
3845 as super
3847 method key key mask =
3848 let calcfirst first active =
3849 if active > first
3850 then
3851 let rows = active - first in
3852 let maxrows =
3853 if String.length state.text = 0
3854 then fstate.maxrows
3855 else fstate.maxrows - 2
3857 if rows > maxrows then active - maxrows else first
3858 else active
3860 let navigate incr =
3861 let active = m_active + incr in
3862 let active = bound active 0 (source#getitemcount - 1) in
3863 let first = calcfirst m_first active in
3864 G.postRedisplay "outline navigate";
3865 coe {< m_active = active; m_first = first >}
3867 let ctrl = Wsi.withctrl mask in
3868 match key with
3869 | 110 when ctrl -> (* ctrl-n *)
3870 source#narrow m_qsearch;
3871 G.postRedisplay "outline ctrl-n";
3872 coe {< m_first = 0; m_active = 0 >}
3874 | 117 when ctrl -> (* ctrl-u *)
3875 source#denarrow;
3876 G.postRedisplay "outline ctrl-u";
3877 state.text <- "";
3878 coe {< m_first = 0; m_active = 0 >}
3880 | 108 when ctrl -> (* ctrl-l *)
3881 let first = max 0 (m_active - (fstate.maxrows / 2)) in
3882 G.postRedisplay "outline ctrl-l";
3883 coe {< m_first = first >}
3885 | 0xff9f | 0xffff -> (* (kp) delete *)
3886 source#remove m_active;
3887 G.postRedisplay "outline delete";
3888 let active = max 0 (m_active-1) in
3889 coe {< m_first = firstof m_first active;
3890 m_active = active >}
3892 | 0xff52 | 0xff97 -> navigate ~-1 (* (kp) up *)
3893 | 0xff54 | 0xff99 -> navigate 1 (* (kp) down *)
3894 | 0xff55 | 0xff9a -> (* (kp) prior *)
3895 navigate ~-(fstate.maxrows)
3896 | 0xff56 | 0xff9b -> (* (kp) next *)
3897 navigate fstate.maxrows
3899 | 0xff53 | 0xff98 -> (* [ctrl-] (kp) right *)
3900 let o =
3901 if ctrl
3902 then (
3903 G.postRedisplay "outline ctrl right";
3904 {< m_pan = m_pan + 1 >}
3906 else self#updownlevel 1
3908 coe o
3910 | 0xff51 | 0xff96 -> (* [ctrl-] (kp) left *)
3911 let o =
3912 if ctrl
3913 then (
3914 G.postRedisplay "outline ctrl left";
3915 {< m_pan = m_pan - 1 >}
3917 else self#updownlevel ~-1
3919 coe o
3921 | 0xff50 | 0xff95 -> (* (kp) home *)
3922 G.postRedisplay "outline home";
3923 coe {< m_first = 0; m_active = 0 >}
3925 | 0xff57 | 0xff9c -> (* (kp) end *)
3926 let active = source#getitemcount - 1 in
3927 let first = max 0 (active - fstate.maxrows) in
3928 G.postRedisplay "outline end";
3929 coe {< m_active = active; m_first = first >}
3931 | _ -> super#key key mask
3934 let outlinesource usebookmarks =
3935 let empty = [||] in
3936 (object
3937 inherit lvsourcebase
3938 val mutable m_items = empty
3939 val mutable m_orig_items = empty
3940 val mutable m_prev_items = empty
3941 val mutable m_narrow_pattern = ""
3942 val mutable m_hadremovals = false
3944 method getitemcount =
3945 Array.length m_items + (if m_hadremovals then 1 else 0)
3947 method getitem n =
3948 if n == Array.length m_items && m_hadremovals
3949 then
3950 ("[Confirm removal]", 0)
3951 else
3952 let s, n, _ = m_items.(n) in
3953 (s, n)
3955 method exit ~uioh ~cancel ~active ~first ~pan ~qsearch =
3956 ignore (uioh, first, qsearch);
3957 let confrimremoval = m_hadremovals && active = Array.length m_items in
3958 let items =
3959 if String.length m_narrow_pattern = 0
3960 then m_orig_items
3961 else m_items
3963 if not cancel
3964 then (
3965 if not confrimremoval
3966 then(
3967 let _, _, anchor = m_items.(active) in
3968 gotoghyll (getanchory anchor);
3969 m_items <- items;
3971 else (
3972 state.bookmarks <- Array.to_list m_items;
3973 m_orig_items <- m_items;
3976 else m_items <- items;
3977 m_pan <- pan;
3978 None
3980 method hasaction _ = true
3982 method greetmsg =
3983 if Array.length m_items != Array.length m_orig_items
3984 then "Narrowed to " ^ m_narrow_pattern ^ " (ctrl-u to restore)"
3985 else ""
3987 method narrow pattern =
3988 let reopt = try Some (Str.regexp_case_fold pattern) with _ -> None in
3989 match reopt with
3990 | None -> ()
3991 | Some re ->
3992 let rec loop accu n =
3993 if n = -1
3994 then (
3995 m_narrow_pattern <- pattern;
3996 m_items <- Array.of_list accu
3998 else
3999 let (s, _, _) as o = m_items.(n) in
4000 let accu =
4001 if (try ignore (Str.search_forward re s 0); true
4002 with Not_found -> false)
4003 then o :: accu
4004 else accu
4006 loop accu (n-1)
4008 loop [] (Array.length m_items - 1)
4010 method denarrow =
4011 m_orig_items <- (
4012 if usebookmarks
4013 then Array.of_list state.bookmarks
4014 else state.outlines
4016 m_items <- m_orig_items
4018 method remove m =
4019 if usebookmarks
4020 then
4021 if m >= 0 && m < Array.length m_items
4022 then (
4023 m_hadremovals <- true;
4024 m_items <- Array.init (Array.length m_items - 1) (fun n ->
4025 let n = if n >= m then n+1 else n in
4026 m_items.(n)
4030 method reset anchor items =
4031 m_hadremovals <- false;
4032 if m_orig_items == empty || m_prev_items != items
4033 then (
4034 m_orig_items <- items;
4035 if String.length m_narrow_pattern = 0
4036 then m_items <- items;
4038 m_prev_items <- items;
4039 let rely = getanchory anchor in
4040 let active =
4041 let rec loop n best bestd =
4042 if n = Array.length m_items
4043 then best
4044 else
4045 let (_, _, anchor) = m_items.(n) in
4046 let orely = getanchory anchor in
4047 let d = abs (orely - rely) in
4048 if d < bestd
4049 then loop (n+1) n d
4050 else loop (n+1) best bestd
4052 loop 0 ~-1 max_int
4054 m_active <- active;
4055 m_first <- firstof m_first active
4056 end)
4059 let enterselector usebookmarks =
4060 let source = outlinesource usebookmarks in
4061 fun errmsg ->
4062 let outlines =
4063 if usebookmarks
4064 then Array.of_list state.bookmarks
4065 else state.outlines
4067 if Array.length outlines = 0
4068 then (
4069 showtext ' ' errmsg;
4071 else (
4072 state.text <- source#greetmsg;
4073 Wsi.setcursor Wsi.CURSOR_INHERIT;
4074 let anchor = getanchor () in
4075 source#reset anchor outlines;
4076 state.uioh <- coe (new outlinelistview ~source);
4077 G.postRedisplay "enter selector";
4081 let enteroutlinemode =
4082 let f = enterselector false in
4083 fun ()-> f "Document has no outline";
4086 let enterbookmarkmode =
4087 let f = enterselector true in
4088 fun () -> f "Document has no bookmarks (yet)";
4091 let color_of_string s =
4092 Scanf.sscanf s "%d/%d/%d" (fun r g b ->
4093 (float r /. 256.0, float g /. 256.0, float b /. 256.0)
4097 let color_to_string (r, g, b) =
4098 let r = truncate (r *. 256.0)
4099 and g = truncate (g *. 256.0)
4100 and b = truncate (b *. 256.0) in
4101 Printf.sprintf "%d/%d/%d" r g b
4104 let irect_of_string s =
4105 Scanf.sscanf s "%d/%d/%d/%d" (fun x0 y0 x1 y1 -> (x0,y0,x1,y1))
4108 let irect_to_string (x0,y0,x1,y1) =
4109 Printf.sprintf "%d/%d/%d/%d" x0 y0 x1 y1
4112 let makecheckers () =
4113 (* Based on lablGL-1.04/LablGlut/examples/lablGL/checker.ml which had
4114 following to say:
4115 converted by Issac Trotts. July 25, 2002 *)
4116 let image = GlPix.create `ubyte ~format:`luminance ~width:2 ~height:2 in
4117 Raw.sets_string (GlPix.to_raw image) ~pos:0 "\255\200\200\255";
4118 let id = GlTex.gen_texture () in
4119 GlTex.bind_texture `texture_2d id;
4120 GlPix.store (`unpack_alignment 1);
4121 GlTex.image2d image;
4122 List.iter (GlTex.parameter ~target:`texture_2d)
4123 [ `mag_filter `nearest; `min_filter `nearest ];
4127 let setcheckers enabled =
4128 match state.texid with
4129 | None ->
4130 if enabled then state.texid <- Some (makecheckers ())
4132 | Some texid ->
4133 if not enabled
4134 then (
4135 GlTex.delete_texture texid;
4136 state.texid <- None;
4140 let int_of_string_with_suffix s =
4141 let l = String.length s in
4142 let s1, shift =
4143 if l > 1
4144 then
4145 let suffix = Char.lowercase s.[l-1] in
4146 match suffix with
4147 | 'k' -> String.sub s 0 (l-1), 10
4148 | 'm' -> String.sub s 0 (l-1), 20
4149 | 'g' -> String.sub s 0 (l-1), 30
4150 | _ -> s, 0
4151 else s, 0
4153 let n = int_of_string s1 in
4154 let m = n lsl shift in
4155 if m < 0 || m < n
4156 then raise (Failure "value too large")
4157 else m
4160 let string_with_suffix_of_int n =
4161 if n = 0
4162 then "0"
4163 else
4164 let n, s =
4165 if n land ((1 lsl 30) - 1) = 0
4166 then n lsr 30, "G"
4167 else (
4168 if n land ((1 lsl 20) - 1) = 0
4169 then n lsr 20, "M"
4170 else (
4171 if n land ((1 lsl 10) - 1) = 0
4172 then n lsr 10, "K"
4173 else n, ""
4177 let rec loop s n =
4178 let h = n mod 1000 in
4179 let n = n / 1000 in
4180 if n = 0
4181 then string_of_int h ^ s
4182 else (
4183 let s = Printf.sprintf "_%03d%s" h s in
4184 loop s n
4187 loop "" n ^ s;
4190 let defghyllscroll = (40, 8, 32);;
4191 let ghyllscroll_of_string s =
4192 let (n, a, b) as nab =
4193 if s = "default"
4194 then defghyllscroll
4195 else Scanf.sscanf s "%u,%u,%u" (fun n a b -> n, a, b)
4197 if n <= a || n <= b || a >= b
4198 then failwith "invalid ghyll N,A,B (N <= A, A < B, N <= B)";
4199 nab;
4202 let ghyllscroll_to_string ((n, a, b) as nab) =
4203 if nab = defghyllscroll
4204 then "default"
4205 else Printf.sprintf "%d,%d,%d" n a b;
4208 let describe_location () =
4209 let fn = page_of_y state.y in
4210 let ln = page_of_y (state.y + state.winh - hscrollh () - 1) in
4211 let maxy = state.maxy - (if conf.maxhfit then state.winh else 0) in
4212 let percent =
4213 if maxy <= 0
4214 then 100.
4215 else (100. *. (float state.y /. float maxy))
4217 if fn = ln
4218 then
4219 Printf.sprintf "page %d of %d [%.2f%%]"
4220 (fn+1) state.pagecount percent
4221 else
4222 Printf.sprintf
4223 "pages %d-%d of %d [%.2f%%]"
4224 (fn+1) (ln+1) state.pagecount percent
4227 let setpresentationmode v =
4228 let n = page_of_y state.y in
4229 state.anchor <- (n, 0.0, 1.0);
4230 conf.presentation <- v;
4231 if conf.fitmodel = FitPage
4232 then reqlayout conf.angle conf.fitmodel;
4233 represent ();
4236 let enterinfomode =
4237 let btos b = if b then "\xe2\x88\x9a" else "" in
4238 let showextended = ref false in
4239 let leave mode = function
4240 | Confirm -> state.mode <- mode
4241 | Cancel -> state.mode <- mode in
4242 let src =
4243 (object
4244 val mutable m_first_time = true
4245 val mutable m_l = []
4246 val mutable m_a = [||]
4247 val mutable m_prev_uioh = nouioh
4248 val mutable m_prev_mode = View
4250 inherit lvsourcebase
4252 method reset prev_mode prev_uioh =
4253 m_a <- Array.of_list (List.rev m_l);
4254 m_l <- [];
4255 m_prev_mode <- prev_mode;
4256 m_prev_uioh <- prev_uioh;
4257 if m_first_time
4258 then (
4259 let rec loop n =
4260 if n >= Array.length m_a
4261 then ()
4262 else
4263 match m_a.(n) with
4264 | _, _, _, Action _ -> m_active <- n
4265 | _ -> loop (n+1)
4267 loop 0;
4268 m_first_time <- false;
4271 method int name get set =
4272 m_l <-
4273 (name, `int get, 1, Action (
4274 fun u ->
4275 let ondone s =
4276 try set (int_of_string s)
4277 with exn ->
4278 state.text <- Printf.sprintf "bad integer `%s': %s"
4279 s (exntos exn)
4281 state.text <- "";
4282 let te = name ^ ": ", "", None, intentry, ondone, true in
4283 state.mode <- Textentry (te, leave m_prev_mode);
4285 )) :: m_l
4287 method int_with_suffix name get set =
4288 m_l <-
4289 (name, `intws get, 1, Action (
4290 fun u ->
4291 let ondone s =
4292 try set (int_of_string_with_suffix s)
4293 with exn ->
4294 state.text <- Printf.sprintf "bad integer `%s': %s"
4295 s (exntos exn)
4297 state.text <- "";
4298 let te =
4299 name ^ ": ", "", None, intentry_with_suffix, ondone, true
4301 state.mode <- Textentry (te, leave m_prev_mode);
4303 )) :: m_l
4305 method bool ?(offset=1) ?(btos=btos) name get set =
4306 m_l <-
4307 (name, `bool (btos, get), offset, Action (
4308 fun u ->
4309 let v = get () in
4310 set (not v);
4312 )) :: m_l
4314 method color name get set =
4315 m_l <-
4316 (name, `color get, 1, Action (
4317 fun u ->
4318 let invalid = (nan, nan, nan) in
4319 let ondone s =
4320 let c =
4321 try color_of_string s
4322 with exn ->
4323 state.text <- Printf.sprintf "bad color `%s': %s"
4324 s (exntos exn);
4325 invalid
4327 if c <> invalid
4328 then set c;
4330 let te = name ^ ": ", "", None, textentry, ondone, true in
4331 state.text <- color_to_string (get ());
4332 state.mode <- Textentry (te, leave m_prev_mode);
4334 )) :: m_l
4336 method string name get set =
4337 m_l <-
4338 (name, `string get, 1, Action (
4339 fun u ->
4340 let ondone s = set s in
4341 let te = name ^ ": ", "", None, textentry, ondone, true in
4342 state.mode <- Textentry (te, leave m_prev_mode);
4344 )) :: m_l
4346 method colorspace name get set =
4347 m_l <-
4348 (name, `string get, 1, Action (
4349 fun _ ->
4350 let source =
4351 (object
4352 inherit lvsourcebase
4354 initializer
4355 m_active <- CSTE.to_int conf.colorspace;
4356 m_first <- 0;
4358 method getitemcount =
4359 Array.length CSTE.names
4360 method getitem n =
4361 (CSTE.names.(n), 0)
4362 method exit ~uioh ~cancel ~active ~first ~pan ~qsearch =
4363 ignore (uioh, first, pan, qsearch);
4364 if not cancel then set active;
4365 None
4366 method hasaction _ = true
4367 end)
4369 state.text <- "";
4370 let modehash = findkeyhash conf "info" in
4371 coe (new listview ~source ~trusted:true ~modehash)
4372 )) :: m_l
4374 method paxmark name get set =
4375 m_l <-
4376 (name, `string get, 1, Action (
4377 fun _ ->
4378 let source =
4379 (object
4380 inherit lvsourcebase
4382 initializer
4383 m_active <- MTE.to_int conf.paxmark;
4384 m_first <- 0;
4386 method getitemcount = Array.length MTE.names
4387 method getitem n = (MTE.names.(n), 0)
4388 method exit ~uioh ~cancel ~active ~first ~pan ~qsearch =
4389 ignore (uioh, first, pan, qsearch);
4390 if not cancel then set active;
4391 None
4392 method hasaction _ = true
4393 end)
4395 state.text <- "";
4396 let modehash = findkeyhash conf "info" in
4397 coe (new listview ~source ~trusted:true ~modehash)
4398 )) :: m_l
4400 method fitmodel name get set =
4401 m_l <-
4402 (name, `string get, 1, Action (
4403 fun _ ->
4404 let source =
4405 (object
4406 inherit lvsourcebase
4408 initializer
4409 m_active <- FMTE.to_int conf.fitmodel;
4410 m_first <- 0;
4412 method getitemcount = Array.length FMTE.names
4413 method getitem n = (FMTE.names.(n), 0)
4414 method exit ~uioh ~cancel ~active ~first ~pan ~qsearch =
4415 ignore (uioh, first, pan, qsearch);
4416 if not cancel then set active;
4417 None
4418 method hasaction _ = true
4419 end)
4421 state.text <- "";
4422 let modehash = findkeyhash conf "info" in
4423 coe (new listview ~source ~trusted:true ~modehash)
4424 )) :: m_l
4426 method caption s offset =
4427 m_l <- (s, `empty, offset, Noaction) :: m_l
4429 method caption2 s f offset =
4430 m_l <- (s, `string f, offset, Noaction) :: m_l
4432 method getitemcount = Array.length m_a
4434 method getitem n =
4435 let tostr = function
4436 | `int f -> string_of_int (f ())
4437 | `intws f -> string_with_suffix_of_int (f ())
4438 | `string f -> f ()
4439 | `color f -> color_to_string (f ())
4440 | `bool (btos, f) -> btos (f ())
4441 | `empty -> ""
4443 let name, t, offset, _ = m_a.(n) in
4444 ((let s = tostr t in
4445 if String.length s > 0
4446 then Printf.sprintf "%s\t%s" name s
4447 else name),
4448 offset)
4450 method exit ~uioh ~cancel ~active ~first ~pan ~qsearch =
4451 let uiohopt =
4452 if not cancel
4453 then (
4454 m_qsearch <- qsearch;
4455 let uioh =
4456 match m_a.(active) with
4457 | _, _, _, Action f -> f uioh
4458 | _ -> uioh
4460 Some uioh
4462 else None
4464 m_active <- active;
4465 m_first <- first;
4466 m_pan <- pan;
4467 uiohopt
4469 method hasaction n =
4470 match m_a.(n) with
4471 | _, _, _, Action _ -> true
4472 | _ -> false
4473 end)
4475 let rec fillsrc prevmode prevuioh =
4476 let sep () = src#caption "" 0 in
4477 let colorp name get set =
4478 src#string name
4479 (fun () -> color_to_string (get ()))
4480 (fun v ->
4482 let c = color_of_string v in
4483 set c
4484 with exn ->
4485 state.text <- Printf.sprintf "bad color `%s': %s" v (exntos exn)
4488 let oldmode = state.mode in
4489 let birdseye = isbirdseye state.mode in
4491 src#caption (if birdseye then "Setup (Bird's eye)" else "Setup") 0;
4493 src#bool "presentation mode"
4494 (fun () -> conf.presentation)
4495 (fun v -> setpresentationmode v);
4497 src#bool "ignore case in searches"
4498 (fun () -> conf.icase)
4499 (fun v -> conf.icase <- v);
4501 src#bool "preload"
4502 (fun () -> conf.preload)
4503 (fun v -> conf.preload <- v);
4505 src#bool "highlight links"
4506 (fun () -> conf.hlinks)
4507 (fun v -> conf.hlinks <- v);
4509 src#bool "under info"
4510 (fun () -> conf.underinfo)
4511 (fun v -> conf.underinfo <- v);
4513 src#bool "persistent bookmarks"
4514 (fun () -> conf.savebmarks)
4515 (fun v -> conf.savebmarks <- v);
4517 src#fitmodel "fit model"
4518 (fun () -> FMTE.to_string conf.fitmodel)
4519 (fun v -> reqlayout conf.angle (FMTE.of_int v));
4521 src#bool "trim margins"
4522 (fun () -> conf.trimmargins)
4523 (fun v -> settrim v conf.trimfuzz; fillsrc prevmode prevuioh);
4525 src#bool "persistent location"
4526 (fun () -> conf.jumpback)
4527 (fun v -> conf.jumpback <- v);
4529 sep ();
4530 src#int "inter-page space"
4531 (fun () -> conf.interpagespace)
4532 (fun n ->
4533 conf.interpagespace <- n;
4534 docolumns conf.columns;
4535 let pageno, py =
4536 match state.layout with
4537 | [] -> 0, 0
4538 | l :: _ ->
4539 l.pageno, l.pagey
4541 state.maxy <- calcheight ();
4542 let y = getpagey pageno in
4543 gotoy (y + py)