6 external init
: Unix.file_descr
-> params
-> unit = "ml_init";;
7 external seltext
: opaque
-> (int * int * int * int) -> unit = "ml_seltext";;
8 external hassel
: opaque
-> bool = "ml_hassel";;
9 external copysel
: Unix.file_descr
-> opaque
-> unit = "ml_copysel";;
10 external getpdimrect
: int -> float array
= "ml_getpdimrect";;
11 external whatsunder
: opaque
-> int -> int -> under
= "ml_whatsunder";;
12 external markunder
: opaque
-> int -> int -> mark
-> bool = "ml_markunder";;
13 external clearmark
: opaque
-> unit = "ml_clearmark";;
14 external zoomforh
: int -> int -> int -> int -> float = "ml_zoom_for_height";;
15 external drawstr
: int -> int -> int -> string -> float = "ml_draw_string";;
16 external measurestr
: int -> string -> float = "ml_measure_string";;
17 external postprocess
:
18 opaque
-> int -> int -> int -> (int * string * int) -> int
20 external pagebbox
: opaque
-> (int * int * int * int) = "ml_getpagebox";;
21 external setaalevel
: int -> unit = "ml_setaalevel";;
22 external realloctexts
: int -> bool = "ml_realloctexts";;
23 external findlink
: opaque
-> linkdir
-> link
= "ml_findlink";;
24 external getlink
: opaque
-> int -> under
= "ml_getlink";;
25 external getlinkrect
: opaque
-> int -> irect
= "ml_getlinkrect";;
26 external getlinkcount
: opaque
-> int = "ml_getlinkcount";;
27 external findpwl
: int -> int -> pagewithlinks
= "ml_find_page_with_links";;
28 external getpbo
: width
-> height
-> colorspace
-> opaque
= "ml_getpbo";;
29 external freepbo
: opaque
-> unit = "ml_freepbo";;
30 external unmappbo
: opaque
-> unit = "ml_unmappbo";;
31 external pbousable
: unit -> bool = "ml_pbo_usable";;
32 external unproject
: opaque
-> int -> int -> (int * int) option
34 external drawtile
: tileparams
-> opaque
-> unit = "ml_drawtile";;
35 external rectofblock
: opaque
-> int -> int -> float array
option
37 external begintiles
: unit -> unit = "ml_begintiles";;
38 external endtiles
: unit -> unit = "ml_endtiles";;
40 let reeenterhist = ref false;;
41 let selfexec = ref E.s
;;
43 let drawstring size x y s
=
45 Gl.enable `texture_2d
;
46 GlFunc.blend_func ~src
:`src_alpha ~dst
:`one_minus_src_alpha
;
47 ignore
(drawstr size x y s
);
49 Gl.disable `texture_2d
;
52 let drawstring1 size x y s
=
56 let drawstring2 size x y fmt
=
57 Printf.kprintf
(drawstring size
(x
+1) (y
+size
+1)) fmt
61 dolog
"l %d dim=%d {" l
.pageno l
.pagedimno
;
62 dolog
" WxH %dx%d" l
.pagew l
.pageh
;
63 dolog
" vWxH %dx%d" l
.pagevw l
.pagevh
;
64 dolog
" pagex,y %d,%d" l
.pagex l
.pagey
;
65 dolog
" dispx,y %d,%d" l
.pagedispx l
.pagedispy
;
66 dolog
" column %d" l
.pagecol
;
70 let debugrect (x0
, y0
, x1
, y1
, x2
, y2
, x3
, y3
) =
72 dolog
" x0,y0=(% f, % f)" x0 y0
;
73 dolog
" x1,y1=(% f, % f)" x1 y1
;
74 dolog
" x2,y2=(% f, % f)" x2 y2
;
75 dolog
" x3,y3=(% f, % f)" x3 y3
;
79 let isbirdseye = function
86 let istextentry = function
93 let wtmode = ref false;;
94 let cxack = ref false;;
96 let pgscale h
= truncate
(float h
*. conf
.pgscale);;
99 if not state
.uioh#alwaysscrolly
&& (conf
.scrollb
land scrollbhv
= 0)
100 || (state
.x
= 0 && state
.w
<= state
.winw
- conf
.scrollbw
)
106 if not state
.uioh#alwaysscrolly
&& (conf
.scrollb
land scrollbvv
= 0)
111 let wadjsb () = -vscrollw ();;
112 let xadjsb () = if conf
.leftscroll
then vscrollw () else 0;;
115 fstate
.fontsize
<- n
;
116 fstate
.wwidth
<- measurestr fstate
.fontsize
"w";
117 fstate
.maxrows
<- (state
.winh
- fstate
.fontsize
- 1) / (fstate
.fontsize
+ 1);
123 Printf.kprintf prerr_endline fmt
125 Printf.kprintf ignore fmt
129 if emptystr conf
.pathlauncher
130 then print_endline state
.path
132 let re = Str.regexp
"%s" in
133 let command = Str.global_replace
re state
.path conf
.pathlauncher
in
136 Printf.eprintf
"failed to execute `%s': %s\n" command (exntos exn
);
141 let redirectstderr () =
142 let clofail what errmsg
= dolog
"failed to close %s: %s" what errmsg
in
143 if conf
.redirectstderr
145 match Unix.pipe
() with
147 dolog
"failed to create stderr redirection pipes: %s" (exntos exn
)
150 begin match Unix.dup
Unix.stderr
with
152 dolog
"failed to dup stderr: %s" (exntos exn
);
153 Ne.clo r
(clofail "pipe/r");
154 Ne.clo w
(clofail "pipe/w");
157 begin match Unix.dup2 w
Unix.stderr
with
159 dolog
"failed to dup2 to stderr: %s" (exntos exn
);
160 Ne.clo dupstderr
(clofail "stderr duplicate");
161 Ne.clo r
(clofail "redir pipe/r");
162 Ne.clo w
(clofail "redir pipe/w");
165 state
.stderr
<- dupstderr
;
166 state
.errfd
<- Some r
;
170 state
.newerrmsgs
<- false;
171 begin match state
.errfd
with
173 begin match Unix.dup2 state
.stderr
Unix.stderr
with
175 dolog
"failed to dup2 original stderr: %s" (exntos exn
)
177 Ne.clo fd
(clofail "dup of stderr");
182 prerr_string
(Buffer.contents state
.errmsgs
);
184 Buffer.clear state
.errmsgs
;
190 let postRedisplay who
=
192 then prerr_endline
("redisplay for " ^ who
);
193 state
.redisplay
<- true;
197 let getopaque pageno
=
198 try Some
(Hashtbl.find state
.pagemap
(pageno
, state
.gen
))
199 with Not_found
-> None
202 let putopaque pageno opaque
=
203 Hashtbl.replace state
.pagemap
(pageno
, state
.gen
) opaque
206 let pagetranslatepoint l x y
=
207 let dy = y
- l
.pagedispy
in
208 let y = dy + l
.pagey
in
209 let dx = x
- l
.pagedispx
in
210 let x = dx + l
.pagex
in
214 let onppundermouse g
x y d
=
217 begin match getopaque l
.pageno
with
219 let x0 = l
.pagedispx
in
220 let x1 = x0 + l
.pagevw
in
221 let y0 = l
.pagedispy
in
222 let y1 = y0 + l
.pagevh
in
223 if y >= y0 && y <= y1 && x >= x0 && x <= x1
225 let px, py
= pagetranslatepoint l
x y in
226 match g opaque l
px py
with
239 let g opaque l
px py
=
242 match rectofblock opaque
px py
with
244 let rect = (a
.(0),a
.(2),a
.(1),a
.(2),a
.(1),a
.(3),a
.(0),a
.(3)) in
245 state
.rects
<- [l
.pageno
, l
.pageno
mod 3, rect];
246 G.postRedisplay "getunder";
249 let under = whatsunder opaque
px py
in
260 | Uannotation _
-> Some
under
262 onppundermouse g x y Unone
267 match unproject opaque
x y with
268 | Some
(x, y) -> Some
(Some
(l
.pageno
, x, y))
271 onppundermouse g x y None
;
275 state
.text
<- Printf.sprintf
"%c%s" c s
;
276 G.postRedisplay "showtext";
279 let pipesel opaque cmd
=
282 match Unix.pipe
() with
285 (Printf.sprintf
"pipesel can not create pipe: %s" (exntos exn
));
287 let doclose what fd
=
288 Ne.clo fd
(fun msg
-> dolog
"%s close failed: %s" what msg
)
291 try popen cmd
[r
, 0; w
, -1]; true
293 dolog
"can not execute %S: %s" cmd
(exntos exn
);
299 G.postRedisplay "pipesel";
301 else doclose "pipesel pipe/w" w
;
302 doclose "pipesel pipe/r" r
;
306 let g opaque l
px py
=
307 if markunder opaque
px py conf
.paxmark
310 match getopaque l
.pageno
with
312 | Some opaque
-> pipesel opaque conf
.paxcmd
317 G.postRedisplay "paxunder";
318 if conf
.paxmark
= Mark_page
321 match getopaque l
.pageno
with
323 | Some opaque
-> clearmark opaque
) state
.layout
;
325 onppundermouse g x y (fun () -> showtext '
!'
"Whoopsie daisy");
329 match Unix.pipe
() with
331 showtext '
!'
(Printf.sprintf
"pipe failed: %s" (exntos exn
))
334 Ne.clo fd
(fun msg
->
335 showtext '
!'
(Printf.sprintf
"failed to close %s: %s" cap msg
)
339 try popen conf
.selcmd
[r
, 0; w
, -1]; true
342 (Printf.sprintf
"failed to execute %s: %s"
343 conf
.selcmd
(exntos exn
));
349 let l = String.length s
in
350 let bytes = Bytes.unsafe_of_string s
in
351 let n = tempfailureretry
(Unix.write w
bytes 0) l in
356 "failed to write %d characters to sel pipe, wrote %d"
361 (Printf.sprintf
"failed to write to sel pipe: %s"
366 clo "selstring pipe/r" r
;
367 clo "selstring pipe/w" w
;
370 let undertext = function
373 | Ulinkgoto
(pageno
, _
) -> Printf.sprintf
"%s: page %d" state
.path
(pageno
+1)
374 | Utext s
-> "font: " ^ s
375 | Uunexpected s
-> "unexpected: " ^ s
376 | Ulaunch s
-> "launch: " ^ s
377 | Unamed s
-> "named: " ^ s
378 | Uremote
(filename
, pageno
) ->
379 Printf.sprintf
"%s: page %d" filename
(pageno
+1)
380 | Uremotedest
(filename
, destname
) ->
381 Printf.sprintf
"%s: destination %S" filename destname
382 | Uannotation contents
->
383 Printf.sprintf
"annotation " ^ contents
386 let updateunder x y =
387 match getunder x y with
388 | Unone
-> Wsi.setcursor
Wsi.CURSOR_INHERIT
390 if conf
.underinfo
then showtext 'u'
("ri: " ^ uri
);
391 Wsi.setcursor
Wsi.CURSOR_INFO
392 | Ulinkgoto
(pageno
, _
) ->
394 then showtext 'p'
("age: " ^ string_of_int
(pageno
+1));
395 Wsi.setcursor
Wsi.CURSOR_INFO
397 if conf
.underinfo
then showtext '
f'
("ont: " ^ s
);
398 Wsi.setcursor
Wsi.CURSOR_TEXT
400 if conf
.underinfo
then showtext 'u'
("nexpected: " ^ s
);
401 Wsi.setcursor
Wsi.CURSOR_INHERIT
403 if conf
.underinfo
then showtext '
l'
("aunch: " ^ s
);
404 Wsi.setcursor
Wsi.CURSOR_INHERIT
406 if conf
.underinfo
then showtext '
n'
("amed: " ^ s
);
407 Wsi.setcursor
Wsi.CURSOR_INHERIT
408 | Uremote
(filename
, pageno
) ->
409 if conf
.underinfo
then showtext 'r'
410 (Printf.sprintf
"emote: %s (%d)" filename
(pageno
+1));
411 Wsi.setcursor
Wsi.CURSOR_INFO
412 | Uremotedest
(filename
, destname
) ->
413 if conf
.underinfo
then showtext 'r'
414 (Printf.sprintf
"emote destination: %s (%S)" filename destname
);
415 Wsi.setcursor
Wsi.CURSOR_INFO
417 if conf
.underinfo
then showtext 'a'
"nnotation";
418 Wsi.setcursor
Wsi.CURSOR_INFO
421 let showlinktype under =
435 let s = undertext under in
440 let b = Buffer.create
(String.length
s + 1) in
441 Buffer.add_string
b s;
446 let intentry_with_suffix text key
=
448 if key
>= 32 && key
< 127
452 match Char.lowercase
c with
454 let text = addchar text c in
458 let text = addchar text c in
462 state
.text <- Printf.sprintf
"invalid char (%d, `%c')" key
c;
467 let s = Bytes.create
4 in
468 let n = tempfailureretry
(Unix.read fd
s 0) 4 in
469 if n != 4 then error
"incomplete read(len) = %d" n;
470 let len = (Char.code
(Bytes.get
s 0) lsl 24)
471 lor (Char.code
(Bytes.get
s 1) lsl 16)
472 lor (Char.code
(Bytes.get
s 2) lsl 8)
473 lor (Char.code
(Bytes.get
s 3))
475 let s = Bytes.create
len in
476 let n = tempfailureretry
(Unix.read fd
s 0) len in
477 if n != len then error
"incomplete read(data) %d vs %d" n len;
481 let btod b = if b then 1 else 0;;
484 let b = Buffer.create
16 in
485 Buffer.add_string
b "llll";
488 let s = Buffer.to_bytes
b in
489 let n = Bytes.length
s in
491 (* dolog "wcmd %S" (String.sub s 4 len); *)
492 Bytes.set
s 0 (Char.chr
((len lsr 24) land 0xff));
493 Bytes.set
s 1 (Char.chr
((len lsr 16) land 0xff));
494 Bytes.set
s 2 (Char.chr
((len lsr 8) land 0xff));
495 Bytes.set
s 3 (Char.chr
(len land 0xff));
496 let n'
= tempfailureretry
(Unix.write state
.ss
s 0) n in
497 if n'
!= n then error
"write failed %d vs %d" n'
n;
501 let nogeomcmds cmds
=
503 | s, [] -> emptystr
s
507 let layoutN ((columns
, coverA
, coverB
), b) y sh
=
508 let sh = sh - (hscrollh ()) in
509 let wadj = wadjsb () in
510 let rec fold accu
n =
511 if n = Array.length
b
514 let pdimno, dx, vy
, (_
, w
, h
, xoff
) = b.(n) in
517 || n = state
.pagecount
- coverB
518 || (n - coverA
) mod columns
= columns
- 1)
524 let pagey = max
0 (y - vy
) in
525 let pagedispy = if pagey > 0 then 0 else vy
- y in
526 let pagedispx, pagex
=
528 if n = coverA
- 1 || n = state
.pagecount
- coverB
529 then state
.x + (wadj + state
.winw
- w
) / 2
530 else dx + xoff
+ state
.x
537 let vw = wadj + state
.winw
- pagedispx in
538 let pw = w
- pagex
in
541 let pagevh = min
(h
- pagey) (sh - pagedispy) in
542 if pagevw > 0 && pagevh > 0
553 ; pagedispx = pagedispx
554 ; pagedispy = pagedispy
566 if Array.length
b = 0
568 else List.rev
(fold [] (page_of_y
y))
571 let layoutS (columns
, b) y sh =
572 let sh = sh - hscrollh () in
573 let wadj = wadjsb () in
574 let rec fold accu n =
575 if n = Array.length
b
578 let pdimno, px, vy
, (_
, pagew
, pageh
, xoff
) = b.(n) in
585 let x = xoff
+ state
.x in
586 let pagey = max
0 (y - vy
) in
587 let pagedispy = if pagey > 0 then 0 else vy
- y in
588 let pagedispx, pagex
=
602 let pagecolw = pagew
/columns
in
604 if pagecolw < state
.winw
605 then pagedispx + ((wadj + state
.winw
- pagecolw) / 2)
609 let vw = wadj + state
.winw
- pagedispx in
610 let pw = pagew
- pagex
in
613 let pagevw = min
pagevw pagecolw in
614 let pagevh = min
(pageh
- pagey) (sh - pagedispy) in
615 if pagevw > 0 && pagevh > 0
626 ; pagedispx = pagedispx
627 ; pagedispy = pagedispy
628 ; pagecol
= n mod columns
643 if nogeomcmds state
.geomcmds
645 match conf
.columns
with
646 | Csingle
b -> layoutN ((1, 0, 0), b) y sh
647 | Cmulti
c -> layoutN c y sh
648 | Csplit
s -> layoutS s y sh
653 let y = state
.y + incr
in
655 let y = min
y (state
.maxy
- (if conf
.maxhfit
then state
.winh
else 0)) in
660 let tilex = l.pagex
mod conf
.tilew
in
661 let tiley = l.pagey mod conf
.tileh
in
663 let col = l.pagex
/ conf
.tilew
in
664 let row = l.pagey / conf
.tileh
in
666 let xadj = xadjsb () in
667 let rec rowloop row y0 dispy h
=
671 let dh = conf
.tileh
- y0 in
673 let rec colloop col x0 dispx w
=
677 let dw = conf
.tilew
- x0 in
679 let dispx'
= xadj + dispx in
680 f col row dispx' dispy
x0 y0 dw dh;
681 colloop (col+1) 0 (dispx+dw) (w
-dw)
684 colloop col tilex l.pagedispx l.pagevw;
685 rowloop (row+1) 0 (dispy
+dh) (h
-dh)
688 if l.pagevw > 0 && l.pagevh > 0
689 then rowloop row tiley l.pagedispy l.pagevh;
692 let gettileopaque l col row =
694 l.pageno
, state
.gen
, conf
.colorspace
, conf
.angle
, l.pagew
, l.pageh
, col, row
696 try Some
(Hashtbl.find state
.tilemap
key)
697 with Not_found
-> None
700 let puttileopaque l col row gen colorspace angle opaque size elapsed
=
701 let key = l.pageno
, gen
, colorspace
, angle
, l.pagew
, l.pageh
, col, row in
702 Hashtbl.add state
.tilemap
key (opaque
, size
, elapsed
)
705 let filledrect x0 y0 x1 y1 =
706 GlArray.disable `texture_coord
;
707 Raw.sets_float state
.vraw ~pos
:0 [| x0; y0; x0; y1; x1; y0; x1; y1 |];
708 GlArray.vertex `two state
.vraw
;
709 GlArray.draw_arrays `triangle_strip ~first
:0 ~count
:4;
710 GlArray.enable `texture_coord
;
713 let linerect x0 y0 x1 y1 =
714 GlArray.disable `texture_coord
;
715 Raw.sets_float state
.vraw ~pos
:0 [| x0; y0; x0; y1; x1; y1; x1; y0 |];
716 GlArray.vertex `two state
.vraw
;
717 GlArray.draw_arrays `line_loop ~first
:0 ~count
:4;
718 GlArray.enable `texture_coord
;
721 let drawtiles l color
=
723 let wadj = wadjsb () in
725 let f col row x y tilex tiley w h
=
726 match gettileopaque l col row with
727 | Some
(opaque
, _
, t
) ->
728 let params = x, y, w
, h
, tilex, tiley in
730 then GlTex.env
(`mode `blend
);
731 drawtile
params opaque
;
733 then GlTex.env
(`mode `modulate
);
737 let s = Printf.sprintf
741 let w = measurestr fstate
.fontsize
s in
742 GlDraw.color
(0.0, 0.0, 0.0);
743 filledrect (float (x-2))
746 (float (y + fstate
.fontsize
+ 2));
747 GlDraw.color
(1.0, 1.0, 1.0);
748 drawstring fstate
.fontsize
x (y + fstate
.fontsize
- 1) s;
758 let lw = wadj + state
.winw
- x in
761 let lh = state
.winh
- y in
765 then GlTex.env
(`mode `blend
);
766 begin match state
.checkerstexid
with
768 Gl.enable `texture_2d
;
769 GlTex.bind_texture ~target
:`texture_2d id
;
773 and y1 = float (y+h
) in
775 let tw = float w /. 16.0
776 and th
= float h
/. 16.0 in
777 let tx0 = float tilex /. 16.0
778 and ty0
= float tiley /. 16.0 in
780 and ty1
= ty0
+. th
in
781 Raw.sets_float state
.vraw ~pos
:0
782 [| x0; y0; x0; y1; x1; y0; x1; y1 |];
783 Raw.sets_float state
.traw ~pos
:0
784 [| tx0; ty0
; tx0; ty1
; tx1; ty0
; tx1; ty1
|];
785 GlArray.vertex `two state
.vraw
;
786 GlArray.tex_coord `two state
.traw
;
787 GlArray.draw_arrays `triangle_strip ~first
:0 ~count
:4;
788 Gl.disable `texture_2d
;
791 GlDraw.color
(1.0, 1.0, 1.0);
792 filledrect (float x) (float y) (float (x+w)) (float (y+h
));
795 then GlTex.env
(`mode `modulate
);
796 if w > 128 && h
> fstate
.fontsize
+ 10
798 let c = if conf
.invert
then 1.0 else 0.0 in
799 GlDraw.color
(c, c, c);
802 then (col*conf
.tilew
, row*conf
.tileh
)
805 drawstring2 fstate
.fontsize
x y "Loading %d [%d,%d]" l.pageno
c r
;
814 let pagevisible layout n = List.exists
(fun l -> l.pageno
= n) layout;;
816 let tilevisible1 l x y =
818 and ax1
= l.pagex
+ l.pagevw
820 and ay1
= l.pagey + l.pagevh in
824 let bx1 = min
(bx0 + conf
.tilew
) l.pagew
825 and by1
= min
(by0
+ conf
.tileh
) l.pageh
in
827 let rx0 = max
ax0 bx0
828 and ry0
= max ay0 by0
829 and rx1
= min ax1
bx1
830 and ry1
= min ay1 by1
in
832 let nonemptyintersection = rx1
> rx0 && ry1
> ry0
in
836 let tilevisible layout n x y =
837 let rec findpageinlayout m
= function
838 | l :: rest
when l.pageno
= n ->
839 tilevisible1 l x y || (
840 match conf
.columns
with
841 | Csplit
(c, _
) when c > m
-> findpageinlayout (m
+1) rest
846 | _
:: rest
-> findpageinlayout 0 rest
849 findpageinlayout 0 layout;
852 let tileready l x y =
853 tilevisible1 l x y &&
854 gettileopaque l (x/conf
.tilew
) (y/conf
.tileh
) != None
857 let tilepage n p
layout =
858 let rec loop = function
862 let f col row _ _ _ _ _ _
=
863 if state
.currently
= Idle
865 match gettileopaque l col row with
868 let x = col*conf
.tilew
869 and y = row*conf
.tileh
in
871 let w = l.pagew
- x in
875 let h = l.pageh
- y in
880 then getpbo
w h conf
.colorspace
883 wcmd "tile %s %d %d %d %d %s"
884 (~
> p
) x y w h (~
> pbo);
887 l, p
, conf
.colorspace
, conf
.angle
,
888 state
.gen
, col, row, conf
.tilew
, conf
.tileh
897 if nogeomcmds state
.geomcmds
901 let preloadlayout y =
902 let y = if y < state
.winh
then 0 else y - state
.winh
in
903 let h = state
.winh
*3 in
909 if state
.currently
!= Idle
914 begin match getopaque l.pageno
with
916 wcmd "page %d %d" l.pageno
l.pagedimno
;
917 state
.currently
<- Loading
(l, state
.gen
);
919 tilepage l.pageno opaque pages
;
924 if nogeomcmds state
.geomcmds
930 if conf
.preload && state
.currently
= Idle
931 then load (preloadlayout state
.y);
934 let layoutready layout =
935 let rec fold all ls
=
938 let seen = ref false in
939 let allvisible = ref true in
940 let foo col row _ _ _ _ _ _
=
942 allvisible := !allvisible &&
943 begin match gettileopaque l col row with
949 fold (!seen && !allvisible) rest
952 let alltilesvisible = fold true layout in
957 let y = bound
y 0 state
.maxy
in
958 let y, layout, proceed
=
959 match conf
.maxwait
with
960 | Some time
when state
.ghyll
== noghyll
->
961 begin match state
.throttle
with
963 let layout = layout y state
.winh
in
964 let ready = layoutready layout in
968 state
.throttle
<- Some
(layout, y, now
());
970 else G.postRedisplay "gotoy showall (None)";
972 | Some
(_
, _
, started
) ->
973 let dt = now
() -. started
in
976 state
.throttle
<- None
;
977 let layout = layout y state
.winh
in
979 G.postRedisplay "maxwait";
986 let layout = layout y state
.winh
in
987 if not
!wtmode || layoutready layout
988 then G.postRedisplay "gotoy ready";
994 state
.layout <- layout;
995 begin match state
.mode
with
998 | Ltexact
(pageno
, linkno
) ->
999 let rec loop = function
1001 state
.mode
<- LinkNav
(Ltgendir
0)
1002 | l :: _
when l.pageno
= pageno
->
1003 begin match getopaque pageno
with
1005 state
.mode
<- LinkNav
(Ltgendir
0)
1007 let x0, y0, x1, y1 = getlinkrect opaque linkno
in
1008 if not
(x0 >= l.pagex
&& x1 <= l.pagex
+ l.pagevw
1009 && y0 >= l.pagey && y1 <= l.pagey + l.pagevh)
1010 then state
.mode
<- LinkNav
(Ltgendir
0)
1012 | _
:: rest
-> loop rest
1021 begin match state
.mode
with
1022 | Birdseye
(conf
, leftx
, pageno
, hooverpageno
, anchor
) ->
1023 if not
(pagevisible layout pageno
)
1025 match state
.layout with
1028 state
.mode
<- Birdseye
(
1029 conf
, leftx
, l.pageno
, hooverpageno
, anchor
1036 let rec loop = function
1039 match getopaque l.pageno
with
1045 then LDfirstvisible
(l.pagex
, l.pagey, dir
)
1047 if dir
> 0 then LDfirst
else LDlast
1053 | Lnotfound
-> loop rest
1055 showlinktype (getlink opaque
n);
1056 Ltexact
(l.pageno
, n)
1060 state
.mode
<- LinkNav
linknav
1068 state
.ghyll
<- noghyll
;
1071 let mx, my
= state
.mpos
in
1076 let conttiling pageno opaque
=
1077 tilepage pageno opaque
1078 (if conf
.preload then preloadlayout state
.y else state
.layout)
1081 let gotoy_and_clear_text y =
1082 if not conf
.verbose
then state
.text <- E.s;
1086 let getanchory (n, top
, dtop
) =
1087 let y, h = getpageyh
n in
1088 if conf
.presentation
1090 let ips = calcips
h in
1091 y + truncate
(top
*.float h -. dtop
*.float ips) + ips;
1093 y + truncate
(top
*.float h -. dtop
*.float conf
.interpagespace
)
1096 let gotoanchor anchor
=
1097 gotoy (getanchory anchor
);
1101 cbput state
.hists
.nav
(getanchor
());
1105 let anchor = cbgetc state
.hists
.nav dir
in
1109 let gotoghyll1 single
y =
1110 let scroll f n a
b =
1111 (* http://devmaster.net/forums/topic/9796-ease-in-ease-out-algorithm/ *)
1113 let s x = 3.0*.x**2.0 -. 2.0*.x**3.0 in
1115 then s (float f /. float a
)
1118 then 1.0 -. s ((float (f-b) /. float (n-b)))
1124 let ins = float a
*. 0.5
1125 and outs
= float (n-b) *. 0.5 in
1127 ins +. outs
+. float ones
1129 let rec set nab
y sy
=
1130 let (_N
, _A
, _B
), y =
1133 let scl = if y > sy
then 2 else -2 in
1134 let _N, _
, _
= nab
in
1135 (_N,0,_N), y+conf
.scrollstep
*scl
1137 let sum = summa
_N _A _B
in
1138 let dy = float (y - sy
) in
1142 then state
.ghyll
<- noghyll
1145 let s = scroll n _N _A _B
in
1146 let y1 = y1 +. ((s *. dy) /. sum) in
1147 gotoy_and_clear_text (truncate
y1);
1148 state
.ghyll
<- gf (n+1) y1;
1152 | Some
y'
when single
-> set nab
y' state
.y
1153 | Some
y'
-> set (_N/2, 1, 1) y' state
.y
1155 gf 0 (float state
.y)
1158 match conf
.ghyllscroll
with
1159 | Some nab
when not conf
.presentation
->
1160 if state
.ghyll
== noghyll
1161 then set nab
y state
.y
1162 else state
.ghyll
(Some
y)
1164 gotoy_and_clear_text y
1167 let gotoghyll = gotoghyll1 false;;
1169 let gotopage n top
=
1170 let y, h = getpageyh
n in
1171 let y = y + (truncate
(top
*. float h)) in
1175 let gotopage1 n top
=
1176 let y = getpagey
n in
1181 let invalidate s f =
1186 match state
.geomcmds
with
1187 | ps
, [] when emptystr ps
->
1189 state
.geomcmds
<- s, [];
1192 state
.geomcmds
<- ps
, [s, f];
1194 | ps
, (s'
, _
) :: rest
when s'
= s ->
1195 state
.geomcmds
<- ps
, ((s, f) :: rest
);
1198 state
.geomcmds
<- ps
, ((s, f) :: cmds
);
1202 Hashtbl.iter
(fun _ opaque
->
1203 wcmd "freepage %s" (~
> opaque
);
1205 Hashtbl.clear state
.pagemap
;
1209 if not
(Queue.is_empty state
.tilelru
)
1211 Queue.iter
(fun (k
, p
, s) ->
1212 wcmd "freetile %s" (~
> p
);
1213 state
.memused
<- state
.memused
- s;
1214 Hashtbl.remove state
.tilemap k
;
1216 state
.uioh#infochanged Memused
;
1217 Queue.clear state
.tilelru
;
1223 let h = truncate
(float h*.conf
.zoom
) in
1224 let d = conf
.interpagespace
lsl (if conf
.presentation
then 1 else 0) in
1228 let opendoc path password
=
1230 state
.password
<- password
;
1231 state
.gen
<- state
.gen
+ 1;
1232 state
.docinfo
<- [];
1233 state
.outlines
<- [||];
1236 setaalevel conf
.aalevel
;
1238 if emptystr state
.origin
1242 Wsi.settitle
("llpp " ^
(mbtoutf8
(Filename.basename
titlepath)));
1243 wcmd "open %d %d %s\000%s\000" (btod !wtmode) (btod !cxack) path password
;
1244 invalidate "reqlayout"
1246 wcmd "reqlayout %d %d %d %s\000"
1247 conf
.angle
(FMTE.to_int conf
.fitmodel
)
1248 (stateh state
.winh
) state
.nameddest
1253 state
.anchor <- getanchor
();
1254 opendoc state
.path state
.password
;
1258 let c = c *. conf
.colorscale
in
1262 let scalecolor2 (r
, g, b) =
1263 (r
*. conf
.colorscale
, g *. conf
.colorscale
, b *. conf
.colorscale
);
1266 let docolumns columns
=
1267 let wadj = wadjsb () in
1270 let a = Array.make state
.pagecount
(-1, -1, -1, (-1, -1, -1, -1)) in
1271 let wadj = wadjsb () in
1272 let rec loop pageno
pdimno pdim
y ph pdims
=
1273 if pageno
= state
.pagecount
1276 let pdimno, ((_
, w, h, xoff
) as pdim
), pdims
=
1278 | ((pageno'
, _
, _
, _
) as pdim
) :: rest
when pageno'
= pageno
->
1279 pdimno+1, pdim
, rest
1283 let x = max
0 (((wadj + state
.winw
- w) / 2) - xoff
) in
1285 (if conf
.presentation
1286 then (if pageno
= 0 then calcips
h else calcips ph
+ calcips
h)
1287 else (if pageno
= 0 then 0 else conf
.interpagespace
)
1290 a.(pageno
) <- (pdimno, x, y, pdim
);
1291 loop (pageno
+1) pdimno pdim
(y + h) h pdims
1293 loop 0 ~
-1 (-1,-1,-1,-1) 0 0 state
.pdims
;
1294 conf
.columns
<- Csingle
a;
1296 | Cmulti
((columns
, coverA
, coverB
), _
) ->
1297 let a = Array.make state
.pagecount
(-1, -1, -1, (-1, -1, -1, -1)) in
1298 let rec loop pageno
pdimno pdim
x y rowh pdims
=
1299 let rec fixrow m
= if m
= pageno
then () else
1300 let (pdimno, x, y, ((_
, _
, h, _
) as pdim
)) = a.(m
) in
1303 let y = y + (rowh
- h) / 2 in
1304 a.(m
) <- (pdimno, x, y, pdim
);
1308 if pageno
= state
.pagecount
1309 then fixrow (((pageno
- 1) / columns
) * columns
)
1311 let pdimno, ((_
, w, h, xoff
) as pdim
), pdims
=
1313 | ((pageno'
, _
, _
, _
) as pdim
) :: rest
when pageno'
= pageno
->
1314 pdimno+1, pdim
, rest
1319 if pageno
= coverA
- 1 || pageno
= state
.pagecount
- coverB
1321 let x = (wadj + state
.winw
- w) / 2 in
1323 if conf
.presentation
then calcips
h else conf
.interpagespace
in
1324 x, y + ips + rowh
, h
1327 if (pageno
- coverA
) mod columns
= 0
1329 let x = max
0 (wadj + state
.winw
- state
.w) / 2 in
1331 if conf
.presentation
1333 let ips = calcips
h in
1334 y + (if pageno
= 0 then 0 else calcips rowh
+ ips)
1336 y + (if pageno
= 0 then 0 else conf
.interpagespace
)
1340 else x, y, max rowh
h
1344 if pageno
> 1 && (pageno
- coverA
) mod columns
= 0
1347 if pageno
= columns
&& conf
.presentation
1349 let ips = calcips rowh
in
1350 for i
= 0 to pred columns
1352 let (pdimno, x, y, pdim
) = a.(i
) in
1353 a.(i
) <- (pdimno, x, y+ips, pdim
)
1359 fixrow (pageno
- columns
);
1364 a.(pageno
) <- (pdimno, x, y, pdim
);
1365 let x = x + w + xoff
*2 + conf
.interpagespace
in
1366 loop (pageno
+1) pdimno pdim
x y rowh' pdims
1368 loop 0 ~
-1 (-1,-1,-1,-1) 0 0 0 state
.pdims
;
1369 conf
.columns
<- Cmulti
((columns
, coverA
, coverB
), a);
1372 let a = Array.make
(state
.pagecount
*c) (-1, -1, -1, (-1, -1, -1, -1)) in
1373 let rec loop pageno
pdimno pdim
y pdims
=
1374 if pageno
= state
.pagecount
1377 let pdimno, ((_
, w, h, _
) as pdim
), pdims
=
1379 | ((pageno'
, _
, _
, _
) as pdim
) :: rest
when pageno'
= pageno
->
1380 pdimno+1, pdim
, rest
1385 let rec loop1 n x y =
1386 if n = c then y else (
1387 a.(pageno
*c + n) <- (pdimno, x, y, pdim
);
1388 loop1 (n+1) (x+cw) (y + h + conf
.interpagespace
)
1391 let y = loop1 0 0 y in
1392 loop (pageno
+1) pdimno pdim
y pdims
1394 loop 0 ~
-1 (-1,-1,-1,-1) 0 state
.pdims
;
1395 conf
.columns
<- Csplit
(c, a);
1399 docolumns conf
.columns
;
1400 state
.maxy
<- calcheight
();
1401 if state
.reprf
== noreprf
1403 match state
.mode
with
1404 | Birdseye
(_
, _
, pageno
, _
, _
) ->
1405 let y, h = getpageyh pageno
in
1406 let top = (state
.winh
- h) / 2 in
1407 gotoy (max
0 (y - top))
1410 | LinkNav _
-> gotoanchor state
.anchor
1414 state
.reprf
<- noreprf
;
1419 GlDraw.viewport ~
x:0 ~
y:0 ~
w:w ~
h:h;
1420 let firsttime = state
.geomcmds
== firstgeomcmds
in
1421 if not
firsttime && nogeomcmds state
.geomcmds
1422 then state
.anchor <- getanchor
();
1425 let w = wadjsb () + (truncate
(float w *. conf
.zoom
)) in
1428 setfontsize fstate
.fontsize
;
1429 GlMat.mode `modelview
;
1430 GlMat.load_identity
();
1432 GlMat.mode `projection
;
1433 GlMat.load_identity
();
1434 GlMat.rotate ~
x:1.0 ~angle
:180.0 ();
1435 GlMat.translate ~
x:~
-.1.0 ~
y:~
-.1.0 ();
1436 GlMat.scale3
(2.0 /. float state
.winw
, 2.0 /. float state
.winh
, 1.0);
1441 else float state
.x /. float state
.w
1443 invalidate "geometry"
1447 then state
.x <- truncate
(relx *. float w);
1449 match conf
.columns
with
1451 | Cmulti
((c, _
, _
), _
) -> (w - (c-1)*conf
.interpagespace
) / c
1452 | Csplit
(c, _
) -> w * c
1454 wcmd "geometry %d %d %d"
1455 w (stateh h) (FMTE.to_int conf
.fitmodel
)
1460 let len = String.length state
.text in
1461 let x0 = xadjsb () in
1464 match state
.mode
with
1465 | Textentry _
| View
| LinkNav _
->
1466 let h, _
, _
= state
.uioh#scrollpw
in
1471 filledrect x (float (state
.winh
- (fstate
.fontsize
+ 4) - hscrollh))
1472 (x+.w) (float (state
.winh
- hscrollh))
1475 let w = float (wadjsb () + state
.winw
- 1) in
1476 if state
.progress
>= 0.0 && state
.progress
< 1.0
1478 GlDraw.color
(0.3, 0.3, 0.3);
1479 let w1 = w *. state
.progress
in
1481 GlDraw.color
(0.0, 0.0, 0.0);
1482 rect (float x0+.w1) (float x0+.w-.w1)
1485 GlDraw.color
(0.0, 0.0, 0.0);
1489 GlDraw.color
(1.0, 1.0, 1.0);
1490 drawstring fstate
.fontsize
1491 (if conf
.leftscroll
then x0 + 2 else x0 + if len > 0 then 8 else 2)
1492 (state
.winh
- hscrollh - 5) s;
1495 match state
.mode
with
1496 | Textentry
((prefix
, text, _
, _
, _
, _
), _
) ->
1500 Printf.sprintf
"%s%s_ [%s]" prefix
text state
.text
1502 Printf.sprintf
"%s%s_" prefix
text
1508 | LinkNav _
-> state
.text
1513 if not
(istextentry state
.mode
) && state
.uioh#eformsgs
1515 let s1 = "(press 'e' to review error messasges)" in
1516 if nonemptystr
s then s ^
" " ^
s1 else s1
1526 let len = Queue.length state
.tilelru
in
1528 match state
.throttle
with
1531 then preloadlayout state
.y
1533 | Some
(layout, _
, _
) ->
1537 if state
.memused
<= conf
.memlimit
1542 let (k
, p
, s) as lruitem
= Queue.pop state
.tilelru
in
1543 let n, gen
, colorspace
, angle
, pagew
, pageh
, col, row = k
in
1544 let (_
, pw, ph
, _
) = getpagedim
n in
1547 && colorspace
= conf
.colorspace
1548 && angle
= conf
.angle
1552 let x = col*conf
.tilew
1553 and y = row*conf
.tileh
in
1554 tilevisible (Lazy.force_val
layout) n x y
1556 then Queue.push lruitem state
.tilelru
1559 wcmd "freetile %s" (~
> p
);
1560 state
.memused
<- state
.memused
- s;
1561 state
.uioh#infochanged Memused
;
1562 Hashtbl.remove state
.tilemap k
;
1570 let logcurrently = function
1571 | Idle
-> dolog
"Idle"
1572 | Loading
(l, gen
) ->
1573 dolog
"Loading %d gen=%d curgen=%d" l.pageno gen state
.gen
1574 | Tiling
(l, pageopaque
, colorspace
, angle
, gen
, col, row, tilew
, tileh
) ->
1576 "Tiling %d[%d,%d] page=%s cs=%s angle"
1577 l.pageno
col row (~
> pageopaque
)
1578 (CSTE.to_string colorspace
)
1580 dolog
"gen=(%d,%d) (%d,%d) tile=(%d,%d) (%d,%d)"
1581 angle gen conf
.angle state
.gen
1583 conf
.tilew conf
.tileh
1590 let r = Str.regexp
" " in
1591 fun s -> Str.bounded_split
r s 2;
1594 let onpagerect pageno
f =
1596 match conf
.columns
with
1597 | Cmulti
(_
, b) -> b
1599 | Csplit
(_
, b) -> b
1601 if pageno
>= 0 && pageno
< Array.length
b
1603 let (_
, _
, _
, (w, h, _
, _
)) = b.(pageno
) in
1607 let gotopagexy1 pageno
x y =
1608 let _,w1,h1
,leftx
= getpagedim pageno
in
1609 let top = y /. (float h1
) in
1610 let left = x /. (float w1) in
1611 let py, w, h = getpageywh pageno
in
1612 let wh = state
.winh
- hscrollh () in
1613 let x = left *. (float w) in
1614 let x = leftx
+ state
.x + truncate
x in
1615 let wadj = wadjsb () in
1617 if x < 0 || x >= wadj + state
.winw
1621 let pdy = truncate
(top *. float h) in
1622 let y'
= py + pdy in
1623 let dy = y'
- state
.y in
1625 if x != state
.x || not
(dy > 0 && dy < wh)
1627 if conf
.presentation
1629 if abs
(py - y'
) > wh
1636 if state
.x != sx || state
.y != sy
1641 let ww = wadj + state
.winw
in
1643 and qy
= pdy / wh in
1645 and y = py + qy
* wh in
1646 let x = if -x + ww > w1 then -(w1-ww) else x
1647 and y'
= if y + wh > state
.maxy
then state
.maxy
- wh else y in
1649 if conf
.presentation
1651 if abs
(py - y'
) > wh
1661 gotoy_and_clear_text y;
1663 else gotoy_and_clear_text state
.y;
1666 let gotopagexy pageno
x y =
1667 match state
.mode
with
1668 | Birdseye
_ -> gotopage pageno
0.0
1671 | LinkNav
_ -> gotopagexy1 pageno
x y
1675 (* dolog "%S" cmds; *)
1676 let cl = splitatspace cmds
in
1678 try Scanf.sscanf
s fmt
f
1680 dolog
"error processing '%S': %s" cmds
(exntos exn
);
1683 let addoutline outline
=
1684 match state
.currently
with
1685 | Outlining outlines
->
1686 state
.currently
<- Outlining
(outline
:: outlines
)
1687 | Idle
-> state
.currently
<- Outlining
[outline
]
1690 dolog
"invalid outlining state";
1691 logcurrently state
.currently
1695 state
.uioh#infochanged Pdim
;
1698 | "clearrects" :: [] ->
1699 state
.rects
<- state
.rects1
;
1700 G.postRedisplay "clearrects";
1702 | "continue" :: args
:: [] ->
1703 let n = scan args
"%u" (fun n -> n) in
1704 state
.pagecount
<- n;
1705 begin match state
.currently
with
1707 state
.currently
<- Idle
;
1708 state
.outlines
<- Array.of_list
(List.rev
l)
1714 let cur, cmds
= state
.geomcmds
in
1716 then failwith
"umpossible";
1718 begin match List.rev cmds
with
1720 state
.geomcmds
<- E.s, [];
1721 state
.throttle
<- None
;
1725 state
.geomcmds
<- s, List.rev rest
;
1727 if conf
.maxwait
= None
&& not
!wtmode
1728 then G.postRedisplay "continue";
1730 | "msg" :: args
:: [] ->
1733 | "vmsg" :: args
:: [] ->
1735 then showtext ' ' args
1737 | "emsg" :: args
:: [] ->
1738 Buffer.add_string state
.errmsgs args
;
1739 state
.newerrmsgs
<- true;
1740 G.postRedisplay "error message"
1742 | "progress" :: args
:: [] ->
1743 let progress, text =
1746 f, String.sub args pos
(String.length args
- pos
))
1749 state
.progress <- progress;
1750 G.postRedisplay "progress"
1752 | "firstmatch" :: args
:: [] ->
1753 let pageno, c, x0, y0, x1, y1, x2
, y2
, x3
, y3
=
1754 scan args
"%u %d %f %f %f %f %f %f %f %f"
1755 (fun p
c x0 y0 x1 y1 x2 y2 x3 y3
->
1756 (p
, c, x0, y0, x1, y1, x2
, y2
, x3
, y3
))
1758 let xoff = float (xadjsb ()) in
1762 and x3
= x3
+. xoff in
1763 let y = (getpagey
pageno) + truncate
y0 in
1766 state
.rects1
<- [pageno, c, (x0, y0, x1, y1, x2
, y2
, x3
, y3
)]
1768 | "match" :: args
:: [] ->
1769 let pageno, c, x0, y0, x1, y1, x2
, y2
, x3
, y3
=
1770 scan args
"%u %d %f %f %f %f %f %f %f %f"
1771 (fun p
c x0 y0 x1 y1 x2 y2 x3 y3
->
1772 (p
, c, x0, y0, x1, y1, x2
, y2
, x3
, y3
))
1774 let xoff = float (xadjsb ()) in
1778 and x3
= x3
+. xoff in
1780 (pageno, c, (x0, y0, x1, y1, x2
, y2
, x3
, y3
)) :: state
.rects1
1782 | "page" :: args
:: [] ->
1783 let pageopaques, t
= scan args
"%s %f" (fun p t
-> p
, t
) in
1784 let pageopaque = ~
< pageopaques in
1785 begin match state
.currently
with
1786 | Loading
(l, gen
) ->
1787 vlog "page %d took %f sec" l.pageno t
;
1788 Hashtbl.replace state
.pagemap
(l.pageno, gen
) pageopaque;
1789 begin match state
.throttle
with
1791 let preloadedpages =
1793 then preloadlayout state
.y
1798 List.fold_left
(fun s l -> IntSet.add
l.pageno s)
1799 IntSet.empty
preloadedpages
1802 Hashtbl.fold (fun ((pageno, _) as key) opaque
accu ->
1803 if not
(IntSet.mem
pageno set)
1805 wcmd "freepage %s" (~
> opaque
);
1811 List.iter
(Hashtbl.remove state
.pagemap
) evictedpages;
1814 state
.currently
<- Idle
;
1817 tilepage l.pageno pageopaque state
.layout;
1819 load preloadedpages;
1820 if pagevisible state
.layout l.pageno
1821 && layoutready state
.layout
1822 then G.postRedisplay "page";
1825 | Some
(layout, _, _) ->
1826 state
.currently
<- Idle
;
1827 tilepage l.pageno pageopaque layout;
1834 dolog
"Inconsistent loading state";
1835 logcurrently state
.currently
;
1839 | "tile" :: args
:: [] ->
1840 let (x, y, opaques
, size
, t
) =
1841 scan args
"%u %u %s %u %f"
1842 (fun x y p size t
-> (x, y, p
, size
, t
))
1844 let opaque = ~
< opaques
in
1845 begin match state
.currently
with
1846 | Tiling
(l, pageopaque, cs
, angle
, gen
, col, row, tilew
, tileh
) ->
1847 vlog "tile %d [%d,%d] took %f sec" l.pageno col row t
;
1850 if tilew
!= conf
.tilew
|| tileh
!= conf
.tileh
1852 wcmd "freetile %s" (~
> opaque);
1853 state
.currently
<- Idle
;
1857 puttileopaque l col row gen cs angle
opaque size t
;
1858 state
.memused
<- state
.memused
+ size
;
1859 state
.uioh#infochanged Memused
;
1861 Queue.push
((l.pageno, gen
, cs
, angle
, l.pagew
, l.pageh
, col, row),
1862 opaque, size
) state
.tilelru
;
1865 match state
.throttle
with
1866 | None
-> state
.layout
1867 | Some
(layout, _, _) -> layout
1870 state
.currently
<- Idle
;
1872 && conf
.colorspace
= cs
1873 && conf
.angle
= angle
1874 && tilevisible layout l.pageno x y
1875 then conttiling l.pageno pageopaque;
1877 begin match state
.throttle
with
1879 preload state
.layout;
1881 && conf
.colorspace
= cs
1882 && conf
.angle
= angle
1883 && tilevisible state
.layout l.pageno x y
1884 && (not
!wtmode || layoutready state
.layout)
1885 then G.postRedisplay "tile nothrottle";
1887 | Some
(layout, y, _) ->
1888 let ready = layoutready layout in
1892 state
.layout <- layout;
1893 state
.throttle
<- None
;
1894 G.postRedisplay "throttle";
1903 dolog
"Inconsistent tiling state";
1904 logcurrently state
.currently
;
1908 | "pdim" :: args
:: [] ->
1909 let (n, w, h, _) as pdim
=
1910 scan args
"%u %u %u %u" (fun n w h x -> n, w, h, x)
1913 match conf
.fitmodel
with
1915 | FitPage
| FitProportional
->
1916 match conf
.columns
with
1917 | Csplit
_ -> (n, w, h, 0)
1918 | Csingle
_ | Cmulti
_ -> pdim
1920 state
.uioh#infochanged Pdim
;
1921 state
.pdims
<- pdim :: state
.pdims
1923 | "o" :: args
:: [] ->
1924 let (l, n, t
, h, pos
) =
1925 scan args
"%u %u %d %u %n"
1926 (fun l n t
h pos
-> l, n, t
, h, pos
)
1928 let s = String.sub args pos
(String.length args
- pos
) in
1929 addoutline (s, l, Oanchor
(n, float t
/. float h, 0.0))
1931 | "ou" :: args
:: [] ->
1932 let (l, len, pos
) = scan args
"%u %u %n" (fun l len pos
-> l, len, pos
) in
1933 let s = String.sub args pos
len in
1934 let pos2 = pos
+ len + 1 in
1935 let uri = String.sub args
pos2 (String.length args
- pos2) in
1936 addoutline (s, l, Ouri
uri)
1938 | "on" :: args
:: [] ->
1939 let (l, pos
) = scan args
"%u %n" (fun l pos
-> l, pos
) in
1940 let s = String.sub args pos
(String.length args
- pos
) in
1941 addoutline (s, l, Onone
)
1943 | "a" :: args
:: [] ->
1945 scan args
"%u %d %d" (fun n l t
-> n, l, t
)
1947 state
.reprf
<- (fun () -> gotopagexy n (float l) (float t
))
1949 | "info" :: args
:: [] ->
1950 let pos = nindex args '
\t'
in
1951 if pos >= 0 && String.sub args
0 pos = "Title"
1953 let s = String.sub args
(pos+1) @@ String.length args
- pos - 1 in
1956 state
.docinfo
<- (1, args
) :: state
.docinfo
1958 | "infoend" :: [] ->
1959 state
.uioh#infochanged Docinfo
;
1960 state
.docinfo
<- List.rev state
.docinfo
1963 error
"unknown cmd `%S'" cmds
1968 let action = function
1969 | HCprev
-> cbget cb ~
-1
1970 | HCnext
-> cbget cb
1
1971 | HCfirst
-> cbget cb ~
-(cb
.rc)
1972 | HClast
-> cbget cb
(cb
.len - 1 - cb
.rc)
1973 and cancel
() = cb
.rc <- rc
1977 let search pattern forward
=
1978 match conf
.columns
with
1980 showtext '
!'
"searching does not work properly in split columns mode"
1983 if nonemptystr pattern
1986 match state
.layout with
1989 l.pageno, (l.pagey + if forward
then 0 else 0*l.pagevh)
1991 wcmd "search %d %d %d %d,%s\000"
1992 (btod conf
.icase
) pn py (btod forward
) pattern
;
1995 let intentry text key =
1997 if key >= 32 && key < 127
2003 let text = addchar text c in
2007 state
.text <- Printf.sprintf
"invalid char (%d, `%c')" key c;
2011 let linknentry text key =
2013 if key >= 32 && key < 127
2019 let text = addchar text c in
2023 state
.text <- Printf.sprintf
"invalid char (%d, `%c')" key c;
2031 let l = String.length
s in
2032 let rec loop pos n = if pos = l then n else
2033 let m = Char.code
s.[pos] - (if pos = 0 && l > 1 then 96 else 97) in
2034 loop (pos+1) (n*26 + m)
2037 let rec loop n = function
2040 match getopaque l.pageno with
2041 | None
-> loop n rest
2043 let m = getlinkcount
opaque in
2046 let under = getlink
opaque n in
2049 else loop (n-m) rest
2051 loop n state
.layout;
2055 let textentry text key =
2056 if key land 0xff00 = 0xff00
2058 else TEcont
(text ^ toutf8
key)
2061 let reqlayout angle fitmodel
=
2062 match state
.throttle
with
2064 if nogeomcmds state
.geomcmds
2065 then state
.anchor <- getanchor
();
2066 conf
.angle
<- angle
mod 360;
2069 match state
.mode
with
2070 | LinkNav
_ -> state
.mode
<- View
2075 conf
.fitmodel
<- fitmodel
;
2076 invalidate "reqlayout"
2078 wcmd "reqlayout %d %d %d"
2079 conf
.angle
(FMTE.to_int conf
.fitmodel
) (stateh state
.winh
)
2084 let settrim trimmargins trimfuzz
=
2085 if nogeomcmds state
.geomcmds
2086 then state
.anchor <- getanchor
();
2087 conf
.trimmargins
<- trimmargins
;
2088 conf
.trimfuzz
<- trimfuzz
;
2089 let x0, y0, x1, y1 = trimfuzz
in
2090 invalidate "settrim"
2092 wcmd "settrim %d %d %d %d %d" (btod conf
.trimmargins
) x0 y0 x1 y1);
2097 match state
.throttle
with
2099 let zoom = max
0.0001 zoom in
2100 if zoom <> conf
.zoom
2102 state
.prevzoom
<- (conf
.zoom, state
.x);
2104 reshape state
.winw state
.winh
;
2105 state
.text <- Printf.sprintf
"zoom is now %-5.2f" (zoom *. 100.0);
2108 | Some
(layout, y, started
) ->
2110 match conf
.maxwait
with
2114 let dt = now
() -. started
in
2122 let setcolumns mode columns coverA coverB
=
2123 state
.prevcolumns
<- Some
(conf
.columns
, conf
.zoom);
2127 then showtext '
!'
"split mode doesn't work in bird's eye"
2129 conf
.columns
<- Csplit
(-columns
, E.a);
2137 conf
.columns
<- Csingle
E.a;
2142 conf
.columns
<- Cmulti
((columns
, coverA
, coverB
), E.a);
2146 reshape state
.winw state
.winh
;
2149 let resetmstate () =
2150 state
.mstate
<- Mnone
;
2151 Wsi.setcursor
Wsi.CURSOR_INHERIT
;
2154 let enterbirdseye () =
2155 let zoom = float conf
.thumbw
/. float state
.winw
in
2156 let birdseyepageno =
2157 let cy = state
.winh
/ 2 in
2161 let rec fold best
= function
2164 let d = cy - (l.pagedispy + l.pagevh/2)
2165 and dbest
= cy - (best
.pagedispy + best
.pagevh/2) in
2166 if abs
d < abs dbest
2173 state
.mode
<- Birdseye
(
2174 { conf
with zoom = conf
.zoom }, state
.x, birdseyepageno, -1, getanchor
()
2178 conf
.presentation
<- false;
2179 conf
.interpagespace
<- 10;
2180 conf
.hlinks
<- false;
2181 conf
.fitmodel
<- FitPage
;
2183 conf
.maxwait
<- None
;
2185 match conf
.beyecolumns
with
2188 Cmulti
((c, 0, 0), E.a)
2189 | None
-> Csingle
E.a
2193 state
.text <- Printf.sprintf
"birds eye mode on (zoom %3.1f%%)"
2198 reshape state
.winw state
.winh
;
2201 let leavebirdseye (c, leftx
, pageno, _, anchor) goback
=
2203 conf
.zoom <- c.zoom;
2204 conf
.presentation
<- c.presentation
;
2205 conf
.interpagespace
<- c.interpagespace
;
2206 conf
.maxwait
<- c.maxwait
;
2207 conf
.hlinks
<- c.hlinks
;
2208 conf
.fitmodel
<- c.fitmodel
;
2209 conf
.beyecolumns
<- (
2210 match conf
.columns
with
2211 | Cmulti
((c, _, _), _) -> Some
c
2213 | Csplit
_ -> failwith
"leaving bird's eye split mode"
2216 match c.columns
with
2217 | Cmulti
(c, _) -> Cmulti
(c, E.a)
2218 | Csingle
_ -> Csingle
E.a
2219 | Csplit
(c, _) -> Csplit
(c, E.a)
2223 state
.text <- Printf.sprintf
"birds eye mode off (zoom %3.1f%%)"
2226 reshape state
.winw state
.winh
;
2227 state
.anchor <- if goback
then anchor else (pageno, 0.0, 1.0);
2231 let togglebirdseye () =
2232 match state
.mode
with
2233 | Birdseye vals
-> leavebirdseye vals
true
2234 | View
-> enterbirdseye ()
2239 let upbirdseye incr
(conf
, leftx
, pageno, hooverpageno
, anchor) =
2240 let pageno = max
0 (pageno - incr
) in
2241 let rec loop = function
2242 | [] -> gotopage1 pageno 0
2243 | l :: _ when l.pageno = pageno ->
2244 if l.pagedispy >= 0 && l.pagey = 0
2245 then G.postRedisplay "upbirdseye"
2246 else gotopage1 pageno 0
2247 | _ :: rest
-> loop rest
2251 state
.mode
<- Birdseye
(conf
, leftx
, pageno, hooverpageno
, anchor)
2254 let downbirdseye incr
(conf
, leftx
, pageno, hooverpageno
, anchor) =
2255 let pageno = min
(state
.pagecount
- 1) (pageno + incr
) in
2256 state
.mode
<- Birdseye
(conf
, leftx
, pageno, hooverpageno
, anchor);
2257 let rec loop = function
2259 let y, h = getpageyh
pageno in
2260 let dy = (y - state
.y) - (state
.winh
- h - conf
.interpagespace
) in
2262 | l :: _ when l.pageno = pageno ->
2263 if l.pagevh != l.pageh
2264 then gotoy (clamp (l.pageh
- l.pagevh + conf
.interpagespace
))
2265 else G.postRedisplay "downbirdseye"
2266 | _ :: rest
-> loop rest
2272 let boundastep h step
=
2274 then bound step ~
-h 0
2278 let optentry mode
_ key =
2279 let btos b = if b then "on" else "off" in
2280 if key >= 32 && key < 127
2282 let c = Char.chr
key in
2286 try conf
.scrollstep
<- int_of_string
s with exc
->
2287 state
.text <- Printf.sprintf
"bad integer `%s': %s" s (exntos exc
)
2289 TEswitch
("scroll step: ", E.s, None
, intentry, ondone, true)
2294 conf
.autoscrollstep
<- boundastep state
.winh
(int_of_string
s);
2295 if state
.autoscroll
<> None
2296 then state
.autoscroll
<- Some conf
.autoscrollstep
2298 state
.text <- Printf.sprintf
"bad integer `%s': %s" s (exntos exc
)
2300 TEswitch
("auto scroll step: ", E.s, None
, intentry, ondone, true)
2305 let n, a, b = multicolumns_of_string
s in
2306 setcolumns mode
n a b;
2308 state
.text <- Printf.sprintf
"bad columns `%s': %s" s (exntos exc
)
2310 TEswitch
("columns: ", E.s, None
, textentry, ondone, true)
2315 let zoom = float (int_of_string
s) /. 100.0 in
2318 state
.text <- Printf.sprintf
"bad integer `%s': %s" s (exntos exc
)
2320 TEswitch
("zoom: ", E.s, None
, intentry, ondone, true)
2325 conf
.thumbw
<- bound
(int_of_string
s) 2 4096;
2327 Printf.sprintf
"thumbnail width is set to %d" conf
.thumbw
;
2328 begin match mode
with
2330 leavebirdseye beye
false;
2337 state
.text <- Printf.sprintf
"bad integer `%s': %s" s (exntos exc
)
2339 TEswitch
("thumbnail width: ", E.s, None
, intentry, ondone, true)
2344 Some
(int_of_string
s)
2346 state
.text <- Printf.sprintf
"bad integer `%s': %s"
2350 | Some angle
-> reqlayout angle conf
.fitmodel
2353 TEswitch
("rotation: ", E.s, None
, intentry, ondone, true)
2356 conf
.icase
<- not conf
.icase
;
2357 TEdone
("case insensitive search " ^
(btos conf
.icase
))
2360 conf
.preload <- not conf
.preload;
2362 TEdone
("preload " ^
(btos conf
.preload))
2365 conf
.verbose
<- not conf
.verbose
;
2366 TEdone
("verbose " ^
(btos conf
.verbose
))
2369 conf
.debug
<- not conf
.debug
;
2370 TEdone
("debug " ^
(btos conf
.debug
))
2373 conf
.maxhfit
<- not conf
.maxhfit
;
2374 state
.maxy
<- calcheight
();
2375 TEdone
("maxhfit " ^
(btos conf
.maxhfit
))
2378 conf
.crophack
<- not conf
.crophack
;
2379 TEdone
("crophack " ^
btos conf
.crophack
)
2383 match conf
.maxwait
with
2385 conf
.maxwait
<- Some infinity
;
2386 "always wait for page to complete"
2388 conf
.maxwait
<- None
;
2389 "show placeholder if page is not ready"
2394 conf
.underinfo
<- not conf
.underinfo
;
2395 TEdone
("underinfo " ^
btos conf
.underinfo
)
2398 conf
.savebmarks
<- not conf
.savebmarks
;
2399 TEdone
("persistent bookmarks " ^
btos conf
.savebmarks
)
2405 match state
.layout with
2410 conf
.interpagespace
<- int_of_string
s;
2411 docolumns conf
.columns
;
2412 state
.maxy
<- calcheight
();
2413 let y = getpagey
pageno in
2416 state
.text <- Printf.sprintf
"bad integer `%s': %s" s (exntos exc
)
2418 TEswitch
("vertical margin: ", E.s, None
, intentry, ondone, true)
2422 match conf
.fitmodel
with
2423 | FitProportional
-> FitWidth
2424 | FitWidth
| FitPage
-> FitProportional
2426 reqlayout conf
.angle
fm;
2427 TEdone
("proportional display " ^
btos (fm == FitProportional
))
2430 settrim (not conf
.trimmargins
) conf
.trimfuzz
;
2431 TEdone
("trim margins " ^
btos conf
.trimmargins
)
2434 conf
.invert
<- not conf
.invert
;
2435 TEdone
("invert colors " ^
btos conf
.invert
)
2439 cbput state
.hists
.sel
s;
2442 TEswitch
("selection command: ", E.s, Some
(onhist state
.hists
.sel
),
2443 textentry, ondone, true)
2447 then conf
.pax
<- Some
(ref (0.0, 0, 0))
2448 else conf
.pax
<- None
;
2449 TEdone
("PAX " ^
btos (conf
.pax
!= None
))
2452 state
.text <- Printf.sprintf
"bad option %d `%c'" key c;
2458 class type lvsource
= object
2459 method getitemcount
: int
2460 method getitem
: int -> (string * int)
2461 method hasaction
: int -> bool
2469 method getactive
: int
2470 method getfirst
: int
2472 method getminfo
: (int * int) array
2475 class virtual lvsourcebase
= object
2476 val mutable m_active
= 0
2477 val mutable m_first
= 0
2478 val mutable m_pan
= 0
2479 method getactive
= m_active
2480 method getfirst
= m_first
2481 method getpan
= m_pan
2482 method getminfo
: (int * int) array
= E.a
2485 let withoutlastutf8 s =
2486 let len = String.length
s in
2494 let b = Char.code
s.[pos] in
2495 if b land 0b11000000 = 0b11000000
2500 if Char.code
s.[len-1] land 0x80 = 0
2504 String.sub
s 0 first;
2507 let textentrykeyboard
2508 key _mask
((c, text, opthist
, onkey
, ondone, cancelonempty
), onleave
) =
2510 if key >= 0xffb0 && key <= 0xffb9
2511 then key - 0xffb0 + 48 else key
2514 state
.mode
<- Textentry
(te
, onleave
);
2517 G.postRedisplay "textentrykeyboard enttext";
2519 let histaction cmd
=
2522 | Some
(action, _) ->
2523 state
.mode
<- Textentry
(
2524 (c, action cmd
, opthist
, onkey
, ondone, cancelonempty
), onleave
2526 G.postRedisplay "textentry histaction"
2530 if emptystr
text && cancelonempty
2533 G.postRedisplay "textentrykeyboard after cancel";
2536 let s = withoutlastutf8 text in
2537 enttext (c, s, opthist
, onkey
, ondone, cancelonempty
)
2539 | @enter
| @kpenter
->
2542 G.postRedisplay "textentrykeyboard after confirm"
2544 | @up
| @kpup
-> histaction HCprev
2545 | @down
| @kpdown
-> histaction HCnext
2546 | @home
| @kphome
-> histaction HCfirst
2547 | @jend
| @kpend
-> histaction HClast
2552 begin match opthist
with
2554 | Some
(_, onhistcancel
) -> onhistcancel
()
2558 G.postRedisplay "textentrykeyboard after cancel2"
2561 enttext (c, E.s, opthist
, onkey
, ondone, cancelonempty
)
2564 | @delete
| @kpdelete
-> ()
2567 && key land 0xff00 != 0xff00 (* keyboard *)
2568 && key land 0xfe00 != 0xfe00 (* xkb *)
2569 && key land 0xfd00 != 0xfd00 (* 3270 *)
2571 begin match onkey
text key with
2575 G.postRedisplay "textentrykeyboard after confirm2";
2578 enttext (c, text, opthist
, onkey
, ondone, cancelonempty
);
2582 G.postRedisplay "textentrykeyboard after cancel3"
2585 state
.mode
<- Textentry
(te
, onleave
);
2586 G.postRedisplay "textentrykeyboard switch";
2590 vlog "unhandled key %s" (Wsi.keyname
key)
2593 let firstof first active
=
2594 if first > active
|| abs
(first - active
) > fstate
.maxrows
- 1
2595 then max
0 (active
- (fstate
.maxrows
/2))
2599 let calcfirst first active
=
2602 let rows = active
- first in
2603 if rows > fstate
.maxrows
then active
- fstate
.maxrows
else first
2607 let scrollph y maxy
=
2608 let sh = float (maxy
+ state
.winh
) /. float state
.winh
in
2609 let sh = float state
.winh
/. sh in
2610 let sh = max
sh (float conf
.scrollh
) in
2612 let percent = float y /. float maxy
in
2613 let position = (float state
.winh
-. sh) *. percent in
2616 if position +. sh > float state
.winh
2617 then float state
.winh
-. sh
2623 let coe s = (s :> uioh
);;
2625 class listview ~zebra ~helpmode ~
(source
:lvsource
) ~trusted ~modehash
=
2627 val m_pan
= source#getpan
2628 val m_first
= source#getfirst
2629 val m_active
= source#getactive
2631 val m_prev_uioh
= state
.uioh
2633 method private elemunder
y =
2637 let n = y / (fstate
.fontsize
+1) in
2638 if m_first
+ n < source#getitemcount
2640 if source#hasaction
(m_first
+ n)
2641 then Some
(m_first
+ n)
2648 GlFunc.blend_func ~src
:`src_alpha ~dst
:`one_minus_src_alpha
;
2649 GlDraw.color
(0., 0., 0.) ~alpha
:0.85;
2650 filledrect 0. 0. (float state
.winw
) (float state
.winh
);
2651 GlDraw.color
(1., 1., 1.);
2652 Gl.enable `texture_2d
;
2653 let fs = fstate
.fontsize
in
2655 let hw = (wadjsb () + xadjsb () + state
.winw
)/3 in
2656 let ww = fstate
.wwidth
in
2657 let tabw = 17.0*.ww in
2658 let itemcount = source#getitemcount
in
2659 let minfo = source#getminfo
in
2662 then float (xadjsb ()), float (state
.winw
- 1)
2663 else 0.0, float (state
.winw
- conf
.scrollbw
- 1)
2665 let xadj = xadjsb () in
2667 if (row - m_first
) > fstate
.maxrows
2670 if row >= 0 && row < itemcount
2672 let (s, level
) = source#getitem
row in
2673 let y = (row - m_first
) * nfs in
2675 (if conf
.leftscroll
then float xadj else 5.0)
2676 +. (float (level
+ m_pan
)) *. ww in
2679 (let c = if row land 1 = 0 then 1.0 else 0.92 in (c,c,c));
2683 Gl.disable `texture_2d
;
2684 let alpha = if source#hasaction
row then 0.9 else 0.3 in
2685 GlDraw.color
(1., 1., 1.) ~
alpha;
2686 linerect (x0 +. 1.) (float (y + 1)) (x1) (float (y + fs + 3));
2687 Gl.enable `texture_2d
;
2690 if zebra
&& row land 1 = 1
2694 GlDraw.color
(c,c,c);
2695 let drawtabularstring s =
2697 let x'
= truncate
(x0 +. x) in
2698 let pos = nindex
s '
\000'
in
2700 then drawstring1 fs x'
(y+nfs) s
2702 let s1 = String.sub
s 0 pos
2703 and s2
= String.sub
s (pos+1) (String.length
s - pos - 1) in
2708 let s'
= withoutlastutf8 s in
2709 let s = s' ^
"@Uellipsis" in
2710 let w = measurestr
fs s in
2711 if float x'
+. w +. ww < float (hw + x'
)
2716 if float x'
+. ww +. measurestr
fs s1 > float (hw + x'
)
2720 ignore
(drawstring1 fs x'
(y+nfs) s1);
2721 drawstring1 fs (hw + x'
) (y+nfs) s2
2725 let x = if helpmode
&& row > 0 then x +. ww else x in
2726 let tabpos = nindex
s '
\t'
in
2729 let len = String.length
s - tabpos - 1 in
2730 let s1 = String.sub
s 0 tabpos
2731 and s2
= String.sub
s (tabpos + 1) len in
2732 let nx = drawstr x s1 in
2734 let x = x +. (max
tabw sw) in
2737 let len = String.length
s - 2 in
2738 if len > 0 && s.[0] = '
\xc2'
&& s.[1] = '
\xb7'
2740 let s = String.sub
s 2 len in
2741 let x = if not helpmode
then x +. ww else x in
2742 GlDraw.color
(1.2, 1.2, 1.2);
2743 let vinc = drawstring1 (fs+fs/4)
2744 (truncate
(x -. ww)) (y+nfs) s in
2745 GlDraw.color
(1., 1., 1.);
2746 vinc +. (float fs *. 0.8)
2752 ignore
(drawtabularstring s);
2758 GlDraw.color
(1.0, 1.0, 1.0) ~
alpha:0.5;
2759 let xadj = float (xadjsb () + 5) in
2761 if (row - m_first
) > fstate
.maxrows
2764 if row >= 0 && row < itemcount
2766 let (s, level
) = source#getitem
row in
2767 let pos0 = nindex
s '
\000'
in
2768 let y = (row - m_first
) * nfs in
2769 let x = float (level
+ m_pan
) *. ww in
2770 let (first, last
) = minfo.(row) in
2772 if pos0 > 0 && first > pos0
2773 then String.sub
s (pos0+1) (first-pos0-1)
2774 else String.sub
s 0 first
2776 let suffix = String.sub
s first (last
- first) in
2777 let w1 = measurestr fstate
.fontsize
prefix in
2778 let w2 = measurestr fstate
.fontsize
suffix in
2779 let x = x +. if conf
.leftscroll
then xadj else 5.0 in
2780 let x = if pos0 > 0 && first > pos0 then x +. float hw else x in
2782 and y0 = float (y+2) in
2784 and y1 = float (y+fs+3) in
2785 filledrect x0 y0 x1 y1;
2790 Gl.disable `texture_2d
;
2791 if Array.length
minfo > 0 then loop m_first
;
2794 method updownlevel incr
=
2795 let len = source#getitemcount
in
2797 if m_active
>= 0 && m_active
< len
2798 then snd
(source#getitem m_active
)
2802 if i
= len then i
-1 else if i
= -1 then 0 else
2803 let _, l = source#getitem i
in
2804 if l != curlevel then i
else flow (i
+incr
)
2806 let active = flow m_active
in
2807 let first = calcfirst m_first
active in
2808 G.postRedisplay "outline updownlevel";
2809 {< m_active
= active; m_first
= first >}
2811 method private key1
key mask
=
2812 let set1 active first qsearch
=
2813 coe {< m_active
= active; m_first
= first; m_qsearch
= qsearch
>}
2815 let search active pattern incr
=
2816 let active = if active = -1 then m_first
else active in
2819 if n >= 0 && n < source#getitemcount
2821 let s, _ = source#getitem
n in
2823 (try ignore
(Str.search_forward
re s 0); true
2824 with Not_found
-> false)
2826 else loop (n + incr
)
2833 let re = Str.regexp_case_fold pattern
in
2839 let itemcount = source#getitemcount
in
2840 let find start incr
=
2842 if i
= -1 || i
= itemcount
2845 if source#hasaction i
2847 else find (i
+ incr
)
2852 let set active first =
2853 let first = bound
first 0 (itemcount - fstate
.maxrows
) in
2855 coe {< m_active
= active; m_first
= first; m_qsearch
= E.s >}
2858 let isvisible first n = n >= first && n - first <= fstate
.maxrows
in
2860 let incr1 = if incr
> 0 then 1 else -1 in
2861 if isvisible m_first m_active
2864 let next = m_active
+ incr
in
2866 if next < 0 || next >= itemcount
2868 else find next incr1
2870 if abs
(m_active
- next) > fstate
.maxrows
2876 let first = m_first
+ incr
in
2877 let first = bound
first 0 (itemcount - fstate
.maxrows
) in
2879 let next = m_active
+ incr
in
2880 let next = bound
next 0 (itemcount - 1) in
2887 if isvisible first next
2894 let first = min
next m_first
in
2896 if abs
(next - first) > fstate
.maxrows
2902 let first = m_first
+ incr
in
2903 let first = bound
first 0 (itemcount - 1) in
2905 let next = m_active
+ incr
in
2906 let next = bound
next 0 (itemcount - 1) in
2907 let next = find next incr1 in
2909 if next = -1 || abs
(m_active
- first) > fstate
.maxrows
2911 let active = if m_active
= -1 then next else m_active
in
2916 if isvisible first active
2922 G.postRedisplay "listview navigate";
2926 | (@r|@s) when Wsi.withctrl mask
->
2927 let incr = if key = @r then -1 else 1 in
2929 match search (m_active
+ incr) m_qsearch
incr with
2931 state
.text <- m_qsearch ^
" [not found]";
2934 state
.text <- m_qsearch
;
2935 active, firstof m_first
active
2937 G.postRedisplay "listview ctrl-r/s";
2938 set1 active first m_qsearch
;
2940 | @insert
when Wsi.withctrl mask
->
2941 if m_active
>= 0 && m_active
< source#getitemcount
2943 let s, _ = source#getitem m_active
in
2949 if emptystr m_qsearch
2952 let qsearch = withoutlastutf8 m_qsearch
in
2956 G.postRedisplay "listview empty qsearch";
2957 set1 m_active m_first
E.s;
2961 match search m_active
qsearch ~
-1 with
2963 state
.text <- qsearch ^
" [not found]";
2966 state
.text <- qsearch;
2967 active, firstof m_first
active
2969 G.postRedisplay "listview backspace qsearch";
2970 set1 active first qsearch
2973 | key when (key != 0 && key land 0xff00 != 0xff00) ->
2974 let pattern = m_qsearch ^ toutf8
key in
2976 match search m_active
pattern 1 with
2978 state
.text <- pattern ^
" [not found]";
2981 state
.text <- pattern;
2982 active, firstof m_first
active
2984 G.postRedisplay "listview qsearch add";
2985 set1 active first pattern;
2989 if emptystr m_qsearch
2991 G.postRedisplay "list view escape";
2994 source#exit ~uioh
:(coe self
)
2995 ~cancel
:true ~
active:m_active ~
first:m_first ~pan
:m_pan
2997 | None
-> m_prev_uioh
3002 G.postRedisplay "list view kill qsearch";
3003 coe {< m_qsearch
= E.s >}
3006 | @enter
| @kpenter
->
3008 let self = {< m_qsearch
= E.s >} in
3010 G.postRedisplay "listview enter";
3011 if m_active
>= 0 && m_active
< source#getitemcount
3013 source#exit ~uioh
:(coe self) ~cancel
:false
3014 ~
active:m_active ~
first:m_first ~pan
:m_pan
;
3017 source#exit ~uioh
:(coe self) ~cancel
:true
3018 ~
active:m_active ~
first:m_first ~pan
:m_pan
;
3021 begin match opt with
3022 | None
-> m_prev_uioh
3026 | @delete
| @kpdelete
->
3029 | @up
| @kpup
-> navigate ~
-1
3030 | @down
| @kpdown
-> navigate 1
3031 | @prior
| @kpprior
-> navigate ~
-(fstate
.maxrows
)
3032 | @next | @kpnext
-> navigate fstate
.maxrows
3034 | @right
| @kpright
->
3036 G.postRedisplay "listview right";
3037 coe {< m_pan
= m_pan
- 1 >}
3039 | @left | @kpleft
->
3041 G.postRedisplay "listview left";
3042 coe {< m_pan
= m_pan
+ 1 >}
3044 | @home
| @kphome
->
3045 let active = find 0 1 in
3046 G.postRedisplay "listview home";
3050 let first = max
0 (itemcount - fstate
.maxrows
) in
3051 let active = find (itemcount - 1) ~
-1 in
3052 G.postRedisplay "listview end";
3055 | key when (key = 0 || key land 0xff00 = 0xff00) ->
3059 dolog
"listview unknown key %#x" key; coe self
3061 method key key mask
=
3062 match state
.mode
with
3063 | Textentry te
-> textentrykeyboard key mask te
; coe self
3066 | LinkNav
_ -> self#key1
key mask
3068 method button button down
x y _ =
3071 | 1 when x > state
.winw
- conf
.scrollbw
->
3072 G.postRedisplay "listview scroll";
3075 let _, position, sh = self#
scrollph in
3076 if y > truncate
position && y < truncate
(position +. sh)
3078 state
.mstate
<- Mscrolly
;
3082 let s = float (max
0 (y - conf
.scrollh
)) /. float state
.winh
in
3083 let first = truncate
(s *. float source#getitemcount
) in
3084 let first = min source#getitemcount
first in
3085 Some
(coe {< m_first
= first; m_active
= first >})
3087 state
.mstate
<- Mnone
;
3091 begin match self#elemunder
y with
3093 G.postRedisplay "listview click";
3094 source#exit ~uioh
:(coe {< m_active
= n >})
3095 ~cancel
:false ~
active:n ~
first:m_first ~pan
:m_pan
3099 | n when (n == 4 || n == 5) && not down
->
3100 let len = source#getitemcount
in
3102 if n = 5 && m_first
+ fstate
.maxrows
>= len
3106 let first = m_first
+ (if n == 4 then -1 else 1) in
3107 bound
first 0 (len - 1)
3109 G.postRedisplay "listview wheel";
3110 Some
(coe {< m_first
= first >})
3111 | n when (n = 6 || n = 7) && not down
->
3112 let inc = if n = 7 then -1 else 1 in
3113 G.postRedisplay "listview hwheel";
3114 Some
(coe {< m_pan
= m_pan
+ inc >})
3119 | None
-> m_prev_uioh
3122 method multiclick
_ x y = self#button
1 true x y
3125 match state
.mstate
with
3127 let s = float (max
0 (y - conf
.scrollh
)) /. float state
.winh
in
3128 let first = truncate
(s *. float source#getitemcount
) in
3129 let first = min source#getitemcount
first in
3130 G.postRedisplay "listview motion";
3131 coe {< m_first
= first; m_active
= first >}
3139 method pmotion
x y =
3140 if x < state
.winw
- conf
.scrollbw
3143 match self#elemunder
y with
3144 | None
-> Wsi.setcursor
Wsi.CURSOR_INHERIT
; m_active
3145 | Some
n -> Wsi.setcursor
Wsi.CURSOR_INFO
; n
3149 then (G.postRedisplay "listview pmotion"; {< m_active
= n >})
3154 Wsi.setcursor
Wsi.CURSOR_INHERIT
;
3158 method infochanged
_ = ()
3160 method scrollpw
= (0, 0.0, 0.0)
3162 let nfs = fstate
.fontsize
+ 1 in
3163 let y = m_first
* nfs in
3164 let itemcount = source#getitemcount
in
3165 let maxi = max
0 (itemcount - fstate
.maxrows
) in
3166 let maxy = maxi * nfs in
3167 let p, h = scrollph y maxy in
3170 method modehash
= modehash
3171 method eformsgs
= false
3172 method alwaysscrolly
= true
3175 class outlinelistview ~zebra ~source
=
3176 let settext autonarrow
s =
3179 let ss = source#statestr
in
3183 else "{" ^
ss ^
"} [" ^
s ^
"]"
3184 else state
.text <- s
3190 ~source
:(source
:> lvsource
)
3192 ~modehash
:(findkeyhash conf
"outline")
3195 val m_autonarrow
= false
3197 method! key key mask
=
3199 if emptystr state
.text
3201 else fstate
.maxrows - 2
3203 let calcfirst first active =
3206 let rows = active - first in
3207 if rows > maxrows then active - maxrows else first
3211 let active = m_active
+ incr in
3212 let active = bound
active 0 (source#getitemcount
- 1) in
3213 let first = calcfirst m_first
active in
3214 G.postRedisplay "outline navigate";
3215 coe {< m_active
= active; m_first
= first >}
3217 let navscroll first =
3219 let dist = m_active
- first in
3225 else first + maxrows
3228 G.postRedisplay "outline navscroll";
3229 coe {< m_first
= first; m_active
= active >}
3231 let ctrl = Wsi.withctrl mask
in
3236 then (source#denarrow
; E.s)
3238 let pattern = source#renarrow
in
3239 if nonemptystr m_qsearch
3240 then (source#narrow m_qsearch
; m_qsearch
)
3244 settext (not m_autonarrow
) text;
3245 G.postRedisplay "toggle auto narrowing";
3246 coe {< m_first
= 0; m_active
= 0; m_autonarrow
= not m_autonarrow
>}
3248 | @slash
when emptystr m_qsearch
&& not m_autonarrow
->
3250 G.postRedisplay "toggle auto narrowing";
3251 coe {< m_first
= 0; m_active
= 0; m_autonarrow
= true >}
3254 source#narrow m_qsearch
;
3256 then source#add_narrow_pattern m_qsearch
;
3257 G.postRedisplay "outline ctrl-n";
3258 coe {< m_first
= 0; m_active
= 0 >}
3261 let active = source#calcactive
(getanchor
()) in
3262 let first = firstof m_first
active in
3263 G.postRedisplay "outline ctrl-s";
3264 coe {< m_first
= first; m_active
= active >}
3267 G.postRedisplay "outline ctrl-u";
3268 if m_autonarrow
&& nonemptystr m_qsearch
3270 ignore
(source#renarrow
);
3271 settext m_autonarrow
E.s;
3272 coe {< m_first
= 0; m_active
= 0; m_qsearch
= E.s >}
3275 source#del_narrow_pattern
;
3276 let pattern = source#renarrow
in
3278 if emptystr
pattern then E.s else "Narrowed to " ^
pattern
3280 settext m_autonarrow
text;
3281 coe {< m_first
= 0; m_active
= 0; m_qsearch
= E.s >}
3285 let first = max
0 (m_active
- (fstate
.maxrows / 2)) in
3286 G.postRedisplay "outline ctrl-l";
3287 coe {< m_first
= first >}
3289 | @tab
when m_autonarrow
->
3290 if nonemptystr m_qsearch
3292 G.postRedisplay "outline list view tab";
3293 source#add_narrow_pattern m_qsearch
;
3295 coe {< m_qsearch
= E.s >}
3299 | @escape
when m_autonarrow
->
3300 if nonemptystr m_qsearch
3301 then source#add_narrow_pattern m_qsearch
;
3304 | @enter
| @kpenter
when m_autonarrow
->
3305 if nonemptystr m_qsearch
3306 then source#add_narrow_pattern m_qsearch
;
3309 | key when m_autonarrow
&& (key != 0 && key land 0xff00 != 0xff00) ->
3310 let pattern = m_qsearch ^ toutf8
key in
3311 G.postRedisplay "outlinelistview autonarrow add";
3312 source#narrow
pattern;
3313 settext true pattern;
3314 coe {< m_first
= 0; m_active
= 0; m_qsearch
= pattern >}
3316 | key when m_autonarrow
&& key = @backspace
->
3317 if emptystr m_qsearch
3320 let pattern = withoutlastutf8 m_qsearch
in
3321 G.postRedisplay "outlinelistview autonarrow backspace";
3322 ignore
(source#renarrow
);
3323 source#narrow
pattern;
3324 settext true pattern;
3325 coe {< m_first
= 0; m_active
= 0; m_qsearch
= pattern >}
3327 | @delete
| @kpdelete
->
3328 source#remove m_active
;
3329 G.postRedisplay "outline delete";
3330 let active = max
0 (m_active
-1) in
3331 coe {< m_first
= firstof m_first
active;
3332 m_active
= active >}
3334 | @up
| @kpup
when ctrl ->
3335 navscroll (max
0 (m_first
- 1))
3337 | @down
| @kpdown
when ctrl ->
3338 navscroll (min
(source#getitemcount
- 1) (m_first
+ 1))
3340 | @up
| @kpup
-> navigate ~
-1
3341 | @down
| @kpdown
-> navigate 1
3342 | @prior
| @kpprior
-> navigate ~
-(fstate
.maxrows)
3343 | @next | @kpnext
-> navigate fstate
.maxrows
3345 | @right
| @kpright
->
3349 G.postRedisplay "outline ctrl right";
3350 {< m_pan
= m_pan
+ 1 >}
3352 else self#updownlevel
1
3356 | @left | @kpleft
->
3360 G.postRedisplay "outline ctrl left";
3361 {< m_pan
= m_pan
- 1 >}
3363 else self#updownlevel ~
-1
3367 | @home
| @kphome
->
3368 G.postRedisplay "outline home";
3369 coe {< m_first
= 0; m_active
= 0 >}
3372 let active = source#getitemcount
- 1 in
3373 let first = max
0 (active - fstate
.maxrows) in
3374 G.postRedisplay "outline end";
3375 coe {< m_active
= active; m_first
= first >}
3377 | _ -> super#
key key mask
3380 let gotounder under =
3381 let getpath filename
=
3383 if nonemptystr filename
3385 if Filename.is_relative filename
3387 let dir = Filename.dirname state
.path in
3389 if Filename.is_implicit
dir
3390 then Filename.concat
(Sys.getcwd
()) dir
3393 Filename.concat
dir filename
3397 if Sys.file_exists
path
3402 | Ulinkgoto
(pageno, top) ->
3406 gotopage1 pageno top;
3412 | Uremote
(filename
, pageno) ->
3413 let path = getpath filename
in
3418 let command = Printf.sprintf
"%s -page %d %S" !selfexec pageno path in
3419 try popen
command []
3421 Printf.eprintf
"failed to execute `%s': %s\n" command (exntos exn
);
3424 let anchor = getanchor
() in
3425 let ranchor = state
.path, state
.password
, anchor, state
.origin
in
3426 state
.origin
<- E.s;
3427 state
.anchor <- (pageno, 0.0, 0.0);
3428 state
.ranchors
<- ranchor :: state
.ranchors
;
3431 else showtext '
!'
("Could not find " ^ filename
)
3433 | Uremotedest
(filename
, destname
) ->
3434 let path = getpath filename
in
3439 let command = !selfexec ^
" " ^
path ^
" -dest " ^ destname
in
3440 try popen
command []
3443 "failed to execute `%s': %s\n" command (exntos exn
);
3446 let anchor = getanchor
() in
3447 let ranchor = state
.path, state
.password
, anchor, state
.origin
in
3448 state
.origin
<- E.s;
3449 state
.nameddest
<- destname
;
3450 state
.ranchors
<- ranchor :: state
.ranchors
;
3453 else showtext '
!'
("Could not find " ^ filename
)
3455 | Uunexpected
_ | Ulaunch
_ | Unamed
_ | Utext
_ | Unone
3456 | Uannotation
_ -> ()
3459 let gotohist (path, (c, bookmarks
, x, anchor)) =
3460 Config.save
leavebirdseye;
3461 state
.anchor <- anchor;
3463 state
.bookmarks
<- bookmarks
;
3464 state
.origin
<- E.s;
3466 let x0, y0, x1, y1 = conf
.trimfuzz
in
3467 wcmd "trimset %d %d %d %d %d" (btod conf
.trimmargins
) x0 y0 x1 y1;
3471 let gotooutline (_, _, kind
) =
3475 let (pageno, y, _) = anchor in
3477 (if conf
.presentation
then (pageno, y, 1.0) else anchor)
3481 | Ouri
uri -> gotounder (Ulinkuri
uri)
3482 | Olaunch cmd
-> gotounder (Ulaunch cmd
)
3483 | Oremote remote
-> gotounder (Uremote remote
)
3484 | Ohistory hist
-> gotohist hist
3485 | Oremotedest remotedest
-> gotounder (Uremotedest remotedest
)
3489 let genhistoutlines =
3490 let order ty
(p1
, c1
, _, _, _) (p2
, c2
, _, _, _) =
3492 | `lastvisit
-> compare c1
.lastvisit c2
.lastvisit
3493 | `
path -> compare p2 p1
3494 | `file
-> compare
(Filename.basename p2
) (Filename.basename p1
)
3496 let e1 = emptystr c1
.title
3497 and e2
= emptystr c2
.title
in
3499 then compare
(Filename.basename p2
) (Filename.basename p1
)
3502 else compare c1
.title c2
.title
3504 let showfullpath = ref false in
3507 let s = if orderty
= t
then "[@Uradical] " ^
s else "[ ] " ^
s in
3508 s, 0, Oaction
(fun () -> Config.historder
:= t
; reeenterhist := true)
3510 let list = ref [] in
3511 if Config.gethist
list
3515 (fun accu (path, c, b, x, a) ->
3516 let hist = (path, (c, b, x, a)) in
3517 let s = if !showfullpath then path else Filename.basename
path in
3518 let base = mbtoutf8
s in
3519 (base ^
"\000" ^
c.title
, 1, Ohistory
hist) :: accu
3521 [ setorty "Sort by time of last visit" `lastvisit
;
3522 setorty "Sort by file name" `file
;
3523 setorty "Sort by path" `
path;
3524 setorty "Sort by title" `title
;
3525 (if !showfullpath then "@Uradical "
3526 else " ") ^
"Show full path", 0, Oaction
(fun () ->
3527 showfullpath := not
!showfullpath; reeenterhist := true)
3528 ] (List.sort
(order orderty
) !list)
3534 let outlinesource sourcetype
=
3536 inherit lvsourcebase
3537 val mutable m_items
= E.a
3538 val mutable m_minfo
= E.a
3539 val mutable m_orig_items
= E.a
3540 val mutable m_orig_minfo
= E.a
3541 val mutable m_narrow_patterns
= []
3542 val mutable m_hadremovals
= false
3543 val mutable m_gen
= -1
3545 method getitemcount
=
3546 Array.length m_items
+ (if m_hadremovals
then 1 else 0)
3549 if n == Array.length m_items
&& m_hadremovals
3551 ("[Confirm removal]", 0)
3553 let s, n, _ = m_items
.(n) in
3556 method exit ~uioh ~cancel ~
active ~
first ~pan
=
3557 ignore
(uioh
, first);
3558 let confrimremoval = m_hadremovals
&& active = Array.length m_items
in
3560 if m_narrow_patterns
= []
3561 then m_orig_items
, m_orig_minfo
3562 else m_items
, m_minfo
3566 if not
confrimremoval
3568 gotooutline m_items
.(active);
3573 state
.bookmarks
<- Array.to_list m_items
;
3574 m_orig_items
<- m_items
;
3575 m_orig_minfo
<- m_minfo
;
3585 method hasaction
_ = true
3588 if Array.length m_items
!= Array.length m_orig_items
3591 match m_narrow_patterns
with
3593 | many
-> String.concat
"@Uellipsis" (List.rev many
)
3595 "Narrowed to " ^
s ^
" (ctrl-u to restore)"
3599 match m_narrow_patterns
with
3602 | head
:: _ -> "@Uellipsis" ^ head
3604 method narrow
pattern =
3605 let reopt = try Some
(Str.regexp_case_fold
pattern) with _ -> None
in
3609 let rec loop accu minfo n =
3612 m_items
<- Array.of_list
accu;
3613 m_minfo
<- Array.of_list
minfo;
3616 let (s, _, t
) as o = m_items
.(n) in
3619 | Oaction
_ -> o :: accu, (0, 0) :: minfo
3620 | Onone
| Oanchor
_ | Ouri
_ | Olaunch
_
3621 | Oremote
_ | Oremotedest
_ | Ohistory
_ ->
3623 try Str.search_forward
re s 0
3624 with Not_found
-> -1
3627 then o :: accu, (first, Str.match_end
()) :: minfo
3630 loop accu minfo (n-1)
3632 loop [] [] (Array.length m_items
- 1)
3634 method! getminfo
= m_minfo
3638 match sourcetype
with
3639 | `bookmarks
-> Array.of_list state
.bookmarks
3640 | `outlines
-> state
.outlines
3641 | `history
-> genhistoutlines !Config.historder
3643 m_minfo
<- m_orig_minfo
;
3644 m_items
<- m_orig_items
3647 if sourcetype
= `bookmarks
3649 if m >= 0 && m < Array.length m_items
3651 m_hadremovals
<- true;
3652 m_items
<- Array.init
(Array.length m_items
- 1) (fun n ->
3653 let n = if n >= m then n+1 else n in
3658 method add_narrow_pattern
pattern =
3659 m_narrow_patterns
<- pattern :: m_narrow_patterns
3661 method del_narrow_pattern
=
3662 match m_narrow_patterns
with
3663 | _ :: rest
-> m_narrow_patterns
<- rest
3668 match m_narrow_patterns
with
3669 | pattern :: [] -> self#narrow
pattern; pattern
3671 List.fold_left
(fun accu pattern ->
3672 self#narrow
pattern;
3673 pattern ^
"@Uellipsis" ^
accu) E.s list
3675 method calcactive
anchor =
3676 let rely = getanchory anchor in
3677 let rec loop n best bestd
=
3678 if n = Array.length m_items
3681 let _, _, kind
= m_items
.(n) in
3684 let orely = getanchory anchor in
3685 let d = abs
(orely - rely) in
3688 else loop (n+1) best bestd
3689 | Onone
| Oremote
_ | Olaunch
_
3690 | Oremotedest
_ | Ouri
_ | Ohistory
_ | Oaction
_ ->
3691 loop (n+1) best bestd
3695 method reset
anchor items =
3696 m_hadremovals
<- false;
3697 if state
.gen
!= m_gen
3699 m_orig_items
<- items;
3701 m_narrow_patterns
<- [];
3703 m_orig_minfo
<- E.a;
3707 if items != m_orig_items
3709 m_orig_items
<- items;
3710 if m_narrow_patterns
== []
3711 then m_items
<- items;
3714 let active = self#calcactive
anchor in
3716 m_first
<- firstof m_first
active
3720 let enterselector sourcetype
=
3722 let source = outlinesource sourcetype
in
3725 match sourcetype
with
3726 | `bookmarks
-> Array.of_list state
.bookmarks
3727 | `
outlines -> state
.outlines
3728 | `history
-> genhistoutlines !Config.historder
3730 if Array.length
outlines = 0
3732 showtext ' ' errmsg
;
3735 state
.text <- source#greetmsg
;
3736 Wsi.setcursor
Wsi.CURSOR_INHERIT
;
3737 let anchor = getanchor
() in
3738 source#reset
anchor outlines;
3740 coe (new outlinelistview ~zebra
:(sourcetype
=`history
) ~
source);
3741 G.postRedisplay "enter selector";
3745 let enteroutlinemode =
3746 let f = enterselector `
outlines in
3747 fun () -> f "Document has no outline";
3750 let enterbookmarkmode =
3751 let f = enterselector `bookmarks
in
3752 fun () -> f "Document has no bookmarks (yet)";
3755 let enterhistmode () = enterselector `history
"No history (yet)";;
3757 let makecheckers () =
3758 (* Based on lablGL-1.04/LablGlut/examples/lablGL/checker.ml which had
3760 converted by Issac Trotts. July 25, 2002 *)
3761 let image = GlPix.create `ubyte ~format
:`luminance ~width
:2 ~height
:2 in
3762 Raw.sets_string
(GlPix.to_raw
image) ~
pos:0 "\255\200\200\255";
3763 let id = GlTex.gen_texture
() in
3764 GlTex.bind_texture ~target
:`texture_2d
id;
3765 GlPix.store
(`unpack_alignment
1);
3766 GlTex.image2d
image;
3767 List.iter
(GlTex.parameter ~target
:`texture_2d
)
3768 [ `mag_filter `nearest
; `min_filter `nearest
];
3772 let setcheckers enabled
=
3773 match state
.checkerstexid
with
3775 if enabled
then state
.checkerstexid
<- Some
(makecheckers ())
3777 | Some checkerstexid
->
3780 GlTex.delete_texture checkerstexid
;
3781 state
.checkerstexid
<- None
;
3785 let describe_location () =
3786 let fn = page_of_y state
.y in
3787 let ln = page_of_y
(state
.y + state
.winh
- hscrollh () - 1) in
3788 let maxy = state
.maxy - (if conf
.maxhfit
then state
.winh
else 0) in
3792 else (100. *. (float state
.y /. float maxy))
3796 Printf.sprintf
"page %d of %d [%.2f%%]"
3797 (fn+1) state
.pagecount
percent
3800 "pages %d-%d of %d [%.2f%%]"
3801 (fn+1) (ln+1) state
.pagecount
percent
3804 let setpresentationmode v
=
3805 let n = page_of_y state
.y in
3806 state
.anchor <- (n, 0.0, 1.0);
3807 conf
.presentation
<- v
;
3808 if conf
.fitmodel
= FitPage
3809 then reqlayout conf
.angle conf
.fitmodel
;
3814 let btos b = if b then "@Uradical" else E.s in
3815 let showextended = ref false in
3816 let leave mode
_ = state
.mode
<- mode
in
3819 val mutable m_first_time
= true
3820 val mutable m_l
= []
3821 val mutable m_a
= E.a
3822 val mutable m_prev_uioh
= nouioh
3823 val mutable m_prev_mode
= View
3825 inherit lvsourcebase
3827 method reset prev_mode prev_uioh
=
3828 m_a
<- Array.of_list
(List.rev m_l
);
3830 m_prev_mode
<- prev_mode
;
3831 m_prev_uioh
<- prev_uioh
;
3835 if n >= Array.length m_a
3839 | _, _, _, Action
_ -> m_active
<- n
3840 | _, _, _, Noaction
-> loop (n+1)
3843 m_first_time
<- false;
3846 method int name get
set =
3848 (name
, `
int get
, 1, Action
(
3851 try set (int_of_string
s)
3853 state
.text <- Printf.sprintf
"bad integer `%s': %s"
3857 let te = name ^
": ", E.s, None
, intentry, ondone, true in
3858 state
.mode
<- Textentry
(te, leave m_prev_mode
);
3862 method int_with_suffix name get
set =
3864 (name
, `intws get
, 1, Action
(
3867 try set (int_of_string_with_suffix
s)
3869 state
.text <- Printf.sprintf
"bad integer `%s': %s"
3874 name ^
": ", E.s, None
, intentry_with_suffix, ondone, true
3876 state
.mode
<- Textentry
(te, leave m_prev_mode
);
3880 method bool ?
(offset
=1) ?
(btos=btos) name get
set =
3882 (name
, `
bool (btos, get
), offset
, Action
(
3889 method color name get
set =
3891 (name
, `color get
, 1, Action
(
3893 let invalid = (nan
, nan
, nan
) in
3896 try color_of_string
s
3898 state
.text <- Printf.sprintf
"bad color `%s': %s"
3905 let te = name ^
": ", E.s, None
, textentry, ondone, true in
3906 state
.text <- color_to_string
(get
());
3907 state
.mode
<- Textentry
(te, leave m_prev_mode
);
3911 method string name get
set =
3913 (name
, `
string get
, 1, Action
(
3915 let ondone s = set s in
3916 let te = name ^
": ", E.s, None
, textentry, ondone, true in
3917 state
.mode
<- Textentry
(te, leave m_prev_mode
);
3921 method colorspace name get
set =
3923 (name
, `
string get
, 1, Action
(
3927 inherit lvsourcebase
3930 m_active
<- CSTE.to_int conf
.colorspace
;
3933 method getitemcount
=
3934 Array.length
CSTE.names
3937 method exit ~uioh ~cancel ~
active ~
first ~pan
=
3938 ignore
(uioh
, first, pan
);
3939 if not cancel
then set active;
3941 method hasaction
_ = true
3945 let modehash = findkeyhash conf
"info" in
3946 coe (new listview ~zebra
:false ~helpmode
:false
3947 ~
source ~trusted
:true ~
modehash)
3950 method paxmark name get
set =
3952 (name
, `
string get
, 1, Action
(
3956 inherit lvsourcebase
3959 m_active
<- MTE.to_int conf
.paxmark
;
3962 method getitemcount
= Array.length
MTE.names
3963 method getitem
n = (MTE.names
.(n), 0)
3964 method exit ~uioh ~cancel ~
active ~
first ~pan
=
3965 ignore
(uioh
, first, pan
);
3966 if not cancel
then set active;
3968 method hasaction
_ = true
3972 let modehash = findkeyhash conf
"info" in
3973 coe (new listview ~zebra
:false ~helpmode
:false
3974 ~
source ~trusted
:true ~
modehash)
3977 method fitmodel name get
set =
3979 (name
, `
string get
, 1, Action
(
3983 inherit lvsourcebase
3986 m_active
<- FMTE.to_int conf
.fitmodel
;
3989 method getitemcount
= Array.length
FMTE.names
3990 method getitem
n = (FMTE.names
.(n), 0)
3991 method exit ~uioh ~cancel ~
active ~
first ~pan
=
3992 ignore
(uioh
, first, pan
);
3993 if not cancel
then set active;
3995 method hasaction
_ = true
3999 let modehash = findkeyhash conf
"info" in
4000 coe (new listview ~zebra
:false ~helpmode
:false
4001 ~
source ~trusted
:true ~
modehash)
4004 method caption
s offset
=
4005 m_l
<- (s, `empty
, offset
, Noaction
) :: m_l
4007 method caption2
s f offset
=
4008 m_l
<- (s, `
string f, offset
, Noaction
) :: m_l
4010 method getitemcount
= Array.length m_a
4013 let tostr = function
4014 | `
int f -> string_of_int
(f ())
4015 | `intws
f -> string_with_suffix_of_int
(f ())
4017 | `color
f -> color_to_string
(f ())
4018 | `
bool (btos, f) -> btos (f ())
4021 let name, t
, offset
, _ = m_a
.(n) in
4022 ((let s = tostr t
in
4024 then Printf.sprintf
"%s\t%s" name s
4028 method exit ~uioh ~cancel ~
active ~
first ~pan
=
4033 match m_a
.(active) with
4034 | _, _, _, Action
f -> f uioh
4035 | _, _, _, Noaction
-> uioh
4046 method hasaction
n =
4048 | _, _, _, Action
_ -> true
4049 | _, _, _, Noaction
-> false
4052 let rec fillsrc prevmode prevuioh
=
4053 let sep () = src#caption
E.s 0 in
4054 let colorp name get
set =
4056 (fun () -> color_to_string
(get
()))
4059 let c = color_of_string
v in
4062 state
.text <- Printf.sprintf
"bad color `%s': %s" v (exntos exn
)
4065 let oldmode = state
.mode
in
4066 let birdseye = isbirdseye state
.mode
in
4068 src#caption
(if birdseye then "Setup (Bird's eye)" else "Setup") 0;
4070 src#
bool "presentation mode"
4071 (fun () -> conf
.presentation
)
4072 (fun v -> setpresentationmode v);
4074 src#
bool "ignore case in searches"
4075 (fun () -> conf
.icase
)
4076 (fun v -> conf
.icase
<- v);
4079 (fun () -> conf
.preload)
4080 (fun v -> conf
.preload <- v);
4082 src#
bool "highlight links"
4083 (fun () -> conf
.hlinks
)
4084 (fun v -> conf
.hlinks
<- v);
4086 src#
bool "under info"
4087 (fun () -> conf
.underinfo
)
4088 (fun v -> conf
.underinfo
<- v);
4090 src#
bool "persistent bookmarks"
4091 (fun () -> conf
.savebmarks
)
4092 (fun v -> conf
.savebmarks
<- v);
4094 src#fitmodel
"fit model"
4095 (fun () -> FMTE.to_string conf
.fitmodel
)
4096 (fun v -> reqlayout conf
.angle
(FMTE.of_int
v));
4098 src#
bool "trim margins"
4099 (fun () -> conf
.trimmargins
)
4100 (fun v -> settrim v conf
.trimfuzz
; fillsrc prevmode prevuioh
);
4102 src#
bool "persistent location"
4103 (fun () -> conf
.jumpback
)
4104 (fun v -> conf
.jumpback
<- v);
4107 src#
int "inter-page space"
4108 (fun () -> conf
.interpagespace
)
4110 conf
.interpagespace
<- n;
4111 docolumns conf
.columns
;
4113 match state
.layout with
4118 state
.maxy <- calcheight
();
4119 let y = getpagey
pageno in
4124 (fun () -> conf
.pagebias
)
4125 (fun v -> conf
.pagebias
<- v);
4127 src#
int "scroll step"
4128 (fun () -> conf
.scrollstep
)
4129 (fun n -> conf
.scrollstep
<- n);
4131 src#
int "horizontal scroll step"
4132 (fun () -> conf
.hscrollstep
)
4133 (fun v -> conf
.hscrollstep
<- v);
4135 src#
int "auto scroll step"
4137 match state
.autoscroll
with
4139 | _ -> conf
.autoscrollstep
)
4141 let n = boundastep state
.winh
n in
4142 if state
.autoscroll
<> None
4143 then state
.autoscroll
<- Some
n;
4144 conf
.autoscrollstep
<- n);
4147 (fun () -> truncate
(conf
.zoom *. 100.))
4148 (fun v -> setzoom ((float v) /. 100.));
4151 (fun () -> conf
.angle
)
4152 (fun v -> reqlayout v conf
.fitmodel
);
4154 src#
int "scroll bar width"
4155 (fun () -> conf
.scrollbw
)
4158 reshape state
.winw state
.winh
;
4161 src#
int "scroll handle height"
4162 (fun () -> conf
.scrollh
)
4163 (fun v -> conf
.scrollh
<- v;);
4165 src#
int "thumbnail width"
4166 (fun () -> conf
.thumbw
)
4168 conf
.thumbw
<- min
4096 v;
4171 leavebirdseye beye
false;
4178 let mode = state
.mode in
4179 src#
string "columns"
4181 match conf
.columns
with
4183 | Cmulti
(multi
, _) -> multicolumns_to_string multi
4184 | Csplit
(count
, _) -> "-" ^ string_of_int count
4187 let n, a, b = multicolumns_of_string
v in
4188 setcolumns mode n a b);
4191 src#caption
"Pixmap cache" 0;
4192 src#int_with_suffix
"size (advisory)"
4193 (fun () -> conf
.memlimit
)
4194 (fun v -> conf
.memlimit
<- v);
4197 (fun () -> Printf.sprintf
"%s bytes, %d tiles"
4198 (string_with_suffix_of_int state
.memused
)
4199 (Hashtbl.length state
.tilemap
)) 1;
4202 src#caption
"Layout" 0;
4203 src#caption2
"Dimension"
4205 Printf.sprintf
"%dx%d (virtual %dx%d)"
4206 state
.winw state
.winh
4211 src#caption2
"Position" (fun () ->
4212 Printf.sprintf
"%dx%d" state
.x state
.y
4215 src#caption2
"Position" (fun () -> describe_location ()) 1
4219 src#
bool ~offset
:0 ~
btos:(fun v -> if v then "(on)" else "(off)")
4220 "Save these parameters as global defaults at exit"
4221 (fun () -> conf
.bedefault
)
4222 (fun v -> conf
.bedefault
<- v)
4226 let btos b = if b then "@Ulguillemet" else "@Urguillemet" in
4227 src#
bool ~offset
:0 ~
btos "Extended parameters"
4228 (fun () -> !showextended)
4229 (fun v -> showextended := v; fillsrc prevmode prevuioh
);
4233 (fun () -> conf
.checkers
)
4234 (fun v -> conf
.checkers
<- v; setcheckers v);
4235 src#
bool "update cursor"
4236 (fun () -> conf
.updatecurs
)
4237 (fun v -> conf
.updatecurs
<- v);
4238 src#
bool "scroll-bar on the left"
4239 (fun () -> conf
.leftscroll
)
4240 (fun v -> conf
.leftscroll
<- v);
4242 (fun () -> conf
.verbose
)
4243 (fun v -> conf
.verbose
<- v);
4244 src#
bool "invert colors"
4245 (fun () -> conf
.invert
)
4246 (fun v -> conf
.invert
<- v);
4248 (fun () -> conf
.maxhfit
)
4249 (fun v -> conf
.maxhfit
<- v);
4250 src#
bool "redirect stderr"
4251 (fun () -> conf
.redirectstderr)
4252 (fun v -> conf
.redirectstderr <- v; redirectstderr ());
4254 (fun () -> conf
.pax
!= None
)
4257 then conf
.pax
<- Some
(ref (now
(), 0, 0))
4258 else conf
.pax
<- None
);
4259 src#
string "uri launcher"
4260 (fun () -> conf
.urilauncher
)
4261 (fun v -> conf
.urilauncher
<- v);
4262 src#
string "path launcher"
4263 (fun () -> conf
.pathlauncher
)
4264 (fun v -> conf
.pathlauncher
<- v);
4265 src#
string "tile size"
4266 (fun () -> Printf.sprintf
"%dx%d" conf
.tilew conf
.tileh
)
4269 let w, h = Scanf.sscanf
v "%dx%d" (fun w h -> w, h) in
4270 conf
.tilew
<- max
64 w;
4271 conf
.tileh
<- max
64 h;
4274 state
.text <- Printf.sprintf
"bad tile size `%s': %s"
4277 src#
int "texture count"
4278 (fun () -> conf
.texcount
)
4281 then conf
.texcount
<- v
4282 else showtext '
!'
" Failed to set texture count please retry later"
4284 src#
int "slice height"
4285 (fun () -> conf
.sliceheight
)
4287 conf
.sliceheight
<- v;
4288 wcmd "sliceh %d" conf
.sliceheight
;
4290 src#
int "anti-aliasing level"
4291 (fun () -> conf
.aalevel
)
4293 conf
.aalevel
<- bound
v 0 8;
4294 state
.anchor <- getanchor
();
4295 opendoc state
.path state
.password
;
4297 src#
string "page scroll scaling factor"
4298 (fun () -> string_of_float conf
.pgscale)
4301 let s = float_of_string
v in
4304 state
.text <- Printf.sprintf
4305 "bad page scroll scaling factor `%s': %s" v (exntos exn
)
4308 src#
int "ui font size"
4309 (fun () -> fstate
.fontsize
)
4310 (fun v -> setfontsize (bound
v 5 100));
4311 src#
int "hint font size"
4312 (fun () -> conf
.hfsize
)
4313 (fun v -> conf
.hfsize
<- bound
v 5 100);
4314 colorp "background color"
4315 (fun () -> conf
.bgcolor
)
4316 (fun v -> conf
.bgcolor
<- v);
4317 src#
bool "crop hack"
4318 (fun () -> conf
.crophack
)
4319 (fun v -> conf
.crophack
<- v);
4320 src#
string "trim fuzz"
4321 (fun () -> irect_to_string conf
.trimfuzz
)
4324 conf
.trimfuzz
<- irect_of_string
v;
4326 then settrim true conf
.trimfuzz
;
4328 state
.text <- Printf.sprintf
"bad irect `%s': %s" v (exntos exn
)
4330 src#
string "throttle"
4332 match conf
.maxwait
with
4333 | None
-> "show place holder if page is not ready"
4336 then "wait for page to fully render"
4338 "wait " ^ string_of_float
time
4339 ^
" seconds before showing placeholder"
4343 let f = float_of_string
v in
4345 then conf
.maxwait
<- None
4346 else conf
.maxwait
<- Some
f
4348 state
.text <- Printf.sprintf
"bad time `%s': %s" v (exntos exn
)
4350 src#
string "ghyll scroll"
4352 match conf
.ghyllscroll
with
4354 | Some nab
-> ghyllscroll_to_string nab
4357 try conf
.ghyllscroll
<- ghyllscroll_of_string
v
4359 state
.text <- Printf.sprintf
"bad ghyll `%s': %s" v (exntos exn
)
4361 src#
string "selection command"
4362 (fun () -> conf
.selcmd
)
4363 (fun v -> conf
.selcmd
<- v);
4364 src#
string "synctex command"
4365 (fun () -> conf
.stcmd
)
4366 (fun v -> conf
.stcmd
<- v);
4367 src#
string "pax command"
4368 (fun () -> conf
.paxcmd
)
4369 (fun v -> conf
.paxcmd
<- v);
4370 src#colorspace
"color space"
4371 (fun () -> CSTE.to_string conf
.colorspace
)
4373 conf
.colorspace
<- CSTE.of_int
v;
4377 src#paxmark
"pax mark method"
4378 (fun () -> MTE.to_string conf
.paxmark
)
4379 (fun v -> conf
.paxmark
<- MTE.of_int
v);
4383 (fun () -> conf
.usepbo
)
4384 (fun v -> conf
.usepbo
<- v);
4385 src#
bool "mouse wheel scrolls pages"
4386 (fun () -> conf
.wheelbypage
)
4387 (fun v -> conf
.wheelbypage
<- v);
4388 src#
bool "open remote links in a new instance"
4389 (fun () -> conf
.riani
)
4390 (fun v -> conf
.riani
<- v);
4394 src#caption
"Document" 0;
4395 List.iter
(fun (_, s) -> src#caption
s 1) state
.docinfo
;
4396 src#caption2
"Pages"
4397 (fun () -> string_of_int state
.pagecount
) 1;
4398 src#caption2
"Dimensions"
4399 (fun () -> string_of_int
(List.length state
.pdims
)) 1;
4403 src#caption
"Trimmed margins" 0;
4404 src#caption2
"Dimensions"
4405 (fun () -> string_of_int
(List.length state
.pdims
)) 1;
4409 src#caption
"OpenGL" 0;
4410 src#caption
(Printf.sprintf
"Vendor\t%s" (GlMisc.get_string `vendor
)) 1;
4411 src#caption
(Printf.sprintf
"Renderer\t%s" (GlMisc.get_string `renderer
)) 1;
4414 src#caption
"Location" 0;
4415 if nonemptystr state
.origin
4416 then src#caption
("Orign\t" ^ mbtoutf8 state
.origin
) 1;
4417 src#caption
("Path\t" ^ mbtoutf8 state
.path) 1;
4419 src#reset prevmode prevuioh
;
4424 let prevmode = state
.mode
4425 and prevuioh
= state
.uioh in
4426 fillsrc prevmode prevuioh
;
4427 let source = (src :> lvsource
) in
4428 let modehash = findkeyhash conf
"info" in
4429 state
.uioh <- coe (object (self)
4430 inherit listview ~zebra
:false ~helpmode
:false
4431 ~
source ~trusted
:true ~
modehash as super
4432 val mutable m_prevmemused
= 0
4433 method! infochanged
= function
4435 if m_prevmemused
!= state
.memused
4437 m_prevmemused
<- state
.memused
;
4438 G.postRedisplay "memusedchanged";
4440 | Pdim
-> G.postRedisplay "pdimchanged"
4441 | Docinfo
-> fillsrc prevmode prevuioh
4443 method! key key mask
=
4444 if not
(Wsi.withctrl mask
)
4447 | @left | @kpleft
-> coe (self#updownlevel ~
-1)
4448 | @right
| @kpright
-> coe (self#updownlevel
1)
4449 | _ -> super#
key key mask
4450 else super#
key key mask
4452 G.postRedisplay "info";
4458 inherit lvsourcebase
4459 method getitemcount
= Array.length state
.help
4461 let s, l, _ = state
.help
.(n) in
4464 method exit ~
uioh ~cancel ~
active ~
first ~pan
=
4468 match state
.help
.(active) with
4469 | _, _, Action
f -> Some
(f uioh)
4470 | _, _, Noaction
-> Some
uioh
4479 method hasaction
n =
4480 match state
.help
.(n) with
4481 | _, _, Action
_ -> true
4482 | _, _, Noaction
-> false
4488 let modehash = findkeyhash conf
"help" in
4490 state
.uioh <- coe (new listview
4491 ~zebra
:false ~helpmode
:true
4492 ~
source ~trusted
:true ~
modehash);
4493 G.postRedisplay "help";
4498 let re = Str.regexp
"[\r\n]" in
4500 inherit lvsourcebase
4501 val mutable m_items
= E.a
4503 method getitemcount
= 1 + Array.length m_items
4508 else m_items
.(n-1), 0
4510 method exit ~
uioh ~cancel ~
active ~
first ~pan
=
4515 then Buffer.clear state
.errmsgs
;
4522 method hasaction
n =
4526 state
.newerrmsgs
<- false;
4527 let l = Str.split
re (Buffer.contents state
.errmsgs
) in
4528 m_items
<- Array.of_list
l
4537 let source = (msgsource :> lvsource
) in
4538 let modehash = findkeyhash conf
"listview" in
4539 state
.uioh <- coe (object
4540 inherit listview ~zebra
:false ~helpmode
:false
4541 ~
source ~trusted
:false ~
modehash as super
4544 then msgsource#reset
;
4547 G.postRedisplay "msgs";
4550 let enterannotmode =
4553 inherit lvsourcebase
4554 val mutable m_items
= E.a
4556 method getitemcount
= Array.length m_items
4561 method exit ~
uioh ~cancel ~
active ~
first ~pan
=
4562 ignore
(uioh, cancel
, active, first, pan
);
4565 method hasaction
_ = true
4568 state
.newerrmsgs
<- false;
4569 let rec split accu b i
=
4571 if p = String.length
s
4572 then String.sub
s b (p-b) :: accu
4574 if (i
> 70 && s.[p] = ' '
) || s.[p] = '
\r'
|| s.[p] = '
\n'
4576 let ss = if i
= 0 then E.s else String.sub
s b i
in
4577 split (ss::accu) (p+1) 0
4581 m_items
<- split [] 0 0 |> List.rev
|> Array.of_list
4590 let source = (msgsource :> lvsource
) in
4591 let modehash = findkeyhash conf
"listview" in
4592 state
.uioh <- coe (object
4593 inherit listview ~zebra
:false ~helpmode
:false
4594 ~
source ~trusted
:false ~
modehash
4596 G.postRedisplay "annot";
4599 let quickbookmark ?title
() =
4600 match state
.layout with
4606 let tm = Unix.localtime
(now
()) in
4607 Printf.sprintf
"Quick (page %d) (bookmarked at %d/%d/%d %d:%d)"
4611 (tm.Unix.tm_year
+ 1900)
4614 | Some
title -> title
4616 state
.bookmarks
<- (title, 0, Oanchor
(getanchor1
l)) :: state
.bookmarks
4619 let setautoscrollspeed step goingdown
=
4620 let incr = max
1 ((abs step
) / 2) in
4621 let incr = if goingdown
then incr else -incr in
4622 let astep = boundastep state
.winh
(step
+ incr) in
4623 state
.autoscroll
<- Some
astep;
4627 match conf
.columns
with
4629 | Csingle
_ | Cmulti
_ -> state
.x != 0 || conf
.zoom > 1.0
4632 let panbound x = bound
x (-state
.w) (wadjsb () + state
.winw
);;
4634 let existsinrow pageno (columns
, coverA
, coverB
) p =
4635 let last = ((pageno - coverA
) mod columns
) + columns
in
4636 let rec any = function
4639 if l.pageno = coverA
- 1 || l.pageno = state
.pagecount
- coverB
4643 then (if l.pageno = last then false else any rest
)
4651 match state
.layout with
4653 let pageno = page_of_y state
.y in
4654 gotoghyll (getpagey
(pageno+1))
4656 match conf
.columns
with
4658 if conf
.presentation
&& rest
== [] && l.pageh
> l.pagey + l.pagevh
4660 let y = clamp (pgscale state
.winh
) in
4663 let pageno = min
(l.pageno+1) (state
.pagecount
-1) in
4664 gotoghyll (getpagey
pageno)
4665 | Cmulti
((c, _, _) as cl, _) ->
4666 if conf
.presentation
4667 && (existsinrow l.pageno cl
4668 (fun l -> l.pageh
> l.pagey + l.pagevh))
4670 let y = clamp (pgscale state
.winh
) in
4673 let pageno = min
(l.pageno+c) (state
.pagecount
-1) in
4674 gotoghyll (getpagey
pageno)
4676 if l.pageno < state
.pagecount
- 1 || l.pagecol
< n - 1
4678 let pagey, pageh
= getpageyh
l.pageno in
4679 let pagey = pagey + pageh
* l.pagecol
in
4680 let ips = if l.pagecol
= 0 then 0 else conf
.interpagespace
in
4681 gotoghyll (pagey + pageh
+ ips)
4685 match state
.layout with
4687 let pageno = page_of_y state
.y in
4688 gotoghyll (getpagey
(pageno-1))
4690 match conf
.columns
with
4692 if conf
.presentation
&& l.pagey != 0
4694 gotoghyll (clamp (pgscale ~
-(state
.winh
)))
4696 let pageno = max
0 (l.pageno-1) in
4697 gotoghyll (getpagey
pageno)
4698 | Cmulti
((c, _, coverB
) as cl, _) ->
4699 if conf
.presentation
&&
4700 (existsinrow l.pageno cl (fun l -> l.pagey != 0))
4702 gotoghyll (clamp (pgscale ~
-(state
.winh
)))
4705 if l.pageno = state
.pagecount
- coverB
4709 let pageno = max
0 (l.pageno-decr) in
4710 gotoghyll (getpagey
pageno)
4718 let pageno = max
0 (l.pageno-1) in
4719 let pagey, pageh
= getpageyh
pageno in
4722 let pagey, pageh
= getpageyh
l.pageno in
4723 pagey + pageh
* (l.pagecol
-1) - conf
.interpagespace
4728 let viewkeyboard key mask
=
4730 let mode = state
.mode in
4731 state
.mode <- Textentry
(te, fun _ -> state
.mode <- mode);
4734 G.postRedisplay "view:enttext"
4736 let ctrl = Wsi.withctrl mask
in
4738 if key >= 0xffb0 && key < 0xffb9 then key - 0xffb0 + 48 else key
4743 if conf
.angle
mod 360 = 0 && not
(isbirdseye state
.mode)
4745 state
.mode <- LinkNav
(Ltgendir
0);
4748 else showtext '
!'
"Keyboard link navigation does not work under rotation"
4751 begin match state
.mstate
with
4754 G.postRedisplay "kill zoom rect";
4757 | Mscrolly
| Mscrollx
4760 begin match state
.mode with
4763 G.postRedisplay "esc leave linknav"
4767 match state
.ranchors
with
4769 | (path, password
, anchor, origin
) :: rest
->
4770 state
.ranchors
<- rest
;
4771 state
.anchor <- anchor;
4772 state
.origin
<- origin
;
4773 state
.nameddest
<- E.s;
4774 opendoc path password
4779 gotoghyll (getnav ~
-1)
4790 Hashtbl.iter
(fun _ opaque -> clearmark
opaque) state
.pagemap
;
4791 G.postRedisplay "dehighlight";
4793 | @slash
| @question
->
4794 let ondone isforw
s =
4795 cbput state
.hists
.pat
s;
4796 state
.searchpattern
<- s;
4799 let s = String.make
1 (Char.chr
key) in
4800 enttext (s, E.s, Some
(onhist state
.hists
.pat
),
4801 textentry, ondone (key = @slash
), true)
4803 | @plus
| @kpplus
| @equals
when ctrl ->
4804 let incr = if conf
.zoom +. 0.01 > 0.1 then 0.1 else 0.01 in
4805 setzoom (conf
.zoom +. incr)
4807 | @plus
| @kpplus
->
4810 try int_of_string
s with exc
->
4811 state
.text <- Printf.sprintf
"bad integer `%s': %s" s (exntos exc
);
4817 state
.text <- "page bias is now " ^ string_of_int
n;
4820 enttext ("page bias: ", E.s, None
, intentry, ondone, true)
4822 | @minus
| @kpminus
when ctrl ->
4823 let decr = if conf
.zoom -. 0.1 < 0.1 then 0.01 else 0.1 in
4824 setzoom (max
0.01 (conf
.zoom -. decr))
4826 | @minus
| @kpminus
->
4827 let ondone msg
= state
.text <- msg
in
4829 "option [acfhilpstvxACFPRSZTISM]: ", E.s, None
,
4830 optentry state
.mode, ondone, true
4841 | (@1 | @2) when ctrl && conf
.fitmodel
!= FitPage
-> (* ctrl-1/2 *)
4843 match conf
.columns
with
4844 | Csingle
_ | Cmulti
_ -> 1
4845 | Csplit
(n, _) -> n
4847 let h = state
.winh
-
4848 conf
.interpagespace
lsl (if conf
.presentation
then 1 else 0)
4850 let zoom = zoomforh state
.winw
h (vscrollw ()) cols in
4851 if zoom > 0.0 && (key = 50 || zoom < 1.0)
4856 match conf
.fitmodel
with
4857 | FitWidth
-> FitProportional
4858 | FitProportional
-> FitPage
4859 | FitPage
-> FitWidth
4861 state
.text <- "fit model: " ^
FMTE.to_string
fm;
4862 reqlayout conf
.angle
fm
4870 | (48 | 49 | 50 | 51 | 52 | 53 | 54 | 55 | 56 | 57)
4871 when not
ctrl -> (* 0..9 *)
4874 try int_of_string
s with exc
->
4875 state
.text <- Printf.sprintf
"bad integer `%s': %s" s (exntos exc
);
4881 cbput state
.hists
.pag
(string_of_int
n);
4882 gotopage1 (n + conf
.pagebias
- 1) 0;
4885 let pageentry text key =
4886 match Char.unsafe_chr
key with
4887 | '
g'
-> TEdone
text
4888 | _ -> intentry text key
4890 let text = String.make
1 (Char.chr
key) in
4891 enttext (":", text, Some
(onhist state
.hists
.pag
),
4892 pageentry, ondone, true)
4895 conf
.scrollb
<- if conf
.scrollb
= 0 then (scrollbvv
lor scrollbhv
) else 0;
4896 reshape state
.winw state
.winh
;
4899 state
.bzoom
<- not state
.bzoom
;
4901 showtext ' '
("block zoom " ^
if state
.bzoom
then "on" else "off")
4904 conf
.hlinks
<- not conf
.hlinks
;
4905 state
.text <- "highlightlinks " ^
if conf
.hlinks
then "on" else "off";
4906 G.postRedisplay "toggle highlightlinks";
4909 state
.glinks
<- true;
4910 let mode = state
.mode in
4911 state
.mode <- Textentry
(
4912 (":", E.s, None
, linknentry, linkndone gotounder, false),
4914 state
.glinks
<- false;
4918 G.postRedisplay "view:linkent(F)"
4921 state
.glinks
<- true;
4922 let mode = state
.mode in
4923 state
.mode <- Textentry
(
4925 ":", E.s, None
, linknentry, linkndone (fun under ->
4926 selstring (undertext under);
4930 state
.glinks
<- false;
4934 G.postRedisplay "view:linkent"
4937 begin match state
.autoscroll
with
4939 conf
.autoscrollstep
<- step
;
4940 state
.autoscroll
<- None
4942 if conf
.autoscrollstep
= 0
4943 then state
.autoscroll
<- Some
1
4944 else state
.autoscroll
<- Some conf
.autoscrollstep
4951 setpresentationmode (not conf
.presentation
);
4952 showtext ' '
("presentation mode " ^
4953 if conf
.presentation
then "on" else "off");
4956 if List.mem
Wsi.Fullscreen state
.winstate
4957 then Wsi.reshape conf
.cwinw conf
.cwinh
4958 else Wsi.fullscreen
()
4961 search state
.searchpattern
false
4964 search state
.searchpattern
true
4967 begin match state
.layout with
4970 gotoghyll (getpagey
l.pageno)
4976 | @delete
| @kpdelete
-> (* delete *)
4980 showtext ' '
(describe_location ());
4983 begin match state
.layout with
4986 Wsi.reshape (l.pagew
+ vscrollw ()) l.pageh
;
4991 enterbookmarkmode ()
4999 | @e when Buffer.length state
.errmsgs
> 0 ->
5004 match state
.layout with
5009 (s, 0, Oanchor
(getanchor1
l)) :: state
.bookmarks
5012 enttext ("bookmark: ", E.s, None
, textentry, ondone, true)
5016 showtext ' '
"Quick bookmark added";
5019 begin match state
.layout with
5021 let rect = getpdimrect
l.pagedimno
in
5025 (truncate
(1.8 *. (rect.(1) -. rect.(0))),
5026 truncate
(1.2 *. (rect.(3) -. rect.(0))))
5028 (truncate
(rect.(1) -. rect.(0)),
5029 truncate
(rect.(3) -. rect.(0)))
5031 let w = truncate
((float w)*.conf
.zoom)
5032 and h = truncate
((float h)*.conf
.zoom) in
5035 state
.anchor <- getanchor
();
5036 Wsi.reshape (w + vscrollw ()) (h + conf
.interpagespace
)
5038 G.postRedisplay "z";
5043 | @x -> state
.roam
()
5046 reqlayout (conf
.angle
+
5047 (if key = @Gt
then 30 else -30)) conf
.fitmodel
5051 bound
(conf
.colorscale
+. (if key = 93 then 0.1 else -0.1)) 0.0 1.0
5053 G.postRedisplay "brightness";
5055 | @c when state
.mode = View
->
5060 let m = (wadjsb () + state
.winw
- state
.w) / 2 in
5062 gotoy_and_clear_text state
.y
5066 match state
.prevcolumns
with
5067 | None
-> (1, 0, 0), 1.0
5068 | Some
(columns
, z
) ->
5071 | Csplit
(c, _) -> -c, 0, 0
5072 | Cmulti
((c, a, b), _) -> c, a, b
5073 | Csingle
_ -> 1, 0, 0
5077 setcolumns View
c a b;
5080 | @down
| @up
when ctrl && Wsi.withshift mask
->
5081 let zoom, x = state
.prevzoom
in
5085 | @k
| @up
| @kpup
->
5086 begin match state
.autoscroll
with
5088 begin match state
.mode with
5089 | Birdseye beye
-> upbirdseye 1 beye
5094 then gotoy_and_clear_text (clamp ~
-(state
.winh
/2))
5096 if not
(Wsi.withshift mask
) && conf
.presentation
5098 else gotoghyll1 true (clamp (-conf
.scrollstep
))
5102 setautoscrollspeed n false
5105 | @j
| @down
| @kpdown
->
5106 begin match state
.autoscroll
with
5108 begin match state
.mode with
5109 | Birdseye beye
-> downbirdseye 1 beye
5114 then gotoy_and_clear_text (clamp (state
.winh
/2))
5116 if not
(Wsi.withshift mask
) && conf
.presentation
5118 else gotoghyll1 true (clamp (conf
.scrollstep
))
5122 setautoscrollspeed n true
5125 | @left | @right
| @kpleft
| @kpright
when not
(Wsi.withalt mask
) ->
5131 else conf
.hscrollstep
5133 let dx = if key = @left || key = @kpleft
then dx else -dx in
5134 state
.x <- panbound (state
.x + dx);
5135 gotoy_and_clear_text state
.y
5138 G.postRedisplay "left/right"
5141 | @prior
| @kpprior
->
5145 match state
.layout with
5147 | l :: _ -> state
.y - l.pagey
5149 clamp (pgscale (-state
.winh
))
5153 | @next | @kpnext
->
5157 match List.rev state
.layout with
5159 | l :: _ -> getpagey
l.pageno
5161 clamp (pgscale state
.winh
)
5165 | @g | @home
| @kphome
->
5168 | @G
| @jend
| @kpend
->
5170 gotoghyll (clamp state
.maxy)
5172 | @right
| @kpright
when Wsi.withalt mask
->
5173 gotoghyll (getnav 1)
5174 | @left | @kpleft
when Wsi.withalt mask
->
5175 gotoghyll (getnav ~
-1)
5180 | @v when conf
.debug
->
5183 match getopaque l.pageno with
5186 let x0, y0, x1, y1 = pagebbox
opaque in
5187 let a,b = float x0, float y0 in
5188 let c,d = float x1, float y0 in
5189 let e,f = float x1, float y1 in
5190 let h,j
= float x0, float y1 in
5191 let rect = (a,b,c,d,e,f,h,j
) in
5193 state
.rects
<- (l.pageno, l.pageno mod 3, rect) :: state
.rects
;
5195 G.postRedisplay "v";
5198 let mode = state
.mode in
5199 let cmd = ref E.s in
5200 let onleave = function
5201 | Cancel
-> state
.mode <- mode
5204 match getopaque l.pageno with
5205 | Some
opaque -> pipesel opaque !cmd
5206 | None
-> ()) state
.layout;
5210 cbput state
.hists
.sel
s;
5214 "| ", !cmd, Some
(onhist state
.hists
.sel
), textentry, ondone, true
5216 G.postRedisplay "|";
5217 state
.mode <- Textentry
(te, onleave);
5220 vlog "huh? %s" (Wsi.keyname
key)
5223 let linknavkeyboard key mask
linknav =
5224 let getpage pageno =
5225 let rec loop = function
5227 | l :: _ when l.pageno = pageno -> Some
l
5228 | _ :: rest
-> loop rest
5229 in loop state
.layout
5231 let doexact (pageno, n) =
5232 match getopaque pageno, getpage pageno with
5233 | Some
opaque, Some
l ->
5234 if key = @enter
|| key = @kpenter
5236 let under = getlink
opaque n in
5237 G.postRedisplay "link gotounder";
5244 Some
(findlink
opaque LDfirst
), -1
5247 Some
(findlink
opaque LDlast
), 1
5250 Some
(findlink
opaque (LDleft
n)), -1
5253 Some
(findlink
opaque (LDright
n)), 1
5256 Some
(findlink
opaque (LDup
n)), -1
5259 Some
(findlink
opaque (LDdown
n)), 1
5264 begin match findpwl
l.pageno dir with
5268 state
.mode <- LinkNav
(Ltgendir
dir);
5269 let y, h = getpageyh
pageno in
5272 then y + h - state
.winh
5277 begin match getopaque pageno, getpage pageno with
5278 | Some
opaque, Some
_ ->
5280 let ld = if dir > 0 then LDfirst
else LDlast
in
5283 begin match link with
5285 showlinktype (getlink
opaque m);
5286 state
.mode <- LinkNav
(Ltexact
(pageno, m));
5287 G.postRedisplay "linknav jpage";
5288 | Lnotfound
-> notfound dir
5294 begin match opt with
5295 | Some Lnotfound
-> pwl l dir;
5296 | Some
(Lfound
m) ->
5300 let _, y0, _, y1 = getlinkrect
opaque m in
5302 then gotopage1 l.pageno y0
5304 let d = fstate
.fontsize
+ 1 in
5305 if y1 - l.pagey > l.pagevh - d
5306 then gotopage1 l.pageno (y1 - state
.winh
- hscrollh () + d)
5307 else G.postRedisplay "linknav";
5309 showlinktype (getlink
opaque m);
5310 state
.mode <- LinkNav
(Ltexact
(l.pageno, m));
5313 | None
-> viewkeyboard key mask
5315 | _ -> viewkeyboard key mask
5320 G.postRedisplay "leave linknav"
5324 | Ltgendir
_ -> viewkeyboard key mask
5325 | Ltexact exact
-> doexact exact
5328 let keyboard key mask
=
5329 if (key = 103 && Wsi.withctrl mask
) && not
(istextentry state
.mode)
5330 then wcmd "interrupt"
5331 else state
.uioh <- state
.uioh#
key key mask
5334 let birdseyekeyboard key mask
5335 ((oconf
, leftx
, pageno, hooverpageno
, anchor) as beye
) =
5337 match conf
.columns
with
5339 | Cmulti
((c, _, _), _) -> c
5340 | Csplit
_ -> failwith
"bird's eye split mode"
5342 let pgh layout = List.fold_left
5343 (fun m l -> max
l.pageh
m) state
.winh
layout in
5345 | @l when Wsi.withctrl mask
->
5346 let y, h = getpageyh
pageno in
5347 let top = (state
.winh
- h) / 2 in
5348 gotoy (max
0 (y - top))
5349 | @enter
| @kpenter
-> leavebirdseye beye
false
5350 | @escape
-> leavebirdseye beye
true
5351 | @up
-> upbirdseye incr beye
5352 | @down
-> downbirdseye incr beye
5353 | @left -> upbirdseye 1 beye
5354 | @right
-> downbirdseye 1 beye
5357 begin match state
.layout with
5361 state
.mode <- Birdseye
(
5362 oconf
, leftx
, l.pageno, hooverpageno
, anchor
5364 gotopage1 l.pageno 0;
5367 let layout = layout (state
.y-state
.winh
) (pgh state
.layout) in
5369 | [] -> gotoy (clamp (-state
.winh
))
5371 state
.mode <- Birdseye
(
5372 oconf
, leftx
, l.pageno, hooverpageno
, anchor
5374 gotopage1 l.pageno 0
5377 | [] -> gotoy (clamp (-state
.winh
))
5381 begin match List.rev state
.layout with
5383 let layout = layout (state
.y + (pgh state
.layout)) state
.winh
in
5384 begin match layout with
5386 let incr = l.pageh
- l.pagevh in
5391 oconf
, leftx
, state
.pagecount
- 1, hooverpageno
, anchor
5393 G.postRedisplay "birdseye pagedown";
5395 else gotoy (clamp (incr + conf
.interpagespace
*2));
5399 Birdseye
(oconf
, leftx
, l.pageno, hooverpageno
, anchor);
5400 gotopage1 l.pageno 0;
5403 | [] -> gotoy (clamp state
.winh
)
5407 state
.mode <- Birdseye
(oconf
, leftx
, 0, hooverpageno
, anchor);
5411 let pageno = state
.pagecount
- 1 in
5412 state
.mode <- Birdseye
(oconf
, leftx
, pageno, hooverpageno
, anchor);
5413 if not
(pagevisible state
.layout pageno)
5416 match List.rev state
.pdims
with
5418 | (_, _, h, _) :: _ -> h
5420 gotoy (max
0 (getpagey
pageno - (state
.winh
- h - conf
.interpagespace
)))
5421 else G.postRedisplay "birdseye end";
5423 | _ -> viewkeyboard key mask
5428 match state
.mode with
5429 | Textentry
_ -> scalecolor 0.4
5431 | View
-> scalecolor 1.0
5432 | Birdseye
(_, _, pageno, hooverpageno
, _) ->
5433 if l.pageno = hooverpageno
5436 if l.pageno = pageno
5438 let c = scalecolor 1.0 in
5440 GlDraw.line_width
3.0;
5441 let dispx = xadjsb () + l.pagedispx in
5443 (float (dispx-1)) (float (l.pagedispy-1))
5444 (float (dispx+l.pagevw+1))
5445 (float (l.pagedispy+l.pagevh+1))
5447 GlDraw.line_width
1.0;
5456 let postdrawpage l linkindexbase
=
5457 match getopaque l.pageno with
5459 if tileready l l.pagex
l.pagey
5461 let x = l.pagedispx - l.pagex
+ xadjsb ()
5462 and y = l.pagedispy - l.pagey in
5464 match conf
.columns
with
5465 | Csingle
_ | Cmulti
_ ->
5466 (if conf
.hlinks
then 1 else 0)
5468 && not
(isbirdseye state
.mode) then 2 else 0)
5472 match state
.mode with
5473 | Textentry
((_, s, _, _, _, _), _) when state
.glinks
-> s
5479 postprocess
opaque hlmask x y (linkindexbase
, s, conf
.hfsize
);
5484 let scrollindicator () =
5485 let sbw, ph
, sh = state
.uioh#
scrollph in
5486 let sbh, pw, sw = state
.uioh#scrollpw
in
5491 else ((state
.winw
- sbw), state
.winw
, 0)
5494 GlDraw.color (0.64, 0.64, 0.64);
5495 filledrect (float x0) 0. (float x1) (float state
.winh
);
5497 (float hx0
) (float (state
.winh
- sbh))
5498 (float (hx0
+ wadjsb () + state
.winw
)) (float state
.winh
)
5500 GlDraw.color (0.0, 0.0, 0.0);
5502 filledrect (float x0) ph
(float x1) (ph
+. sh);
5503 let pw = pw +. float hx0
in
5504 filledrect pw (float (state
.winh
- sbh)) (pw +. sw) (float state
.winh
);
5508 match state
.mstate
with
5509 | Mnone
| Mscrolly
| Mscrollx
| Mpan
_ | Mzoom
_ | Mzoomrect
_ ->
5512 | Msel
((x0, y0), (x1, y1)) ->
5513 let identify opaque l px py = Some
(opaque, l.pageno, px, py) in
5514 let o0,n0
,px0
,py0
= onppundermouse identify x0 y0 (~
< E.s, -1, 0, 0) in
5515 let _o1,n1
,px1
,py1
= onppundermouse identify x1 y1 (~
< E.s, -1, 0, 0) in
5516 if n0
!= -1 && n0
= n1
then seltext
o0 (px0
, py0
, px1
, py1
);
5519 let showrects = function [] -> () | rects
->
5521 GlDraw.color (0.0, 0.0, 1.0) ~
alpha:0.5;
5522 GlFunc.blend_func ~
src:`src_alpha ~dst
:`one_minus_src_alpha
;
5524 (fun (pageno, c, (x0, y0, x1, y1, x2
, y2
, x3
, y3
)) ->
5526 if l.pageno = pageno
5528 let dx = float (l.pagedispx - l.pagex
) in
5529 let dy = float (l.pagedispy - l.pagey) in
5530 GlDraw.color (0.0, 0.0, 1.0 /. float c) ~
alpha:0.5;
5531 Raw.sets_float state
.vraw ~
pos:0
5536 GlArray.vertex `two state
.vraw
;
5537 GlArray.draw_arrays `triangle_strip ~
first:0 ~count
:4;
5546 GlClear.color (scalecolor2 conf
.bgcolor
);
5547 GlClear.clear
[`
color];
5548 List.iter
drawpage state
.layout;
5550 match state
.mode with
5551 | LinkNav
(Ltexact
(pageno, linkno
)) ->
5552 begin match getopaque pageno with
5554 let dx = xadjsb () in
5555 let x0, y0, x1, y1 = getlinkrect
opaque linkno
in
5556 let x0 = x0 + dx and x1 = x1 + dx in
5563 | None
-> state
.rects
5565 | LinkNav
(Ltgendir
_)
5568 | View
-> state
.rects
5571 let rec postloop linkindexbase
= function
5573 let linkindexbase = linkindexbase + postdrawpage l linkindexbase in
5574 postloop linkindexbase rest
5578 postloop 0 state
.layout;
5580 begin match state
.mstate
with
5581 | Mzoomrect
((x0, y0), (x1, y1)) ->
5583 GlDraw.color (0.3, 0.3, 0.3) ~
alpha:0.5;
5584 GlFunc.blend_func ~
src:`src_alpha ~dst
:`one_minus_src_alpha
;
5585 filledrect (float x0) (float y0) (float x1) (float y1);
5589 | Mscrolly
| Mscrollx
5598 let zoomrect x y x1 y1 =
5601 and y0 = min
y y1 in
5602 gotoy (state
.y + y0);
5603 state
.anchor <- getanchor
();
5604 let zoom = (float state
.w) /. float (x1 - x0) in
5607 let adjw = wadjsb () + state
.winw
in
5609 then (adjw - state
.w) / 2
5612 match conf
.fitmodel
with
5613 | FitWidth
| FitProportional
-> simple ()
5615 match conf
.columns
with
5617 onppundermouse (fun _ l _ _ -> Some
l.pagedispx) x0 y0 x0
5618 | Cmulti
_ | Csingle
_ -> simple ()
5620 state
.x <- (state
.x + margin) - x0;
5626 let g opaque l px py =
5627 match rectofblock
opaque px py with
5629 let x0 = a.(0) -. 20. in
5630 let x1 = a.(1) +. 20. in
5631 let y0 = a.(2) -. 20. in
5632 let zoom = (float state
.w) /. (x1 -. x0) in
5633 let pagey = getpagey
l.pageno in
5634 gotoy_and_clear_text (pagey + truncate
y0);
5635 state
.anchor <- getanchor
();
5636 let margin = (state
.w - l.pagew
)/2 in
5637 state
.x <- -truncate
x0 - margin;
5642 match conf
.columns
with
5644 showtext '
!'
"block zooming does not work properly in split columns mode"
5645 | Cmulti
_ | Csingle
_ -> onppundermouse g x y ()
5649 let winw = wadjsb () + state
.winw - 1 in
5650 let s = float x /. float winw in
5651 let destx = truncate
(float (state
.w + winw) *. s) in
5652 state
.x <- winw - destx;
5653 gotoy_and_clear_text state
.y;
5654 state
.mstate
<- Mscrollx
;
5658 let s = float y /. float state
.winh
in
5659 let desty = truncate
(float (state
.maxy - state
.winh
) *. s) in
5660 gotoy_and_clear_text desty;
5661 state
.mstate
<- Mscrolly
;
5664 let viewmulticlick clicks
x y mask
=
5665 let g opaque l px py =
5673 if markunder
opaque px py mark
5677 match getopaque l.pageno with
5679 | Some
opaque -> pipesel opaque cmd
5681 state
.roam
<- (fun () -> dopipe conf
.paxcmd
);
5682 if not
(Wsi.withctrl mask
) then dopipe conf
.selcmd
;
5687 G.postRedisplay "viewmulticlick";
5688 onppundermouse g x y (fun () -> showtext '
!'
"Nothing to select") ();
5692 match conf
.columns
with
5694 | Csingle
_ | Cmulti
_ -> conf
.angle
mod 360 = 0
5697 let viewmouse button down
x y mask
=
5699 | n when (n == 4 || n == 5) && not down
->
5700 if Wsi.withctrl mask
5702 match state
.mstate
with
5703 | Mzoom
(oldn
, i
) ->
5711 if conf
.zoom +. 0.01 > 0.1 then 0.1 else 0.01
5713 if conf
.zoom -. 0.1 < 0.1 then -0.01 else -0.1
5715 let zoom = conf
.zoom -. incr in
5717 state
.mstate
<- Mzoom
(n, 0);
5719 state
.mstate
<- Mzoom
(n, i
+1);
5721 else state
.mstate
<- Mzoom
(n, 0)
5725 | Mscrolly
| Mscrollx
5727 | Mnone
-> state
.mstate
<- Mzoom
(n, 0)
5730 match state
.autoscroll
with
5731 | Some step
-> setautoscrollspeed step
(n=4)
5733 if conf
.wheelbypage
|| conf
.presentation
5742 then -conf
.scrollstep
5743 else conf
.scrollstep
5745 let incr = incr * 2 in
5746 let y = clamp incr in
5747 gotoy_and_clear_text y
5750 | n when (n = 6 || n = 7) && not down
&& canpan () ->
5752 panbound (state
.x + (if n = 7 then -2 else 2) * conf
.hscrollstep
);
5753 gotoy_and_clear_text state
.y
5755 | 1 when Wsi.withshift mask
->
5756 state
.mstate
<- Mnone
;
5759 match unproject x y with
5760 | Some
(pageno, ux
, uy
) ->
5761 let cmd = Printf.sprintf
5763 conf
.stcmd state
.path pageno ux uy
5769 | 1 when Wsi.withctrl mask
->
5772 Wsi.setcursor
Wsi.CURSOR_CROSSHAIR
;
5773 state
.mstate
<- Mpan
(x, y)
5776 state
.mstate
<- Mnone
5781 Wsi.setcursor
Wsi.CURSOR_CYCLE
;
5783 state
.mstate
<- Mzoomrect
(p, p)
5786 match state
.mstate
with
5787 | Mzoomrect
((x0, y0), _) ->
5788 if abs
(x-x0) > 10 && abs
(y - y0) > 10
5789 then zoomrect x0 y0 x y
5792 G.postRedisplay "kill accidental zoom rect";
5796 | Mscrolly
| Mscrollx
5802 | 1 when x > state
.winw - vscrollw () ->
5805 let _, position, sh = state
.uioh#
scrollph in
5806 if y > truncate
position && y < truncate
(position +. sh)
5807 then state
.mstate
<- Mscrolly
5810 state
.mstate
<- Mnone
5812 | 1 when y > state
.winh
- hscrollh () ->
5815 let _, position, sw = state
.uioh#scrollpw
in
5816 if x > truncate
position && x < truncate
(position +. sw)
5817 then state
.mstate
<- Mscrollx
5820 state
.mstate
<- Mnone
5822 | 1 when state
.bzoom
-> if not down
then zoomblock x y
5825 let dest = if down
then getunder x y else Unone
in
5826 begin match dest with
5829 | Uremote
_ | Uremotedest
_
5830 | Uunexpected
_ | Ulaunch
_ | Unamed
_ ->
5833 | Unone
when down
->
5834 Wsi.setcursor
Wsi.CURSOR_CROSSHAIR
;
5835 state
.mstate
<- Mpan
(x, y);
5837 | Uannotation contents
-> enterannotmode contents
5839 | Unone
| Utext
_ ->
5844 state
.mstate
<- Msel
((x, y), (x, y));
5845 G.postRedisplay "mouse select";
5849 match state
.mstate
with
5852 | Mzoom
_ | Mscrollx
| Mscrolly
->
5853 state
.mstate
<- Mnone
5855 | Mzoomrect
((x0, y0), _) ->
5859 Wsi.setcursor
Wsi.CURSOR_INHERIT
;
5860 state
.mstate
<- Mnone
5862 | Msel
((x0, y0), (x1, y1)) ->
5863 let rec loop = function
5867 let a0 = l.pagedispy in
5868 let a1 = a0 + l.pagevh in
5869 let b0 = l.pagedispx in
5870 let b1 = b0 + l.pagevw in
5871 ((y0 >= a0 && y0 <= a1) || (y1 >= a0 && y1 <= a1))
5872 && ((x0 >= b0 && x0 <= b1) || (x1 >= b0 && x1 <= b1))
5876 match getopaque l.pageno with
5879 match Unix.pipe
() with
5883 "can not create sel pipe: %s"
5887 Ne.clo fd
(fun msg
->
5888 dolog
"%s close failed: %s" what msg
)
5891 try popen
cmd [r, 0; w, -1]; true
5893 dolog
"can not execute %S: %s"
5900 G.postRedisplay "copysel";
5902 else clo "Msel pipe/w" w;
5903 clo "Msel pipe/r" r;
5905 dosel conf
.selcmd
();
5906 state
.roam
<- dosel conf
.paxcmd
;
5918 let birdseyemouse button down
x y mask
5919 (conf
, leftx
, _, hooverpageno
, anchor) =
5922 let rec loop = function
5925 if y > l.pagedispy && y < l.pagedispy + l.pagevh
5926 && x > l.pagedispx && x < l.pagedispx + l.pagevw
5928 leavebirdseye (conf
, leftx
, l.pageno, hooverpageno
, anchor) false;
5934 | _ -> viewmouse button down
x y mask
5940 method key key mask
=
5941 begin match state
.mode with
5942 | Textentry
textentry -> textentrykeyboard key mask
textentry
5943 | Birdseye
birdseye -> birdseyekeyboard key mask
birdseye
5944 | View
-> viewkeyboard key mask
5945 | LinkNav
linknav -> linknavkeyboard key mask
linknav
5949 method button button bstate
x y mask
=
5950 begin match state
.mode with
5952 | View
-> viewmouse button bstate
x y mask
5953 | Birdseye beye
-> birdseyemouse button bstate
x y mask beye
5958 method multiclick clicks
x y mask
=
5959 begin match state
.mode with
5961 | View
-> viewmulticlick clicks
x y mask
5968 begin match state
.mode with
5970 | View
| Birdseye
_ | LinkNav
_ ->
5971 match state
.mstate
with
5972 | Mzoom
_ | Mnone
-> ()
5977 state
.mstate
<- Mpan
(x, y);
5979 then state
.x <- panbound (state
.x + dx);
5981 gotoy_and_clear_text y
5984 state
.mstate
<- Msel
(a, (x, y));
5985 G.postRedisplay "motion select";
5988 let y = min state
.winh
(max
0 y) in
5992 let x = min state
.winw (max
0 x) in
5995 | Mzoomrect
(p0
, _) ->
5996 state
.mstate
<- Mzoomrect
(p0
, (x, y));
5997 G.postRedisplay "motion zoomrect";
6001 method pmotion
x y =
6002 begin match state
.mode with
6003 | Birdseye
(conf
, leftx
, pageno, hooverpageno
, anchor) ->
6004 let rec loop = function
6006 if hooverpageno
!= -1
6008 state
.mode <- Birdseye
(conf
, leftx
, pageno, -1, anchor);
6009 G.postRedisplay "pmotion birdseye no hoover";
6012 if y > l.pagedispy && y < l.pagedispy + l.pagevh
6013 && x > l.pagedispx && x < l.pagedispx + l.pagevw
6015 state
.mode <- Birdseye
(conf
, leftx
, pageno, l.pageno, anchor);
6016 G.postRedisplay "pmotion birdseye hoover";
6026 match state
.mstate
with
6027 | Mpan
_ | Msel
_ | Mzoom
_ | Mscrolly
| Mscrollx
| Mzoomrect
_ ->
6036 let past, _, _ = !r in
6038 let delta = now -. past in
6041 else r := (now, x, y)
6045 method infochanged
_ = ()
6048 let maxy = state
.maxy - (if conf
.maxhfit
then state
.winh
else 0) in
6051 then 0.0, float state
.winh
6052 else scrollph state
.y maxy
6057 let winw = wadjsb () + state
.winw in
6058 let fwinw = float winw in
6060 let sw = fwinw /. float state
.w in
6061 let sw = fwinw *. sw in
6062 max
sw (float conf
.scrollh
)
6065 let maxx = state
.w + winw in
6066 let x = winw - state
.x in
6067 let percent = float x /. float maxx in
6068 (fwinw -. sw) *. percent
6070 hscrollh (), position, sw
6074 match state
.mode with
6075 | LinkNav
_ -> "links"
6076 | Textentry
_ -> "textentry"
6077 | Birdseye
_ -> "birdseye"
6080 findkeyhash conf
modename
6082 method eformsgs
= true
6083 method alwaysscrolly
= false
6086 let adderrmsg src msg
=
6087 Buffer.add_string state
.errmsgs msg
;
6088 state
.newerrmsgs
<- true;
6092 let adderrfmt src fmt
=
6093 Format.ksprintf
(fun s -> adderrmsg src s) fmt
;
6097 let cl = splitatspace cmds
in
6099 try Scanf.sscanf
s fmt
f
6101 adderrfmt "remote exec"
6102 "error processing '%S': %s\n" cmds
(exntos exn
)
6105 | "reload" :: [] -> reload ()
6106 | "goto" :: args
:: [] ->
6107 scan args
"%u %f %f"
6109 let cmd, _ = state
.geomcmds
in
6111 then gotopagexy pageno x y
6114 gotopagexy pageno x y;
6117 state
.reprf
<- f state
.reprf
6119 | "goto1" :: args
:: [] -> scan args
"%u %f" gotopage
6120 | "gotor" :: args
:: [] ->
6122 (fun filename
pageno -> gotounder (Uremote
(filename
, pageno)))
6123 | "gotord" :: args
:: [] ->
6125 (fun filename
dest -> gotounder (Uremotedest
(filename
, dest)))
6126 | "rect" :: args
:: [] ->
6127 scan args
"%u %u %f %f %f %f"
6128 (fun pageno color x0 y0 x1 y1 ->
6129 onpagerect pageno (fun w h ->
6130 let _,w1,h1
,_ = getpagedim
pageno in
6131 let sw = float w1 /. float w
6132 and sh = float h1
/. float h in
6136 and y1s
= y1 *. sh in
6137 let rect = (x0s,y0s
,x1s
,y0s
,x1s
,y1s
,x0s,y1s
) in
6139 state
.rects <- (pageno, color, rect) :: state
.rects;
6140 G.postRedisplay "rect";
6143 | "activatewin" :: [] -> Wsi.activatewin
()
6144 | "quit" :: [] -> raise Quit
6146 adderrfmt "remote command"
6147 "error processing remote command: %S\n" cmds
;
6151 let scratch = Bytes.create
80 in
6152 let buf = Buffer.create
80 in
6155 try Some
(Unix.read fd
scratch 0 80)
6157 | Unix.Unix_error
(Unix.EAGAIN
, _, _) -> None
6158 | Unix.Unix_error
(Unix.EINTR
, _, _) -> tempfr ()
6161 match tempfr () with
6167 if Buffer.length
buf > 0
6169 let s = Buffer.contents
buf in
6179 let pos = Bytes.index_from
scratch ppos '
\n'
in
6180 if pos >= n then -1 else pos
6181 with Not_found
-> -1
6185 Buffer.add_subbytes
buf scratch ppos
(nlpos-ppos
);
6186 let s = Buffer.contents
buf in
6192 Buffer.add_subbytes
buf scratch ppos
(n-ppos
);
6198 let remoteopen path =
6199 try Some
(Unix.openfile
path [Unix.O_NONBLOCK
; Unix.O_RDONLY
] 0o0)
6201 adderrfmt "remoteopen" "error opening %S: %s" path (exntos exn
);
6206 let gcconfig = ref E.s in
6207 let trimcachepath = ref E.s in
6208 let rcmdpath = ref E.s in
6209 let pageno = ref None
in
6210 let rootwid = ref 0 in
6211 let openlast = ref false in
6212 let nofc = ref false in
6213 selfexec := Sys.executable_name
;
6216 [("-p", Arg.String
(fun s -> state
.password
<- s),
6217 "<password> Set password");
6221 Config.fontpath
:= s;
6222 selfexec := !selfexec ^
" -f " ^
Filename.quote
s;
6224 "<path> Set path to the user interface font");
6228 selfexec := !selfexec ^
" -c " ^
Filename.quote
s;
6229 Config.confpath
:= s),
6230 "<path> Set path to the configuration file");
6232 ("-last", Arg.Set
openlast, " Open last document");
6234 ("-page", Arg.Int
(fun pageno1
-> pageno := Some
(pageno1
-1)),
6235 "<page-number> Jump to page");
6237 ("-tcf", Arg.String
(fun s -> trimcachepath := s),
6238 "<path> Set path to the trim cache file");
6240 ("-dest", Arg.String
(fun s -> state
.nameddest
<- s),
6241 "<named-destination> Set named destination");
6243 ("-wtmode", Arg.Set
wtmode, " Operate in wt mode");
6244 ("-cxack", Arg.Set
cxack, " Cut corners");
6246 ("-remote", Arg.String
(fun s -> rcmdpath := s),
6247 "<path> Set path to the remote commands source");
6249 ("-origin", Arg.String
(fun s -> state
.origin
<- s),
6250 "<original-path> Set original path");
6252 ("-gc", Arg.Set_string
gcconfig,
6253 "<script-path> Collect garbage with the help of a script");
6255 ("-nofc", Arg.Set
nofc, " Do not use fontconfig");
6257 ("-v", Arg.Unit
(fun () ->
6259 "%s\nconfiguration path: %s\n"
6263 exit
0), " Print version and exit");
6265 ("-embed", Arg.Set_int
rootwid,
6266 "<window-id> Embed into window")
6269 (fun s -> state
.path <- s)
6270 ("Usage: " ^
Sys.argv
.(0) ^
" [options] some.pdf\nOptions:")
6273 then selfexec := !selfexec ^
" -wtmode";
6275 let histmode = emptystr state
.path && not
!openlast in
6277 if not
(Config.load !openlast)
6278 then prerr_endline
"failed to load configuration";
6279 begin match !pageno with
6280 | Some
pageno -> state
.anchor <- (pageno, 0.0, 0.0)
6284 if not
(emptystr
!gcconfig)
6287 match Unix.socketpair
Unix.PF_UNIX
Unix.SOCK_STREAM
0 with
6289 error
"gc socketpair failed: %s" (exntos exn
)
6292 match popen
!gcconfig [(c, 0); (c, 1)] with
6297 error
"failed to popen gc script: %s" (exntos exn
);
6300 let wsfd, winw, winh
= Wsi.init
(object (self)
6301 val mutable m_clicks
= 0
6302 val mutable m_click_x
= 0
6303 val mutable m_click_y
= 0
6304 val mutable m_lastclicktime
= infinity
6306 method private cleanup
=
6307 state
.roam
<- noroam
;
6308 Hashtbl.iter
(fun _ opaque -> clearmark
opaque) state
.pagemap
6309 method expose
= G.postRedisplay"expose"
6313 | Wsi.Unobscured
-> "unobscured"
6314 | Wsi.PartiallyObscured
-> "partiallyobscured"
6315 | Wsi.FullyObscured
-> "fullyobscured"
6317 vlog "visibility change %s" name
6318 method display = display ()
6319 method map mapped
= vlog "mappped %b" mapped
6320 method reshape w h =
6323 method mouse
b d x y m =
6324 if d && canselect ()
6326 (* http://blogs.msdn.com/b/oldnewthing/archive/2004/10/18/243925.aspx *)
6332 if abs
x - m_click_x
> 10
6333 || abs
y - m_click_y
> 10
6334 || abs_float
(t -. m_lastclicktime
) > 0.3
6336 m_clicks
<- m_clicks
+ 1;
6337 m_lastclicktime
<- t;
6341 G.postRedisplay "cleanup";
6342 state
.uioh <- state
.uioh#button
b d x y m;
6344 else state
.uioh <- state
.uioh#multiclick m_clicks
x y m
6349 m_lastclicktime
<- infinity
;
6350 state
.uioh <- state
.uioh#button
b d x y m
6354 state
.uioh <- state
.uioh#button
b d x y m
6357 state
.mpos
<- (x, y);
6358 state
.uioh <- state
.uioh#motion
x y
6359 method pmotion
x y =
6360 state
.mpos
<- (x, y);
6361 state
.uioh <- state
.uioh#pmotion
x y
6363 let mascm = m land (
6364 Wsi.altmask
+ Wsi.shiftmask
+ Wsi.ctrlmask
+ Wsi.metamask
6367 let x = state
.x and y = state
.y in
6369 if x != state
.x || y != state
.y then self#cleanup
6371 match state
.keystate
with
6373 let km = k
, mascm in
6376 let modehash = state
.uioh#
modehash in
6377 try Hashtbl.find modehash km
6379 try Hashtbl.find (findkeyhash conf
"global") km
6380 with Not_found
-> KMinsrt
(k
, m)
6382 | KMinsrt
(k
, m) -> keyboard k
m
6383 | KMinsrl
l -> List.iter
(fun (k
, m) -> keyboard k
m) l
6384 | KMmulti
(l, r) -> state
.keystate
<- KSinto
(l, r)
6386 | KSinto
((k'
, m'
) :: [], insrt
) when k'
=k
&& m'
land mascm = m'
->
6387 List.iter
(fun (k
, m) -> keyboard k
m) insrt
;
6388 state
.keystate
<- KSnone
6389 | KSinto
((k'
, m'
) :: keys
, insrt
) when k'
=k
&& m'
land mascm = m'
->
6390 state
.keystate
<- KSinto
(keys
, insrt
)
6391 | KSinto
_ -> state
.keystate
<- KSnone
6394 state
.mpos
<- (x, y);
6395 state
.uioh <- state
.uioh#pmotion
x y
6396 method leave = state
.mpos
<- (-1, -1)
6397 method winstate wsl
= state
.winstate
<- wsl
6398 method quit
= raise Quit
6399 end) !rootwid conf
.cwinw conf
.cwinh platform
in
6404 List.exists
GlMisc.check_extension
6405 [ "GL_ARB_texture_rectangle"
6406 ; "GL_EXT_texture_recangle"
6407 ; "GL_NV_texture_rectangle" ]
6409 then (prerr_endline
"OpenGL does not suppport rectangular textures"; exit
1);
6412 let r = GlMisc.get_string `renderer
in
6413 let p = "Mesa DRI Intel(" in
6414 let l = String.length
p in
6415 String.length
r > l && String.sub
r 0 l = p
6418 defconf
.sliceheight
<- 1024;
6419 defconf
.texcount
<- 32;
6420 defconf
.usepbo
<- true;
6424 match Unix.socketpair
Unix.PF_UNIX
Unix.SOCK_STREAM
0 with
6426 Printf.eprintf
"socketpair failed: %s" (exntos exn
);
6434 setcheckers conf
.checkers
;
6436 if conf
.redirectstderr
6440 (Buffer.to_bytes state
.errmsgs
)
6441 (match state
.errfd
with
6443 let s = Bytes.create
(80*24) in
6446 let r, _, _ = Unix.select
[fd
] [] [] 0.0 in
6448 then Unix.read fd
s 0 (Bytes.length
s)
6454 else Bytes.sub
s 0 n
6458 try ignore
(Unix.write state
.stderr
s 0 (Bytes.length
s))
6459 with exn
-> print_endline
(exntos exn
)
6464 conf
.angle
, conf
.fitmodel
, (conf
.trimmargins
, conf
.trimfuzz
),
6465 conf
.texcount
, conf
.sliceheight
, conf
.mustoresize
, conf
.colorspace
,
6466 !Config.fontpath
, !trimcachepath,
6467 GlMisc.check_extension
"GL_ARB_pixel_buffer_object",
6470 List.iter
GlArray.enable
[`texture_coord
; `vertex
];
6476 Wsi.settitle
"llpp (history)";
6480 state
.text <- "Opening " ^
(mbtoutf8 state
.path);
6481 opendoc state
.path state
.password
;
6486 Sys.set_signal
Sys.sighup
(Sys.Signal_handle
(fun _ -> reload ()));
6489 if nonemptystr
!rcmdpath
6490 then remoteopen !rcmdpath
6495 let rec loop deadline
=
6497 match state
.errfd
with
6498 | None
-> [state
.ss; state
.wsfd]
6499 | Some fd
-> [state
.ss; state
.wsfd; fd
]
6504 | Some fd
-> fd
:: r
6508 state
.redisplay
<- false;
6515 if deadline
= infinity
6517 else max
0.0 (deadline
-. now)
6522 try Unix.select
r [] [] timeout
6523 with Unix.Unix_error
(Unix.EINTR
, _, _) -> [], [], []
6529 if state
.ghyll
== noghyll
6531 match state
.autoscroll
with
6532 | Some step
when step
!= 0 ->
6533 let y = state
.y + step
in
6537 else if y >= state
.maxy then 0 else y
6540 if state
.mode = View
6541 then state
.text <- E.s;
6544 else deadline
+. 0.01
6549 let rec checkfds = function
6551 | fd
:: rest
when fd
= state
.ss ->
6552 let cmd = readcmd state
.ss in
6556 | fd
:: rest
when fd
= state
.wsfd ->
6560 | fd
:: rest
when Some fd
= !optrfd ->
6561 begin match remote fd
with
6562 | None
-> optrfd := remoteopen !rcmdpath;
6563 | opt -> optrfd := opt
6568 let s = Bytes.create
80 in
6569 let n = tempfailureretry
(Unix.read fd
s 0) 80 in
6570 if conf
.redirectstderr
6572 Buffer.add_substring state
.errmsgs
(Bytes.to_string
s) 0 n;
6573 state
.newerrmsgs
<- true;
6574 state
.redisplay
<- true;
6577 prerr_string
(String.sub
(Bytes.to_string
s) 0 n);
6583 if !reeenterhist then (
6585 reeenterhist := false;
6589 if deadline
= infinity
6593 match state
.autoscroll
with
6594 | Some step
when step
!= 0 -> deadline1
6595 | _ -> if state
.ghyll
== noghyll
then infinity
else deadline1
6603 Config.save
leavebirdseye;