Guard against invalid regexps in qsearch
[llpp.git] / main.ml
blob66ec8f81bf71c4b4791cb946cc5815c30424ff27
1 open Format;;
3 let log fmt = Printf.kprintf prerr_endline fmt;;
4 let dolog fmt = Printf.kprintf prerr_endline fmt;;
6 external init : Unix.file_descr -> unit = "ml_init";;
7 external draw : int -> int -> int -> int -> string -> unit = "ml_draw";;
8 external gettext : string -> (int * int * int * int) -> int -> bool -> unit =
9 "ml_gettext";;
10 external checklink : string -> int -> int -> bool = "ml_checklink";;
11 external getlink : string -> int -> int -> (int * int) option = "ml_getlink";;
12 external getpagewh : int -> float array = "ml_getpagewh";;
14 type mstate = Msel of ((int * int) * (int * int)) | Mnone;;
16 type te =
17 | TEstop
18 | TEdone of string
19 | TEcont of string
22 type 'a circbuf =
23 { store : 'a array
24 ; mutable rc : int
25 ; mutable wc : int
26 ; mutable len : int
30 let cbnew n v =
31 { store = Array.create n v
32 ; rc = 0
33 ; wc = 0
34 ; len = 0
38 let cblen b = Array.length b.store;;
40 let cbput b v =
41 let len = cblen b in
42 b.store.(b.wc) <- v;
43 b.wc <- (b.wc + 1) mod len;
44 b.len <- (b.len + 1) mod len;
47 let cbpeekw b = b.store.(b.wc);;
49 let cbget b =
50 let v = b.store.(b.rc) in
51 if b.len = 0
52 then
54 else (
55 let rc = if b.rc = 0 then b.len - 1 else b.rc - 1 in
56 b.rc <- rc;
61 let cbrfollowlen b =
62 b.rc <- b.len - 1;
65 type layout =
66 { pageno : int
67 ; pagedimno : int
68 ; pagew : int
69 ; pageh : int
70 ; pagedispy : int
71 ; pagey : int
72 ; pagevh : int
76 type conf =
77 { mutable scrollw : int
78 ; mutable scrollh : int
79 ; mutable rectsel : bool
80 ; mutable icase : bool
81 ; mutable preload : bool
82 ; mutable titletext : bool
83 ; mutable pagebias : int
84 ; mutable redispimm : bool
85 ; mutable verbose : bool
86 ; mutable scrollincr : int
87 ; mutable maxhfit : bool
88 ; mutable markonquit : bool
89 ; mutable crophack : bool
93 type outline = string * int * int * int;;
94 type outlines = Oarray of outline array | Olist of outline list;;
96 type state =
97 { mutable csock : Unix.file_descr
98 ; mutable ssock : Unix.file_descr
99 ; mutable w : int
100 ; mutable h : int
101 ; mutable y : int
102 ; mutable prevy : int
103 ; mutable maxy : int
104 ; mutable layout : layout list
105 ; pagemap : ((int * int), string) Hashtbl.t
106 ; mutable pages : (int * int * int) list
107 ; mutable pagecount : int
108 ; pagecache : string circbuf
109 ; navhist : float circbuf
110 ; mutable inflight : int
111 ; mutable mstate : mstate
112 ; mutable searchpattern : string
113 ; mutable rects : (int * int * Gl.point2 * Gl.point2) list
114 ; mutable rects1 : (int * int * Gl.point2 * Gl.point2) list
115 ; mutable text : string
116 ; mutable fullscreen : (int * int) option
117 ; mutable textentry :
118 (char * string * (string -> int -> te) * (string -> unit)) option
119 ; mutable outlines : outlines
120 ; mutable outline : (bool * int * int * outline array * string) option
121 ; mutable bookmarks : outline list
122 ; mutable path : string
126 let conf =
127 { scrollw = 5
128 ; scrollh = 12
129 ; icase = true
130 ; rectsel = true
131 ; preload = false
132 ; titletext = false
133 ; pagebias = 0
134 ; redispimm = false
135 ; verbose = false
136 ; scrollincr = 24
137 ; maxhfit = true
138 ; markonquit = false
139 ; crophack = false
143 let state =
144 { csock = Unix.stdin
145 ; ssock = Unix.stdin
146 ; w = 900
147 ; h = 900
148 ; y = 0
149 ; prevy = 0
150 ; layout = []
151 ; maxy = max_int
152 ; pagemap = Hashtbl.create 10
153 ; pagecache = cbnew 10 ""
154 ; pages = []
155 ; pagecount = 0
156 ; inflight = 0
157 ; mstate = Mnone
158 ; navhist = cbnew 100 0.0
159 ; rects = []
160 ; rects1 = []
161 ; text = ""
162 ; fullscreen = None
163 ; textentry = None
164 ; searchpattern = ""
165 ; outlines = Olist []
166 ; outline = None
167 ; bookmarks = []
168 ; path = ""
172 let vlog fmt =
173 if conf.verbose
174 then
175 Printf.kprintf prerr_endline fmt
176 else
177 Printf.kprintf ignore fmt
180 let writecmd fd s =
181 let len = String.length s in
182 let n = 4 + len in
183 let b = Buffer.create n in
184 Buffer.add_char b (Char.chr ((len lsr 24) land 0xff));
185 Buffer.add_char b (Char.chr ((len lsr 16) land 0xff));
186 Buffer.add_char b (Char.chr ((len lsr 8) land 0xff));
187 Buffer.add_char b (Char.chr ((len lsr 0) land 0xff));
188 Buffer.add_string b s;
189 let s' = Buffer.contents b in
190 let n' = Unix.write fd s' 0 n in
191 if n' != n then failwith "write failed";
194 let readcmd fd =
195 let s = "xxxx" in
196 let n = Unix.read fd s 0 4 in
197 if n != 4 then failwith "incomplete read(len)";
198 let len = 0
199 lor (Char.code s.[0] lsl 24)
200 lor (Char.code s.[1] lsl 16)
201 lor (Char.code s.[2] lsl 8)
202 lor (Char.code s.[3] lsl 0)
204 let s = String.create len in
205 let n = Unix.read fd s 0 len in
206 if n != len then failwith "incomplete read(data)";
210 let yratio y =
211 if y = state.maxy then 1.0
212 else float y /. float state.maxy
215 let makecmd s l =
216 let b = Buffer.create 10 in
217 Buffer.add_string b s;
218 let rec combine = function
219 | [] -> b
220 | x :: xs ->
221 Buffer.add_char b ' ';
222 let s =
223 match x with
224 | `b b -> if b then "1" else "0"
225 | `s s -> s
226 | `i i -> string_of_int i
227 | `f f -> string_of_float f
228 | `I f -> string_of_int (truncate f)
230 Buffer.add_string b s;
231 combine xs;
233 combine l;
236 let wcmd s l =
237 let cmd = Buffer.contents (makecmd s l) in
238 writecmd state.csock cmd;
241 let calcheight () =
242 let rec f pn ph fh l =
243 match l with
244 | (n, _, h) :: rest ->
245 let fh = fh + (n - pn) * ph in
246 f n h fh rest
248 | [] ->
249 let fh = fh + (ph * (state.pagecount - pn)) in
250 max 0 fh
252 let fh = f 0 0 0 state.pages in
256 let getpagey pageno =
257 let rec f pn ph y l =
258 match l with
259 | (n, _, h) :: rest ->
260 if n >= pageno
261 then
262 y + (pageno - pn) * ph
263 else
264 let y = y + (n - pn) * ph in
265 f n h y rest
267 | [] ->
268 y + (pageno - pn) * ph
270 f 0 0 0 state.pages;
273 let layout y sh =
274 let rec f pageno pdimno prev vy py dy l cacheleft accu =
275 if pageno = state.pagecount || cacheleft = 0
276 then accu
277 else
278 let ((_, w, h) as curr), rest, pdimno =
279 match l with
280 | ((pageno', _, _) as curr) :: rest when pageno' = pageno ->
281 curr, rest, pdimno + 1
282 | _ ->
283 prev, l, pdimno
285 let pageno' = pageno + 1 in
286 if py + h > vy
287 then
288 let py' = vy - py in
289 let vh = h - py' in
290 if dy + vh > sh
291 then
292 let vh = sh - dy in
293 if vh <= 0
294 then
295 accu
296 else
297 let e =
298 { pageno = pageno
299 ; pagedimno = pdimno
300 ; pagew = w
301 ; pageh = h
302 ; pagedispy = dy
303 ; pagey = py'
304 ; pagevh = vh
307 e :: accu
308 else
309 let e =
310 { pageno = pageno
311 ; pagedimno = pdimno
312 ; pagew = w
313 ; pageh = h
314 ; pagedispy = dy
315 ; pagey = py'
316 ; pagevh = vh
319 let accu = e :: accu in
320 f pageno' pdimno curr
321 (vy + vh) (py + h) (dy + vh + 2) rest
322 (pred cacheleft) accu
323 else
324 f pageno' pdimno curr vy (py + h) dy rest cacheleft accu
326 let accu = f 0 ~-1 (0,0,0) y 0 0 state.pages (cblen state.pagecache) [] in
327 state.maxy <- calcheight ();
328 List.rev accu
331 let clamp incr =
332 let y = state.y + incr in
333 let y = max 0 y in
334 let y = min y (state.maxy - (if conf.maxhfit then state.h else 0)) in
338 let gotoy y =
339 let y = max 0 y in
340 let y = min state.maxy y in
341 let pages = layout y state.h in
342 state.y <- y;
343 state.layout <- pages;
344 if conf.redispimm
345 then
346 Glut.postRedisplay ()
350 let addnav () =
351 cbput state.navhist (yratio state.y);
352 cbrfollowlen state.navhist;
355 let getnav () =
356 let y = cbget state.navhist in
357 truncate (y *. float state.maxy)
360 let gotopage n top =
361 let y = getpagey n in
362 addnav ();
363 state.y <- y + top;
364 gotoy state.y;
367 let reshape ~w ~h =
368 let ratio = float w /. float state.w in
369 let fixbookmark (s, l, pageno, pagey) =
370 let pagey = truncate (float pagey *. ratio) in
371 (s, l, pageno, pagey)
373 state.bookmarks <- List.map fixbookmark state.bookmarks;
374 state.w <- w;
375 state.h <- h;
376 GlDraw.viewport 0 0 w h;
377 GlMat.mode `modelview;
378 GlMat.load_identity ();
379 GlMat.mode `projection;
380 GlMat.load_identity ();
381 GlMat.rotate ~x:1.0 ~angle:180.0 ();
382 GlMat.translate ~x:~-.1.0 ~y:~-.1.0 ();
383 GlMat.scale3 (2.0 /. float w, 2.0 /. float state.h, 1.0);
384 GlClear.color (1., 1., 1.);
385 GlClear.clear [`color];
386 state.layout <- [];
387 state.pages <- [];
388 state.rects <- [];
389 state.text <- "";
390 wcmd "geometry" [`i (state.w - conf.scrollw); `i h];
393 let showtext c s =
394 if not conf.titletext
395 then (
396 GlDraw.color (0.0, 0.0, 0.0);
397 GlDraw.rect
398 (0.0, float (state.h - 18))
399 (float (state.w - conf.scrollw - 1), float state.h)
401 let font = Glut.BITMAP_8_BY_13 in
402 GlDraw.color (1.0, 1.0, 1.0);
403 GlPix.raster_pos ~x:0.0 ~y:(float (state.h - 5)) ();
404 Glut.bitmapCharacter ~font ~c:(Char.code c);
405 String.iter (fun c -> Glut.bitmapCharacter ~font ~c:(Char.code c)) s
407 else
408 let len = String.length s in
409 let dst = String.create (len + 1) in
410 dst.[0] <- c;
411 StringLabels.blit
412 ~src:s
413 ~dst
414 ~src_pos:0
415 ~dst_pos:1
416 ~len
418 Glut.setWindowTitle ~title:dst
421 let enttext () =
422 let len = String.length state.text in
423 match state.textentry with
424 | None ->
425 if len > 0 then showtext ' ' state.text
427 | Some (c, text, _, _) ->
428 let s =
429 if len > 0
430 then
431 text ^ " [" ^ state.text ^ "]"
432 else
433 text
435 showtext c s;
438 let act cmd =
439 match cmd.[0] with
440 | 'c' ->
441 state.pages <- [];
442 state.outlines <- Olist []
444 | 'D' ->
445 state.rects <- state.rects1;
446 Glut.postRedisplay ()
448 | 'd' ->
449 state.rects <- state.rects1;
450 Glut.postRedisplay ()
452 | 'C' ->
453 let n = Scanf.sscanf cmd "C %d" (fun n -> n) in
454 state.pagecount <- n;
455 let rely = yratio state.y in
456 let maxy = calcheight () in
457 state.y <- truncate (float maxy *. rely);
458 let pages = layout state.y state.h in
459 state.layout <- pages;
460 Glut.postRedisplay ();
462 | 't' ->
463 let s = Scanf.sscanf cmd "t %n"
464 (fun n -> String.sub cmd n (String.length cmd - n))
466 Glut.setWindowTitle s
468 | 'T' ->
469 let s = Scanf.sscanf cmd "T %n"
470 (fun n -> String.sub cmd n (String.length cmd - n))
472 state.text <- s;
473 showtext ' ' s;
474 Glut.swapBuffers ();
475 (* Glut.postRedisplay () *)
477 | 'F' ->
478 let pageno, c, x0, y0, x1, y1 =
479 Scanf.sscanf cmd "F %d %d %f %f %f %f"
480 (fun p c x0 y0 x1 y1 -> (p, c, x0, y0, x1, y1))
482 let y = (getpagey pageno) + truncate y0 in
483 addnav ();
484 gotoy y;
485 state.rects1 <- [pageno, c, (x0, y0), (x1, y1)]
487 | 'R' ->
488 let pageno, c, x0, y0, x1, y1 =
489 Scanf.sscanf cmd "R %d %d %f %f %f %f"
490 (fun pageno c x0 y0 x1 y1 -> (pageno, c, x0, y0, x1, y1))
492 state.rects1 <- (pageno, c, (x0, y0), (x1, y1)) :: state.rects1
494 | 'r' ->
495 let n, w, h, p =
496 Scanf.sscanf cmd "r %d %d %d %s"
497 (fun n w h p -> (n, w, h, p))
499 Hashtbl.replace state.pagemap (n, w) p;
500 let evicted = cbpeekw state.pagecache in
501 if String.length evicted > 0
502 then begin
503 wcmd "free" [`s evicted];
504 let l = Hashtbl.fold (fun k p a ->
505 if evicted = p then k :: a else a) state.pagemap []
507 List.iter (fun k -> Hashtbl.remove state.pagemap k) l;
508 end;
509 cbput state.pagecache p;
510 state.inflight <- pred state.inflight;
511 Glut.postRedisplay ()
513 | 'l' ->
514 let (n, w, h) as pagelayout =
515 Scanf.sscanf cmd "l %d %d %d" (fun n w h -> n, w, h)
517 state.pages <- pagelayout :: state.pages
519 | 'o' ->
520 let (l, n, t, pos) =
521 Scanf.sscanf cmd "o %d %d %d %n" (fun l n t pos -> l, n, t, pos)
523 let s = String.sub cmd pos (String.length cmd - pos) in
524 let outline = (s, l, n, t) in
525 let outlines =
526 match state.outlines with
527 | Olist outlines -> Olist (outline :: outlines)
528 | Oarray _ -> Olist [outline]
530 state.outlines <- outlines
532 | _ ->
533 log "unknown cmd `%S'" cmd
536 let getopaque pageno =
537 try Some (Hashtbl.find state.pagemap (pageno + 1, state.w - conf.scrollw))
538 with Not_found -> None
541 let cache pageno opaque =
542 Hashtbl.replace state.pagemap (pageno + 1, state.w - conf.scrollw) opaque
545 let validopaque opaque = String.length opaque > 0;;
547 let preload l =
548 match getopaque l.pageno with
549 | None when state.inflight < 2+0*(cblen state.pagecache) ->
550 state.inflight <- succ state.inflight;
551 cache l.pageno "";
552 wcmd "render" [`i (l.pageno + 1)
553 ;`i l.pagedimno
554 ;`i l.pagew
555 ;`i l.pageh];
557 | _ -> ()
560 let idle () =
561 if not conf.redispimm && state.y != state.prevy
562 then (
563 state.prevy <- state.y;
564 Glut.postRedisplay ();
566 else
567 let r, _, _ = Unix.select [state.csock] [] [] 0.0001 in
569 begin match r with
570 | [] ->
571 if conf.preload then begin
572 let h = state.h in
573 let y = if state.y < state.h then 0 else state.y - state.h in
574 let pages = layout y (h*3) in
575 List.iter preload pages;
576 end;
578 | _ ->
579 let cmd = readcmd state.csock in
580 act cmd;
581 end;
584 let search pattern forward =
585 if String.length pattern > 0
586 then
587 let pn, py =
588 match state.layout with
589 | [] -> 0, 0
590 | l :: _ ->
591 l.pageno, (l.pagey + if forward then 0 else 0*l.pagevh)
593 let cmd =
594 let b = makecmd "search"
595 [`b conf.icase; `i pn; `i py; `i (if forward then 1 else 0)]
597 Buffer.add_char b ',';
598 Buffer.add_string b pattern;
599 Buffer.add_char b '\000';
600 Buffer.contents b;
602 writecmd state.csock cmd;
605 let intentry text key =
606 let c = Char.unsafe_chr key in
607 match c with
608 | '0' .. '9' ->
609 let s = "x" in s.[0] <- c;
610 let text = text ^ s in
611 TEcont text
613 | _ ->
614 state.text <- Printf.sprintf "invalid char (%d, `%c')" key c;
615 TEcont text
618 let addchar s c =
619 let b = Buffer.create (String.length s + 1) in
620 Buffer.add_string b s;
621 Buffer.add_char b c;
622 Buffer.contents b;
625 let textentry text key =
626 let c = Char.unsafe_chr key in
627 match c with
628 | _ when key >= 32 && key < 127 ->
629 let text = addchar text c in
630 TEcont text
632 | _ ->
633 log "unhandled key %d char `%c'" key (Char.unsafe_chr key);
634 TEcont text
637 let optentry text key =
638 let btos b = if b then "on" else "off" in
639 let c = Char.unsafe_chr key in
640 match c with
641 | 'r' ->
642 conf.rectsel <- not conf.rectsel;
643 TEdone ("rectsel " ^ (btos conf.rectsel))
645 | 'i' ->
646 conf.icase <- not conf.icase;
647 TEdone ("case insensitive search " ^ (btos conf.icase))
649 | 'p' ->
650 conf.preload <- not conf.preload;
651 TEdone ("preload " ^ (btos conf.preload))
653 | 't' ->
654 conf.titletext <- not conf.titletext;
655 TEdone ("titletext " ^ (btos conf.titletext))
657 | 'd' ->
658 conf.redispimm <- not conf.redispimm;
659 TEdone ("immediate redisplay " ^ (btos conf.redispimm))
661 | 'v' ->
662 conf.verbose <- not conf.verbose;
663 TEdone ("verbose " ^ (btos conf.verbose))
665 | 'h' ->
666 conf.maxhfit <- not conf.maxhfit;
667 state.maxy <- state.maxy + (if conf.maxhfit then -state.h else state.h);
668 TEdone ("maxhfit " ^ (btos conf.maxhfit))
670 | 'q' ->
671 conf.markonquit <- not conf.markonquit;
672 TEdone ("bookmark on quit " ^ btos conf.markonquit)
674 | 'c' ->
675 conf.crophack <- not conf.crophack;
676 TEdone ("crophack " ^ btos conf.crophack)
678 | _ ->
679 state.text <- Printf.sprintf "bad option %d `%c'" key c;
680 TEstop
683 let maxoutlinerows () = (state.h - 31) / 16;;
685 let enterselector allowdel outlines errmsg =
686 if Array.length outlines = 0
687 then (
688 showtext ' ' errmsg;
689 Glut.swapBuffers ()
691 else
692 let pageno =
693 match state.layout with
694 | [] -> -1
695 | {pageno=pageno} :: rest -> pageno
697 let active =
698 let rec loop n =
699 if n = Array.length outlines
700 then 0
701 else
702 let (_, _, outlinepageno, _) = outlines.(n) in
703 if outlinepageno >= pageno then n else loop (n+1)
705 loop 0
707 state.outline <-
708 Some (allowdel, active, max 0 (active - maxoutlinerows ()), outlines, "");
709 Glut.postRedisplay ();
712 let enteroutlinemode () =
713 let outlines =
714 match state.outlines with
715 | Oarray a -> a
716 | Olist l ->
717 let a = Array.of_list (List.rev l) in
718 state.outlines <- Oarray a;
721 enterselector false outlines "Documents has no outline";
724 let enterbookmarkmode () =
725 let bookmarks = Array.of_list state.bookmarks in
726 enterselector true bookmarks "Documents has no bookmarks (yet)";
730 let quickbookmark ?title () =
731 match state.layout with
732 | [] -> ()
733 | l :: _ ->
734 let title =
735 match title with
736 | None ->
737 let sec = Unix.gettimeofday () in
738 let tm = Unix.localtime sec in
739 Printf.sprintf "Quick %d visited (%d/%d/%d %d:%d)"
740 l.pageno
741 tm.Unix.tm_mday
742 tm.Unix.tm_mon
743 (tm.Unix.tm_year + 1900)
744 tm.Unix.tm_hour
745 tm.Unix.tm_min
746 | Some title -> title
748 state.bookmarks <-
749 (title, 0, l.pageno, l.pagey) :: state.bookmarks
752 let viewkeyboard ~key ~x ~y =
753 let enttext te =
754 state.textentry <- te;
755 state.text <- "";
756 enttext ();
757 Glut.swapBuffers ()
759 match state.textentry with
760 | None ->
761 let c = Char.chr key in
762 begin match c with
763 | '\027' | 'q' ->
764 exit 0
766 | '\008' ->
767 let y = getnav () in
768 gotoy y
770 | 'o' ->
771 enteroutlinemode ()
773 | 'u' ->
774 state.rects <- [];
775 state.text <- "";
776 Glut.postRedisplay ()
778 | '/' | '?' ->
779 let ondone isforw s =
780 state.searchpattern <- s;
781 search s isforw
783 enttext (Some (c, "", textentry, ondone (c ='/')))
785 | '+' ->
786 let ondone s =
787 let n =
788 try int_of_string s with exc ->
789 state.text <- Printf.sprintf "bad integer `%s': %s"
790 s (Printexc.to_string exc);
791 max_int
793 if n != max_int
794 then (
795 conf.pagebias <- n;
796 state.text <- "page bias is now " ^ string_of_int n;
799 enttext (Some ('+', "", intentry, ondone))
801 | '-' ->
802 let ondone msg =
803 state.text <- msg;
805 enttext (Some ('-', "", optentry, ondone))
807 | '0' .. '9' ->
808 let ondone s =
809 let n =
810 try int_of_string s with exc ->
811 state.text <- Printf.sprintf "bad integer `%s': %s"
812 s (Printexc.to_string exc);
815 if n >= 0
816 then (
817 addnav ();
818 state.y <- y;
819 gotoy (getpagey (n + conf.pagebias - 1))
822 let pageentry text key =
823 match Char.unsafe_chr key with
824 | 'g' -> TEdone text
825 | _ -> intentry text key
827 let text = "x" in text.[0] <- c;
828 enttext (Some (':', text, pageentry, ondone))
830 | 'b' ->
831 conf.scrollw <- if conf.scrollw > 0 then 0 else 5;
832 reshape state.w state.h;
834 | 'f' ->
835 begin match state.fullscreen with
836 | None ->
837 state.fullscreen <- Some (state.w, state.h);
838 Glut.fullScreen ()
839 | Some (w, h) ->
840 state.fullscreen <- None;
841 Glut.reshapeWindow ~w ~h
844 | 'n' ->
845 search state.searchpattern true
847 | 'p' ->
848 search state.searchpattern false
850 | 't' ->
851 begin match state.layout with
852 | [] -> ()
853 | l :: _ ->
854 gotoy (state.y - l.pagey);
857 | ' ' | 'N' ->
858 begin match List.rev state.layout with
859 | [] -> ()
860 | l :: _ ->
861 gotoy (clamp (l.pageh - l.pagey))
864 | '\127' | 'P' ->
865 begin match state.layout with
866 | [] -> ()
867 | l :: _ ->
868 gotoy (clamp (-l.pageh));
871 | '=' ->
872 let f (fn, ln) l =
873 if fn = -1 then l.pageno, l.pageno else fn, l.pageno
875 let fn, ln = List.fold_left f (-1, -1) state.layout in
876 let s =
877 let maxy = state.maxy - (if conf.maxhfit then state.h else 0) in
878 let percent = (100. *. (float state.y /. float maxy)) in
879 if fn = ln
880 then
881 Printf.sprintf "Page %d of %d %.2f%%"
882 (fn+1) state.pagecount percent
883 else
884 Printf.sprintf
885 "Pages %d-%d of %d %.2f%%"
886 (fn+1) (ln+1) state.pagecount percent
888 showtext ' ' s;
889 Glut.swapBuffers ()
891 | 'w' ->
892 begin match state.layout with
893 | [] -> ()
894 | l :: _ ->
895 Glut.reshapeWindow (l.pagew + conf.scrollw) l.pageh;
896 Glut.postRedisplay ();
899 | '\'' ->
900 enterbookmarkmode ()
902 | 'm' ->
903 let ondone s =
904 match state.layout with
905 | l :: _ ->
906 state.bookmarks <- (s, 0, l.pageno, l.pagey) :: state.bookmarks
907 | _ -> ()
909 enttext (Some ('~', "", textentry, ondone))
911 | '~' ->
912 quickbookmark ();
913 showtext ' ' "Quick bookmark added";
914 Glut.swapBuffers ()
916 | 'z' ->
917 begin match state.layout with
918 | l :: _ ->
919 let a = getpagewh l.pagedimno in
920 let w, h =
921 if conf.crophack
922 then
923 (truncate (1.8 *. (a.(1) -. a.(0))),
924 truncate (1.4 *. (a.(3) -. a.(0))))
925 else
926 (truncate (a.(1) -. a.(0)),
927 truncate (a.(3) -. a.(0)))
929 Glut.reshapeWindow (w + conf.scrollw) h;
930 Glut.postRedisplay ();
932 | [] -> ()
935 | _ ->
936 vlog "huh? %d %c" key (Char.chr key);
939 | Some (c, text, onkey, ondone) when key = 8 ->
940 let len = String.length text in
941 if len = 0 || len = 1
942 then (
943 state.textentry <- None;
944 Glut.postRedisplay ();
946 else (
947 let s = String.sub text 0 (len - 1) in
948 enttext (Some (c, s, onkey, ondone))
951 | Some (c, text, onkey, ondone) ->
952 begin match Char.unsafe_chr key with
953 | '\r' | '\n' ->
954 ondone text;
955 state.textentry <- None;
956 Glut.postRedisplay ()
958 | '\027' ->
959 state.textentry <- None;
960 Glut.postRedisplay ()
962 | _ ->
963 begin match onkey text key with
964 | TEdone text ->
965 state.textentry <- None;
966 ondone text;
967 Glut.postRedisplay ()
969 | TEcont text ->
970 enttext (Some (c, text, onkey, ondone));
972 | TEstop ->
973 state.textentry <- None;
974 Glut.postRedisplay ()
975 end;
976 end;
979 let outlinekeyboard ~key ~x ~y (allowdel, active, first, outlines, qsearch) =
980 let search active pattern incr =
981 let dosearch re =
982 let rec loop n =
983 if n = Array.length outlines || n = -1 then None else
984 let (s, _, _, _) = outlines.(n) in
986 (try ignore (Str.search_forward re s 0); true
987 with Not_found -> false)
988 then (
989 let maxrows = (min (Array.length outlines) (maxoutlinerows ())) / 2 in
990 if first > n
991 then Some (n, max 0 (n - maxrows))
992 else Some (n, max first (n - maxrows))
994 else loop (n + incr)
996 loop active
999 let re = Str.regexp_case_fold pattern in
1000 dosearch re
1001 with Failure s ->
1002 state.text <- s;
1003 None
1005 match key with
1006 | 27 ->
1007 if String.length qsearch = 0
1008 then (
1009 state.text <- "";
1010 state.outline <- None;
1011 Glut.postRedisplay ();
1013 else (
1014 state.text <- "";
1015 state.outline <- Some (allowdel, active, first, outlines, "");
1016 Glut.postRedisplay ();
1019 | 18 | 19 ->
1020 let incr = if key = 18 then -1 else 1 in
1021 let active, first =
1022 match search (active + incr) qsearch incr with
1023 | None ->
1024 state.text <- qsearch ^ " [not found]";
1025 active, first
1026 | Some af ->
1027 state.text <- qsearch;
1030 state.outline <- Some (allowdel, active, first, outlines, qsearch);
1031 Glut.postRedisplay ();
1033 | 8 ->
1034 let len = String.length qsearch in
1035 if len = 0
1036 then ()
1037 else (
1038 if len = 1
1039 then (
1040 state.text <- "";
1041 state.outline <- Some (allowdel, active, first, outlines, "");
1043 else
1044 let qsearch = String.sub qsearch 0 (len - 1) in
1045 state.text <- qsearch;
1046 state.outline <- Some (allowdel, active, first, outlines, qsearch);
1048 Glut.postRedisplay ()
1050 | 13 ->
1051 if active < Array.length outlines
1052 then (
1053 let (_, _, n, t) = outlines.(active) in
1054 gotopage n t;
1056 state.text <- "";
1057 if allowdel then state.bookmarks <- Array.to_list outlines;
1058 state.outline <- None;
1059 Glut.postRedisplay ();
1061 | _ when key >= 32 && key < 127 ->
1062 let pattern = addchar qsearch (Char.chr key) in
1063 let active, first =
1064 match search active pattern 1 with
1065 | None ->
1066 state.text <- pattern ^ " [not found]";
1067 active, first
1068 | Some (active, first) ->
1069 state.text <- pattern;
1070 active, first
1072 state.outline <- Some (allowdel, active, first, outlines, pattern);
1073 Glut.postRedisplay ()
1075 | 127 when allowdel ->
1076 let len = Array.length outlines - 1 in
1077 if len = 0
1078 then (
1079 state.outline <- None;
1080 state.bookmarks <- [];
1082 else (
1083 let bookmarks = Array.init len
1084 (fun i ->
1085 let i = if i >= active then i + 1 else i in
1086 outlines.(i)
1089 state.outline <-
1090 Some (allowdel,
1091 min active (len-1),
1092 min first (len-1),
1093 bookmarks, qsearch)
1096 Glut.postRedisplay ()
1098 | _ -> log "unknown key %d" key
1101 let keyboard ~key ~x ~y =
1102 match state.outline with
1103 | None -> viewkeyboard ~key ~x ~y
1104 | Some outline -> outlinekeyboard ~key ~x ~y outline
1107 let special ~key ~x ~y =
1108 match state.outline with
1109 | None ->
1110 let y =
1111 match key with
1112 | Glut.KEY_F3 -> search state.searchpattern true; state.y
1113 | Glut.KEY_UP -> clamp (-conf.scrollincr)
1114 | Glut.KEY_DOWN -> clamp conf.scrollincr
1115 | Glut.KEY_PAGE_UP -> clamp (-state.h)
1116 | Glut.KEY_PAGE_DOWN -> clamp state.h
1117 | Glut.KEY_HOME -> addnav (); 0
1118 | Glut.KEY_END ->
1119 addnav ();
1120 state.maxy - (if conf.maxhfit then state.h else 0)
1121 | _ -> state.y
1123 state.text <- "";
1124 gotoy y
1126 | Some (allowdel, active, first, outlines, qsearch) ->
1127 let maxrows = maxoutlinerows () in
1128 let navigate incr =
1129 let active = active + incr in
1130 let active = max 0 (min active (Array.length outlines - 1)) in
1131 let first =
1132 if active > first
1133 then
1134 let rows = active - first in
1135 if rows > maxrows then first + incr else first
1136 else active
1138 state.outline <- Some (allowdel, active, first, outlines, qsearch);
1139 Glut.postRedisplay ()
1141 match key with
1142 | Glut.KEY_UP -> navigate ~-1
1143 | Glut.KEY_DOWN -> navigate 1
1144 | Glut.KEY_PAGE_UP -> navigate ~-maxrows
1145 | Glut.KEY_PAGE_DOWN -> navigate maxrows
1147 | Glut.KEY_HOME ->
1148 state.outline <- Some (allowdel, 0, 0, outlines, qsearch);
1149 Glut.postRedisplay ()
1151 | Glut.KEY_END ->
1152 let active = Array.length outlines - 1 in
1153 let first = max 0 (active - maxrows) in
1154 state.outline <- Some (allowdel, active, first, outlines, qsearch);
1155 Glut.postRedisplay ()
1157 | _ -> ()
1160 let drawplaceholder l =
1161 if true
1162 then (
1163 GlDraw.color (0.2, 0.2, 0.2);
1164 GlDraw.color (1.0, 1.0, 1.0);
1165 GlDraw.rect
1166 (0.0, float l.pagedispy)
1167 (float l.pagew, float (l.pagedispy + l.pagevh))
1169 let x = 0.0
1170 and y = float (l.pagedispy + 13) in
1171 let font = Glut.BITMAP_8_BY_13 in
1172 GlDraw.color (0.0, 0.0, 0.0);
1173 GlPix.raster_pos ~x ~y ();
1174 String.iter (fun c -> Glut.bitmapCharacter ~font ~c:(Char.code c))
1175 ("Loading " ^ string_of_int l.pageno);
1177 else (
1178 GlDraw.begins `quads;
1179 GlDraw.vertex2 (0.0, float l.pagedispy);
1180 GlDraw.vertex2 (float l.pagew, float l.pagedispy);
1181 GlDraw.vertex2 (float l.pagew, float (l.pagedispy + l.pagevh));
1182 GlDraw.vertex2 (0.0, float (l.pagedispy + l.pagevh));
1183 GlDraw.ends ();
1187 let now () = Unix.gettimeofday ();;
1189 let drawpage i l =
1190 begin match getopaque l.pageno with
1191 | Some opaque when validopaque opaque ->
1192 GlDraw.color (1.0, 1.0, 1.0);
1193 let a = now () in
1194 draw l.pagedispy l.pagew l.pagevh l.pagey opaque;
1195 let b = now () in
1196 let d = b-.a in
1197 vlog "draw %f sec" d;
1199 | Some _ ->
1200 drawplaceholder l
1202 | None ->
1203 drawplaceholder l;
1204 if state.inflight < cblen state.pagecache
1205 then (
1206 List.iter preload state.layout;
1208 else (
1209 vlog "inflight %d" state.inflight;
1211 end;
1212 GlDraw.color (0.5, 0.5, 0.5);
1213 GlDraw.rect
1214 (0., float i)
1215 (float (state.w - conf.scrollw), float (i + (l.pagedispy - i)))
1217 l.pagedispy + l.pagevh;
1220 let scrollindicator () =
1221 let maxy = state.maxy - (if conf.maxhfit then state.h else 0) in
1222 GlDraw.color (0.64 , 0.64, 0.64);
1223 GlDraw.rect
1224 (float (state.w - conf.scrollw), 0.)
1225 (float state.w, float state.h)
1227 GlDraw.color (0.0, 0.0, 0.0);
1228 let sh = (float (maxy + state.h) /. float state.h) in
1229 let sh = float state.h /. sh in
1230 let sh = max sh (float conf.scrollh) in
1232 let percent =
1233 if state.y = state.maxy
1234 then 1.0
1235 else float state.y /. float maxy
1237 let position = (float state.h -. sh) *. percent in
1239 let position =
1240 if position +. sh > float state.h
1241 then
1242 float state.h -. sh
1243 else
1244 position
1246 GlDraw.rect
1247 (float (state.w - conf.scrollw), position)
1248 (float state.w, position +. sh)
1252 let showsel () =
1253 match state.mstate with
1254 | Mnone ->
1257 | Msel ((x0, y0), (x1, y1)) ->
1258 let y0' = min y0 y1
1259 and y1 = max y0 y1 in
1260 let y0 = y0' in
1261 let f l =
1262 if (y0 >= l.pagedispy && y0 <= (l.pagedispy + l.pagevh))
1263 || ((y1 >= l.pagedispy)) (* && y1 <= (dy + vh))) *)
1264 then
1265 match getopaque l.pageno with
1266 | Some opaque when validopaque opaque ->
1267 let oy = -l.pagey + l.pagedispy in
1268 gettext opaque (min x0 x1, y0, max x1 x0, y1) oy conf.rectsel
1269 | _ -> ()
1271 List.iter f state.layout
1274 let showrects () =
1275 Gl.enable `blend;
1276 GlDraw.color (0.0, 0.0, 1.0) ~alpha:0.5;
1277 GlFunc.blend_func `src_alpha `one_minus_src_alpha;
1278 List.iter
1279 (fun (pageno, c, (x0, y0), (x1, y1)) ->
1280 List.iter (fun l ->
1281 if l.pageno = pageno
1282 then (
1283 let d = float (l.pagedispy - l.pagey) in
1284 GlDraw.color (0.0, 0.0, 1.0 /. float c) ~alpha:0.5;
1285 GlDraw.rect (x0, y0 +. d) (x1, y1 +. d)
1287 ) state.layout
1288 ) state.rects
1290 Gl.disable `blend;
1293 let showoutline = function
1294 | None -> ()
1295 | Some (allowdel, active, first, outlines, qsearch) ->
1296 Gl.enable `blend;
1297 GlFunc.blend_func `src_alpha `one_minus_src_alpha;
1298 GlDraw.color (0., 0., 0.) ~alpha:0.85;
1299 GlDraw.rect (0., 0.) (float state.w, float state.h);
1300 Gl.disable `blend;
1302 GlDraw.color (1., 1., 1.);
1303 let font = Glut.BITMAP_9_BY_15 in
1304 let draw_string x y s =
1305 GlPix.raster_pos ~x ~y ();
1306 String.iter (fun c -> Glut.bitmapCharacter ~font ~c:(Char.code c)) s
1308 let rec loop row =
1309 if row = Array.length outlines || (row - first) * 16 > state.h
1310 then ()
1311 else (
1312 let (s, l, _, _) = outlines.(row) in
1313 let y = (row - first) * 16 in
1314 let x = 5 + 5*l in
1315 if row = active
1316 then (
1317 Gl.enable `blend;
1318 GlDraw.polygon_mode `both `line;
1319 GlFunc.blend_func `src_alpha `one_minus_src_alpha;
1320 GlDraw.color (1., 1., 1.) ~alpha:0.9;
1321 GlDraw.rect (0., float (y + 1))
1322 (float (state.w - conf.scrollw - 1), float (y + 18));
1323 GlDraw.polygon_mode `both `fill;
1324 Gl.disable `blend;
1325 GlDraw.color (1., 1., 1.);
1327 draw_string (float x) (float (y + 16)) s;
1328 loop (row+1)
1331 loop first
1334 let display () =
1335 let lasty = List.fold_left drawpage 0 (state.layout) in
1336 GlDraw.color (0.5, 0.5, 0.5);
1337 GlDraw.rect
1338 (0., float lasty)
1339 (float (state.w - conf.scrollw), float state.h)
1341 showrects ();
1342 scrollindicator ();
1343 showsel ();
1344 showoutline state.outline;
1345 enttext ();
1346 Glut.swapBuffers ();
1349 let getlink x y =
1350 let rec f = function
1351 | l :: rest ->
1352 begin match getopaque l.pageno with
1353 | Some opaque when validopaque opaque ->
1354 let y = y - l.pagedispy in
1355 if y > 0
1356 then
1357 let y = l.pagey + y in
1358 match getlink opaque x y with
1359 | None -> f rest
1360 | some -> some
1361 else
1362 f rest
1363 | _ ->
1364 f rest
1366 | [] -> None
1368 f state.layout
1371 let checklink x y =
1372 let rec f = function
1373 | l :: rest ->
1374 begin match getopaque l.pageno with
1375 | Some opaque when validopaque opaque ->
1376 let y = y - l.pagedispy in
1377 if y > 0
1378 then
1379 let y = l.pagey + y in
1380 if checklink opaque x y then true else f rest
1381 else
1382 f rest
1383 | _ ->
1384 f rest
1386 | [] -> false
1388 f state.layout
1391 let mouse ~button ~bstate ~x ~y =
1392 match button with
1393 | Glut.OTHER_BUTTON n when n == 3 || n == 4 && bstate = Glut.UP ->
1394 let incr =
1395 if n = 3
1396 then
1397 -conf.scrollincr
1398 else
1399 conf.scrollincr
1401 let incr = incr * 2 in
1402 let y = clamp incr in
1403 gotoy y
1405 | Glut.LEFT_BUTTON when state.outline = None ->
1406 let dest = if bstate = Glut.DOWN then getlink x y else None in
1407 begin match dest with
1408 | Some (pageno, top) ->
1409 gotopage pageno top
1411 | None ->
1412 if bstate = Glut.DOWN
1413 then (
1414 Glut.setCursor Glut.CURSOR_CROSSHAIR;
1415 state.mstate <- Msel ((x, y), (x, y));
1416 Glut.postRedisplay ()
1418 else (
1419 Glut.setCursor Glut.CURSOR_INHERIT;
1420 state.mstate <- Mnone;
1424 | _ ->
1427 let mouse ~button ~state ~x ~y = mouse button state x y;;
1429 let motion ~x ~y =
1430 if state.outline = None
1431 then
1432 match state.mstate with
1433 | Mnone -> ()
1434 | Msel (a, _) ->
1435 state.mstate <- Msel (a, (x, y));
1436 Glut.postRedisplay ()
1439 let pmotion ~x ~y =
1440 if state.outline = None
1441 then
1442 match state.mstate with
1443 | Mnone when (checklink x y) ->
1444 Glut.setCursor Glut.CURSOR_INFO
1446 | Mnone ->
1447 Glut.setCursor Glut.CURSOR_INHERIT
1449 | Msel (a, _) ->
1453 let () =
1454 let statepath = (Sys.getenv "HOME") ^ "/.config/llpp" in
1455 let pstate =
1457 let ic = open_in_bin statepath in
1458 let hash = input_value ic in
1459 close_in ic;
1460 hash
1461 with exn ->
1462 if false
1463 then
1464 prerr_endline ("Error loading state " ^ Printexc.to_string exn)
1466 Hashtbl.create 1
1468 let savestate () =
1470 let w, h =
1471 match state.fullscreen with
1472 | None -> state.w, state.h
1473 | Some wh -> wh
1475 if conf.markonquit then quickbookmark ();
1476 Hashtbl.replace pstate state.path (state.bookmarks, w, h);
1477 let oc = open_out_bin statepath in
1478 output_value oc pstate
1479 with exn ->
1480 if false
1481 then
1482 prerr_endline ("Error saving state " ^ Printexc.to_string exn)
1485 let setstate () =
1487 let statebookmarks, statew, stateh = Hashtbl.find pstate state.path in
1488 state.w <- statew;
1489 state.h <- stateh;
1490 state.bookmarks <- statebookmarks;
1491 with Not_found -> ()
1492 | exn ->
1493 prerr_endline ("Error setting state " ^ Printexc.to_string exn)
1496 Arg.parse [] (fun s -> state.path <- s) "options:";
1497 let name =
1498 if String.length state.path = 0
1499 then (prerr_endline "filename missing"; exit 1)
1500 else state.path
1503 setstate ();
1504 let _ = Glut.init Sys.argv in
1505 let () = Glut.initDisplayMode ~depth:false ~double_buffer:true () in
1506 let () = Glut.initWindowSize state.w state.h in
1507 let _ = Glut.createWindow ("llpp " ^ Filename.basename name) in
1509 let csock, ssock = Unix.socketpair Unix.PF_UNIX Unix.SOCK_STREAM 0 in
1511 init ssock;
1512 state.csock <- csock;
1513 state.ssock <- ssock;
1514 writecmd csock ("open " ^ name ^ "\000");
1516 let () = Glut.displayFunc display in
1517 let () = Glut.reshapeFunc reshape in
1518 let () = Glut.keyboardFunc keyboard in
1519 let () = Glut.specialFunc special in
1520 let () = Glut.idleFunc (Some idle) in
1521 let () = Glut.mouseFunc mouse in
1522 let () = Glut.motionFunc motion in
1523 let () = Glut.passiveMotionFunc pmotion in
1525 at_exit savestate;
1527 let rec handlelablglutbug () =
1529 Glut.mainLoop ();
1530 with Glut.BadEnum "key in special_of_int" ->
1531 showtext '!' " LablGlut bug: special key not recognized";
1532 Glut.swapBuffers ();
1533 handlelablglutbug ()
1535 handlelablglutbug ();