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 getmaxw
: unit -> float = "ml_getmaxw";;
16 external drawstr
: int -> int -> int -> string -> float = "ml_draw_string";;
17 external measurestr
: int -> string -> float = "ml_measure_string";;
18 external postprocess
:
19 opaque
-> int -> int -> int -> (int * string * int) -> int
21 external pagebbox
: opaque
-> (int * int * int * int) = "ml_getpagebox";;
22 external setaalevel
: int -> unit = "ml_setaalevel";;
23 external realloctexts
: int -> bool = "ml_realloctexts";;
24 external findlink
: opaque
-> linkdir
-> link
= "ml_findlink";;
25 external getlink
: opaque
-> int -> under
= "ml_getlink";;
26 external getlinkrect
: opaque
-> int -> irect
= "ml_getlinkrect";;
27 external getlinkcount
: opaque
-> int = "ml_getlinkcount";;
28 external findpwl
: int -> int -> pagewithlinks
= "ml_find_page_with_links";;
29 external getpbo
: width
-> height
-> colorspace
-> opaque
= "ml_getpbo";;
30 external freepbo
: opaque
-> unit = "ml_freepbo";;
31 external unmappbo
: opaque
-> unit = "ml_unmappbo";;
32 external bousable
: unit -> bool = "ml_bo_usable";;
33 external unproject
: opaque
-> int -> int -> (int * int) option
35 external project
: opaque
-> int -> int -> float -> float -> (float * float)
37 external drawtile
: tileparams
-> opaque
-> unit = "ml_drawtile";;
38 external rectofblock
: opaque
-> int -> int -> float array
option
40 external begintiles
: unit -> unit = "ml_begintiles";;
41 external endtiles
: unit -> unit = "ml_endtiles";;
42 external addannot
: opaque
-> int -> int -> string -> unit = "ml_addannot";;
43 external modannot
: opaque
-> slinkindex
-> string -> unit = "ml_modannot";;
44 external delannot
: opaque
-> slinkindex
-> unit = "ml_delannot";;
45 external hasunsavedchanges
: unit -> bool = "ml_hasunsavedchanges";;
46 external savedoc
: string -> unit = "ml_savedoc";;
47 external getannotcontents
: opaque
-> slinkindex
-> string
48 = "ml_getannotcontents";;
49 external drawprect
: opaque
-> int -> int -> float array
-> unit =
51 external wcmd
: Unix.file_descr
-> bytes
-> int -> unit = "ml_wcmd";;
52 external rcmd
: Unix.file_descr
-> string = "ml_rcmd";;
54 let selfexec = ref E.s
;;
55 let opengl_has_pbo = ref false;;
57 let drawstring size x y s
=
59 Gl.enable `texture_2d
;
60 GlFunc.blend_func ~src
:`src_alpha ~dst
:`one_minus_src_alpha
;
61 ignore
(drawstr size x y s
);
63 Gl.disable `texture_2d
;
66 let drawstring1 size x y s
=
70 let drawstring2 size x y fmt
=
71 Printf.kprintf
(drawstring size
(x
+1) (y
+size
+1)) fmt
75 dolog
"l %d dim=%d {" l
.pageno l
.pagedimno
;
76 dolog
" WxH %dx%d" l
.pagew l
.pageh
;
77 dolog
" vWxH %dx%d" l
.pagevw l
.pagevh
;
78 dolog
" pagex,y %d,%d" l
.pagex l
.pagey
;
79 dolog
" dispx,y %d,%d" l
.pagedispx l
.pagedispy
;
80 dolog
" column %d" l
.pagecol
;
84 let debugrect (x0
, y0
, x1
, y1
, x2
, y2
, x3
, y3
) =
86 dolog
" x0,y0=(% f, % f)" x0 y0
;
87 dolog
" x1,y1=(% f, % f)" x1 y1
;
88 dolog
" x2,y2=(% f, % f)" x2 y2
;
89 dolog
" x3,y3=(% f, % f)" x3 y3
;
93 let isbirdseye = function
100 let istextentry = function
101 | Textentry _
-> true
107 let wtmode = ref false;;
108 let cxack = ref false;;
110 let pgscale h
= truncate
(float h
*. conf
.pgscale);;
113 if not state
.uioh#alwaysscrolly
&& (conf
.scrollb
land scrollbhv
= 0)
114 || (state
.x
= 0 && state
.w
<= state
.winw
- conf
.scrollbw
)
120 if not state
.uioh#alwaysscrolly
&& (conf
.scrollb
land scrollbvv
= 0)
128 else x
> state
.winw
- vscrollw ()
131 let wadjsb () = -vscrollw ();;
132 let xadjsb () = if conf
.leftscroll
then vscrollw () else 0;;
135 fstate
.fontsize
<- n
;
136 fstate
.wwidth
<- measurestr fstate
.fontsize
"w";
137 fstate
.maxrows
<- (state
.winh
- fstate
.fontsize
- 1) / (fstate
.fontsize
+ 1);
143 else Printf.kprintf ignore fmt
147 if emptystr conf
.pathlauncher
148 then dolog
"%s" state
.path
150 let command = Str.global_replace percentsre state
.path conf
.pathlauncher
in
151 match spawn
command [] with
154 dolog
"failed to execute `%s': %s" command @@ exntos exn
160 let postRedisplay who
=
161 vlog "redisplay for [%S]" who
;
162 state
.redisplay
<- true;
166 let getopaque pageno
=
167 try Some
(Hashtbl.find state
.pagemap
(pageno
, state
.gen
))
168 with Not_found
-> None
171 let pagetranslatepoint l x y
=
172 let dy = y
- l
.pagedispy
in
173 let y = dy + l
.pagey
in
174 let dx = x
- l
.pagedispx
in
175 let x = dx + l
.pagex
in
179 let onppundermouse g
x y d
=
182 begin match getopaque l
.pageno
with
184 let x0 = l
.pagedispx
in
185 let x1 = x0 + l
.pagevw
in
186 let y0 = l
.pagedispy
in
187 let y1 = y0 + l
.pagevh
in
188 if y >= y0 && y <= y1 && x >= x0 && x <= x1
190 let px, py
= pagetranslatepoint l
x y in
191 match g opaque l
px py
with
204 let g opaque l
px py
=
207 match rectofblock opaque
px py
with
208 | Some
[|x0;x1;y0;y1|] ->
209 let ox = xadjsb () |> float in
210 let rect = (x0+.ox, y0, x1+.ox, y0, x1+.ox, y1, x0+.ox, y1) in
211 let color = (0.0, 0.0, 1.0 /. (l
.pageno
mod 3 |> float), 0.5) in
212 state
.rects
<- [l
.pageno
, color, rect];
213 G.postRedisplay "getunder";
216 let under = whatsunder opaque
px py
in
217 if under = Unone
then None
else Some
under
219 onppundermouse g x y Unone
224 match unproject opaque
x y with
225 | Some
(x, y) -> Some
(Some
(opaque
, l
.pageno
, x, y))
228 onppundermouse g x y None
;
232 state
.text
<- Printf.sprintf
"%c%s" c s
;
233 G.postRedisplay "showtext";
237 Format.ksprintf
(fun s
-> showtext '
!' s
) fmt
;
240 let pipesel opaque cmd
=
243 match Unix.pipe
() with
244 | (exception exn
) -> dolog
"pipesel cannot create pipe: %S" @@ exntos exn
;
246 let doclose what fd
=
247 Ne.clo fd
(fun msg
-> dolog
"%s close failed: %s" what msg
)
250 try spawn cmd
[r
, 0; w
, -1]
252 dolog
"cannot execute %S: %s" cmd
@@ exntos exn
;
258 G.postRedisplay "pipesel";
260 else doclose "pipesel pipe/w" w
;
261 doclose "pipesel pipe/r" r
;
265 let g opaque l
px py
=
266 if markunder opaque
px py conf
.paxmark
269 match getopaque l
.pageno
with
271 | Some opaque
-> pipesel opaque conf
.paxcmd
276 G.postRedisplay "paxunder";
277 if conf
.paxmark
= Mark_page
280 match getopaque l
.pageno
with
282 | Some opaque
-> clearmark opaque
) state
.layout
;
283 state
.roam
<- onppundermouse g x y (fun () -> impmsg "whoopsie daisy");
287 match Unix.pipe
() with
288 | (exception exn
) -> impmsg "pipe failed: %s" @@ exntos exn
291 Ne.clo fd
(fun msg
-> impmsg "failed to close %s: %s" cap msg
)
294 try spawn conf
.selcmd
[r
, 0; w
, -1]
296 impmsg "failed to execute %s: %s" conf
.selcmd
@@ exntos exn
;
302 let l = String.length s
in
303 let bytes = Bytes.unsafe_of_string s
in
304 let n = tempfailureretry
(Unix.write w
bytes 0) l in
306 then impmsg "failed to write %d characters to sel pipe, wrote %d"
309 impmsg "failed to write to sel pipe: %s" @@ exntos exn
312 clo "selstring pipe/r" r
;
313 clo "selstring pipe/w" w
;
316 let undertext ?
(nopath
=false) = function
319 | Ulinkgoto
(pageno
, _
) ->
321 then "page " ^ string_of_int
(pageno
+1)
322 else Printf.sprintf
"%s: page %d" state
.path
(pageno
+1)
323 | Utext s
-> "font: " ^ s
324 | Uunexpected s
-> "unexpected: " ^ s
325 | Ulaunch s
-> "launch: " ^ s
326 | Unamed s
-> "named: " ^ s
327 | Uremote
(filename
, pageno
) ->
328 Printf.sprintf
"%s: page %d" filename
(pageno
+1)
329 | Uremotedest
(filename
, destname
) ->
330 Printf.sprintf
"%s: destination %S" filename destname
331 | Uannotation
(opaque
, slinkindex
) ->
332 "annotation: " ^ getannotcontents opaque slinkindex
335 let updateunder x y =
336 match getunder x y with
337 | Unone
-> Wsi.setcursor
Wsi.CURSOR_INHERIT
339 if conf
.underinfo
then showtext 'u'
("ri: " ^ uri
);
340 Wsi.setcursor
Wsi.CURSOR_INFO
341 | Ulinkgoto
(pageno
, _
) ->
343 then showtext 'p'
("age: " ^ string_of_int
(pageno
+1));
344 Wsi.setcursor
Wsi.CURSOR_INFO
346 if conf
.underinfo
then showtext '
f'
("ont: " ^ s
);
347 Wsi.setcursor
Wsi.CURSOR_TEXT
349 if conf
.underinfo
then showtext 'u'
("nexpected: " ^ s
);
350 Wsi.setcursor
Wsi.CURSOR_INHERIT
352 if conf
.underinfo
then showtext '
l'
("aunch: " ^ s
);
353 Wsi.setcursor
Wsi.CURSOR_INHERIT
355 if conf
.underinfo
then showtext '
n'
("amed: " ^ s
);
356 Wsi.setcursor
Wsi.CURSOR_INHERIT
357 | Uremote
(filename
, pageno
) ->
358 if conf
.underinfo
then showtext 'r'
359 (Printf.sprintf
"emote: %s (%d)" filename
(pageno
+1));
360 Wsi.setcursor
Wsi.CURSOR_INFO
361 | Uremotedest
(filename
, destname
) ->
362 if conf
.underinfo
then showtext 'r'
363 (Printf.sprintf
"emote destination: %s (%S)" filename destname
);
364 Wsi.setcursor
Wsi.CURSOR_INFO
366 if conf
.underinfo
then showtext 'a'
"nnotation";
367 Wsi.setcursor
Wsi.CURSOR_INFO
370 let showlinktype under =
371 if conf
.underinfo
&& under != Unone
372 then showtext ' '
@@ undertext under
375 let intentry_with_suffix text key
=
377 if key
>= 32 && key
< 127
379 let c = Char.chr key
in
384 | 'k'
| 'm'
| '
g'
| 'K'
| 'M'
| 'G'
->
385 addchar
text @@ asciilower
c
387 state
.text <- Printf.sprintf
"invalid key (%d, `%c')" key
c;
390 state
.text <- Printf.sprintf
"invalid key %d" key
;
398 let b = Buffer.create
16 in
399 Buffer.add_string
b "llll";
402 let b = Buffer.to_bytes
b in
403 wcmd state
.ss
b @@ Bytes.length
b
407 let nogeomcmds cmds
=
409 | s
, [] -> emptystr s
413 let layoutN ((columns
, coverA
, coverB
), b) x y sw sh
=
414 let sh = sh - (hscrollh ()) in
415 let wadj = wadjsb () in
416 let rec fold accu
n =
417 if n = Array.length
b
420 let pdimno, dx, vy
, (_
, w
, h
, xoff
) = b.(n) in
423 || n = state
.pagecount
- coverB
424 || (n - coverA
) mod columns
= columns
- 1)
430 let pagey = max
0 (y - vy
) in
431 let pagedispy = if pagey > 0 then 0 else vy
- y in
432 let pagedispx, pagex
=
434 if n = coverA
- 1 || n = state
.pagecount
- coverB
435 then x + (wadj + sw
- w
) / 2
443 let vw = wadj + sw
- pagedispx in
444 let pw = w
- pagex
in
447 let pagevh = min
(h
- pagey) (sh - pagedispy) in
448 if pagevw > 0 && pagevh > 0
459 ; pagedispx = pagedispx
460 ; pagedispy = pagedispy
472 if Array.length
b = 0
474 else List.rev
(fold [] (page_of_y
y))
477 let layoutS (columns
, b) x y sw
sh =
478 let sh = sh - hscrollh () in
479 let wadj = wadjsb () in
480 let rec fold accu n =
481 if n = Array.length
b
484 let pdimno, px, vy
, (_
, pagew
, pageh
, xoff
) = b.(n) in
492 let pagey = max
0 (y - vy
) in
493 let pagedispy = if pagey > 0 then 0 else vy
- y in
494 let pagedispx, pagex
=
508 let pagecolw = pagew
/columns
in
511 then pagedispx + ((wadj + sw
- pagecolw) / 2)
515 let vw = wadj + sw
- pagedispx in
516 let pw = pagew
- pagex
in
519 let pagevw = min
pagevw pagecolw in
520 let pagevh = min
(pageh
- pagey) (sh - pagedispy) in
521 if pagevw > 0 && pagevh > 0
532 ; pagedispx = pagedispx
533 ; pagedispy = pagedispy
534 ; pagecol
= n mod columns
548 let layout x y sw
sh =
549 if nogeomcmds state
.geomcmds
551 match conf
.columns
with
552 | Csingle
b -> layoutN ((1, 0, 0), b) x y sw
sh
553 | Cmulti
c -> layoutN c x y sw
sh
554 | Csplit s
-> layoutS s
x y sw
sh
559 let y = state
.y + incr
in
561 let y = min
y (state
.maxy
- (if conf
.maxhfit
then state
.winh
else 0)) in
566 let tilex = l.pagex
mod conf
.tilew
in
567 let tiley = l.pagey mod conf
.tileh
in
569 let col = l.pagex
/ conf
.tilew
in
570 let row = l.pagey / conf
.tileh
in
572 let xadj = xadjsb () in
573 let rec rowloop row y0 dispy h
=
577 let dh = conf
.tileh
- y0 in
579 let rec colloop col x0 dispx w
=
583 let dw = conf
.tilew
- x0 in
585 let dispx'
= xadj + dispx in
586 f col row dispx' dispy
x0 y0 dw dh;
587 colloop (col+1) 0 (dispx+dw) (w
-dw)
590 colloop col tilex l.pagedispx l.pagevw;
591 rowloop (row+1) 0 (dispy
+dh) (h
-dh)
594 if l.pagevw > 0 && l.pagevh > 0
595 then rowloop row tiley l.pagedispy l.pagevh;
598 let gettileopaque l col row =
600 l.pageno
, state
.gen
, conf
.colorspace
, conf
.angle
, l.pagew
, l.pageh
, col, row
602 try Some
(Hashtbl.find state
.tilemap
key)
603 with Not_found
-> None
606 let puttileopaque l col row gen colorspace angle opaque size elapsed
=
607 let key = l.pageno
, gen
, colorspace
, angle
, l.pagew
, l.pageh
, col, row in
608 Hashtbl.add state
.tilemap
key (opaque
, size
, elapsed
)
611 let filledrect2 x0 y0 x1 y1 x2 y2 x3 y3
=
612 Raw.sets_float state
.vraw ~pos
:0 [| x0; y0; x1; y1; x2
; y2
; x3
; y3
|];
613 GlArray.vertex `two state
.vraw
;
614 GlArray.draw_arrays `triangle_strip ~first
:0 ~count
:4;
617 let filledrect1 x0 y0 x1 y1 = filledrect2 x0 y0 x0 y1 x1 y0 x1 y1;;
619 let filledrect x0 y0 x1 y1 =
620 GlArray.disable `texture_coord
;
621 filledrect1 x0 y0 x1 y1;
622 GlArray.enable `texture_coord
;
625 let linerect x0 y0 x1 y1 =
626 GlArray.disable `texture_coord
;
627 Raw.sets_float state
.vraw ~pos
:0 [| x0; y0; x0; y1; x1; y1; x1; y0 |];
628 GlArray.vertex `two state
.vraw
;
629 GlArray.draw_arrays `line_loop ~first
:0 ~count
:4;
630 GlArray.enable `texture_coord
;
633 let drawtiles l color =
635 let wadj = wadjsb () in
637 let f col row x y tilex tiley w h
=
638 match gettileopaque l col row with
639 | Some
(opaque
, _
, t
) ->
640 let params = x, y, w
, h
, tilex, tiley in
642 then GlTex.env
(`mode `blend
);
643 drawtile
params opaque
;
645 then GlTex.env
(`mode `modulate
);
649 let s = Printf.sprintf
653 let w = measurestr fstate
.fontsize
s in
654 GlDraw.color (0.0, 0.0, 0.0);
655 filledrect (float (x-2))
658 (float (y + fstate
.fontsize
+ 2));
660 drawstring fstate
.fontsize
x (y + fstate
.fontsize
- 1) s;
670 let lw = wadj + state
.winw
- x in
673 let lh = state
.winh
- y in
677 then GlTex.env
(`mode `blend
);
678 begin match state
.checkerstexid
with
680 Gl.enable `texture_2d
;
681 GlTex.bind_texture ~target
:`texture_2d id
;
685 and y1 = float (y+h
) in
687 let tw = float w /. 16.0
688 and th
= float h
/. 16.0 in
689 let tx0 = float tilex /. 16.0
690 and ty0
= float tiley /. 16.0 in
692 and ty1
= ty0
+. th
in
693 Raw.sets_float state
.vraw ~pos
:0
694 [| x0; y0; x0; y1; x1; y0; x1; y1 |];
695 Raw.sets_float state
.traw ~pos
:0
696 [| tx0; ty0
; tx0; ty1
; tx1; ty0
; tx1; ty1
|];
697 GlArray.vertex `two state
.vraw
;
698 GlArray.tex_coord `two state
.traw
;
699 GlArray.draw_arrays `triangle_strip ~first
:0 ~count
:4;
700 Gl.disable `texture_2d
;
703 GlDraw.color (1.0, 1.0, 1.0);
704 filledrect (float x) (float y) (float (x+w)) (float (y+h
));
707 then GlTex.env
(`mode `modulate
);
708 if w > 128 && h
> fstate
.fontsize
+ 10
710 let c = if conf
.invert
then 1.0 else 0.0 in
711 GlDraw.color (c, c, c);
714 then (col*conf
.tilew
, row*conf
.tileh
)
717 drawstring2 fstate
.fontsize
x y "Loading %d [%d,%d]" l.pageno
c r
;
726 let pagevisible layout n = List.exists
(fun l -> l.pageno
= n) layout;;
728 let tilevisible1 l x y =
730 and ax1
= l.pagex
+ l.pagevw
732 and ay1
= l.pagey + l.pagevh in
736 let bx1 = min
(bx0 + conf
.tilew
) l.pagew
737 and by1
= min
(by0
+ conf
.tileh
) l.pageh
in
739 let rx0 = max
ax0 bx0
740 and ry0
= max ay0 by0
741 and rx1
= min ax1
bx1
742 and ry1
= min ay1 by1
in
744 let nonemptyintersection = rx1
> rx0 && ry1
> ry0
in
748 let tilevisible layout n x y =
749 let rec findpageinlayout m
= function
750 | l :: rest
when l.pageno
= n ->
751 tilevisible1 l x y || (
752 match conf
.columns
with
753 | Csplit
(c, _
) when c > m
-> findpageinlayout (m
+1) rest
758 | _
:: rest
-> findpageinlayout 0 rest
761 findpageinlayout 0 layout;
764 let tileready l x y =
765 tilevisible1 l x y &&
766 gettileopaque l (x/conf
.tilew
) (y/conf
.tileh
) != None
769 let tilepage n p
layout =
770 let rec loop = function
774 let f col row _ _ _ _ _ _
=
775 if state
.currently
= Idle
777 match gettileopaque l col row with
780 let x = col*conf
.tilew
781 and y = row*conf
.tileh
in
783 let w = l.pagew
- x in
787 let h = l.pageh
- y in
792 then getpbo
w h conf
.colorspace
795 wcmd "tile %s %d %d %d %d %s"
796 (~
> p
) x y w h (~
> pbo);
799 l, p
, conf
.colorspace
, conf
.angle
,
800 state
.gen
, col, row, conf
.tilew
, conf
.tileh
809 if nogeomcmds state
.geomcmds
813 let preloadlayout x y sw
sh =
814 let y = if y < sh then 0 else y - sh in
815 let x = min
0 (x + sw
) in
823 if state
.currently
!= Idle
828 begin match getopaque l.pageno
with
830 wcmd "page %d %d" l.pageno
l.pagedimno
;
831 state
.currently
<- Loading
(l, state
.gen
);
833 tilepage l.pageno opaque pages
;
838 if nogeomcmds state
.geomcmds
844 if conf
.preload && state
.currently
= Idle
845 then load (preloadlayout state
.x state
.y state
.winw state
.winh
);
848 let layoutready layout =
849 let rec fold all ls
=
852 let seen = ref false in
853 let allvisible = ref true in
854 let foo col row _ _ _ _ _ _
=
856 allvisible := !allvisible &&
857 begin match gettileopaque l col row with
863 fold (!seen && !allvisible) rest
866 let alltilesvisible = fold true layout in
871 let y = bound
y 0 state
.maxy
in
872 let y, layout, proceed
=
873 match conf
.maxwait
with
874 | Some time
when state
.ghyll
== noghyll
->
875 begin match state
.throttle
with
877 let layout = layout state
.x y state
.winw state
.winh
in
878 let ready = layoutready layout in
882 state
.throttle
<- Some
(layout, y, now
());
884 else G.postRedisplay "gotoy showall (None)";
886 | Some
(_
, _
, started
) ->
887 let dt = now
() -. started
in
890 state
.throttle
<- None
;
891 let layout = layout state
.x y state
.winw state
.winh
in
893 G.postRedisplay "maxwait";
900 let layout = layout state
.x y state
.winw state
.winh
in
901 if not
!wtmode || layoutready layout
902 then G.postRedisplay "gotoy ready";
908 state
.layout <- layout;
909 begin match state
.mode
with
912 | Ltexact
(pageno
, linkno
) ->
913 let rec loop = function
915 state
.mode
<- LinkNav
(Ltgendir
0)
916 | l :: _
when l.pageno
= pageno
->
917 begin match getopaque pageno
with
918 | None
-> state
.mode
<- LinkNav
(Ltnotready
(pageno
, 0))
920 let x0, y0, x1, y1 = getlinkrect opaque linkno
in
921 if not
(x0 >= l.pagex
&& x1 <= l.pagex
+ l.pagevw
922 && y0 >= l.pagey && y1 <= l.pagey + l.pagevh)
923 then state
.mode
<- LinkNav
(Ltgendir
0)
925 | _
:: rest
-> loop rest
928 | Ltnotready _
| Ltgendir _
-> ()
934 begin match state
.mode
with
935 | Birdseye
(conf
, leftx
, pageno
, hooverpageno
, anchor
) ->
936 if not
(pagevisible layout pageno
)
938 match state
.layout with
941 state
.mode
<- Birdseye
(
942 conf
, leftx
, l.pageno
, hooverpageno
, anchor
947 | Ltnotready
(_
, dir
)
950 let rec loop = function
953 match getopaque l.pageno
with
954 | None
-> Ltnotready
(l.pageno
, dir
)
959 then LDfirstvisible
(l.pagex
, l.pagey, dir
)
961 if dir
> 0 then LDfirst
else LDlast
967 | Lnotfound
-> loop rest
969 showlinktype (getlink opaque
n);
970 Ltexact
(l.pageno
, n)
974 state
.mode
<- LinkNav
linknav
982 state
.ghyll
<- noghyll
;
985 let mx, my
= state
.mpos
in
990 let conttiling pageno opaque
=
991 tilepage pageno opaque
993 then preloadlayout state
.x state
.y state
.winw state
.winh
997 let gotoy_and_clear_text y =
998 if not conf
.verbose
then state
.text <- E.s;
1002 let getanchory (n, top
, dtop
) =
1003 let y, h = getpageyh
n in
1004 if conf
.presentation
1006 let ips = calcips
h in
1007 y + truncate
(top
*.float h -. dtop
*.float ips) + ips;
1009 y + truncate
(top
*.float h -. dtop
*.float conf
.interpagespace
)
1012 let gotoanchor anchor
=
1013 gotoy (getanchory anchor
);
1017 cbput state
.hists
.nav
(getanchor
());
1021 let anchor = cbgetc state
.hists
.nav dir
in
1025 let gotoghyll1 single
y =
1026 let scroll f n a
b =
1027 (* http://devmaster.net/forums/topic/9796-ease-in-ease-out-algorithm/ *)
1029 let s x = 3.0*.x**2.0 -. 2.0*.x**3.0 in
1031 then s (float f /. float a
)
1034 then 1.0 -. s ((float (f-b) /. float (n-b)))
1040 let ins = float a
*. 0.5
1041 and outs
= float (n-b) *. 0.5 in
1043 ins +. outs
+. float ones
1045 let rec set nab
y sy
=
1046 let (_N
, _A
, _B
), y =
1049 let scl = if y > sy
then 2 else -2 in
1050 let _N, _
, _
= nab
in
1051 (_N,0,_N), y+conf
.scrollstep
*scl
1053 let sum = summa
_N _A _B
in
1054 let dy = float (y - sy
) in
1058 then state
.ghyll
<- noghyll
1061 let s = scroll n _N _A _B
in
1062 let y1 = y1 +. ((s *. dy) /. sum) in
1063 gotoy_and_clear_text (truncate
y1);
1064 state
.ghyll
<- gf (n+1) y1;
1068 | Some
y'
when single
-> set nab
y' state
.y
1069 | Some
y'
-> set (_N/2, 1, 1) y' state
.y
1071 gf 0 (float state
.y)
1074 match conf
.ghyllscroll
with
1075 | Some nab
when not conf
.presentation
->
1076 if state
.ghyll
== noghyll
1077 then set nab
y state
.y
1078 else state
.ghyll
(Some
y)
1080 gotoy_and_clear_text y
1083 let gotoghyll = gotoghyll1 false;;
1085 let gotopage n top
=
1086 let y, h = getpageyh
n in
1087 let y = y + (truncate
(top
*. float h)) in
1091 let gotopage1 n top
=
1092 let y = getpagey
n in
1097 let invalidate s f =
1102 match state
.geomcmds
with
1103 | ps
, [] when emptystr ps
->
1105 state
.geomcmds
<- s, [];
1108 state
.geomcmds
<- ps
, [s, f];
1110 | ps
, (s'
, _
) :: rest
when s'
= s ->
1111 state
.geomcmds
<- ps
, ((s, f) :: rest
);
1114 state
.geomcmds
<- ps
, ((s, f) :: cmds
);
1118 Hashtbl.iter
(fun _ opaque
->
1119 wcmd "freepage %s" (~
> opaque
);
1121 Hashtbl.clear state
.pagemap
;
1125 if not
(Queue.is_empty state
.tilelru
)
1127 Queue.iter
(fun (k
, p
, s) ->
1128 wcmd "freetile %s" (~
> p
);
1129 state
.memused
<- state
.memused
- s;
1130 Hashtbl.remove state
.tilemap k
;
1132 state
.uioh#infochanged Memused
;
1133 Queue.clear state
.tilelru
;
1139 let h = truncate
(float h*.conf
.zoom
) in
1140 let d = conf
.interpagespace
lsl (if conf
.presentation
then 1 else 0) in
1144 let opendoc path password
=
1146 state
.password
<- password
;
1147 state
.gen
<- state
.gen
+ 1;
1148 state
.docinfo
<- [];
1149 state
.outlines
<- [||];
1152 setaalevel conf
.aalevel
;
1154 if emptystr state
.origin
1158 Wsi.settitle
("llpp " ^
(mbtoutf8
(Filename.basename
titlepath)));
1159 wcmd "open %d %d %s\000%s\000" (btod
!wtmode) (btod
!cxack) path password
;
1160 invalidate "reqlayout"
1162 wcmd "reqlayout %d %d %d %s\000"
1163 conf
.angle
(FMTE.to_int conf
.fitmodel
)
1164 (stateh state
.winh
) state
.nameddest
1169 state
.anchor <- getanchor
();
1170 opendoc state
.path state
.password
;
1174 let c = c *. conf
.colorscale
in
1178 let scalecolor2 (r
, g, b) =
1179 (r
*. conf
.colorscale
, g *. conf
.colorscale
, b *. conf
.colorscale
);
1182 let docolumns columns
=
1183 let wadj = wadjsb () in
1186 let a = Array.make state
.pagecount
(-1, -1, -1, (-1, -1, -1, -1)) in
1187 let wadj = wadjsb () in
1188 let rec loop pageno
pdimno pdim
y ph pdims
=
1189 if pageno
= state
.pagecount
1192 let pdimno, ((_
, w, h, xoff
) as pdim
), pdims
=
1194 | ((pageno'
, _
, _
, _
) as pdim
) :: rest
when pageno'
= pageno
->
1195 pdimno+1, pdim
, rest
1199 let x = max
0 (((wadj + state
.winw
- w) / 2) - xoff
) in
1201 (if conf
.presentation
1202 then (if pageno
= 0 then calcips
h else calcips ph
+ calcips
h)
1203 else (if pageno
= 0 then 0 else conf
.interpagespace
)
1206 a.(pageno
) <- (pdimno, x, y, pdim
);
1207 loop (pageno
+1) pdimno pdim
(y + h) h pdims
1209 loop 0 ~
-1 (-1,-1,-1,-1) 0 0 state
.pdims
;
1210 conf
.columns
<- Csingle
a;
1212 | Cmulti
((columns
, coverA
, coverB
), _
) ->
1213 let a = Array.make state
.pagecount
(-1, -1, -1, (-1, -1, -1, -1)) in
1214 let rec loop pageno
pdimno pdim
x y rowh pdims
=
1215 let rec fixrow m
= if m
= pageno
then () else
1216 let (pdimno, x, y, ((_
, _
, h, _
) as pdim
)) = a.(m
) in
1219 let y = y + (rowh
- h) / 2 in
1220 a.(m
) <- (pdimno, x, y, pdim
);
1224 if pageno
= state
.pagecount
1225 then fixrow (((pageno
- 1) / columns
) * columns
)
1227 let pdimno, ((_
, w, h, xoff
) as pdim
), pdims
=
1229 | ((pageno'
, _
, _
, _
) as pdim
) :: rest
when pageno'
= pageno
->
1230 pdimno+1, pdim
, rest
1235 if pageno
= coverA
- 1 || pageno
= state
.pagecount
- coverB
1237 let x = (wadj + state
.winw
- w) / 2 in
1239 if conf
.presentation
then calcips
h else conf
.interpagespace
in
1240 x, y + ips + rowh
, h
1243 if (pageno
- coverA
) mod columns
= 0
1245 let x = max
0 (wadj + state
.winw
- state
.w) / 2 in
1247 if conf
.presentation
1249 let ips = calcips
h in
1250 y + (if pageno
= 0 then 0 else calcips rowh
+ ips)
1252 y + (if pageno
= 0 then 0 else conf
.interpagespace
)
1256 else x, y, max rowh
h
1260 if pageno
> 1 && (pageno
- coverA
) mod columns
= 0
1263 if pageno
= columns
&& conf
.presentation
1265 let ips = calcips rowh
in
1266 for i
= 0 to pred columns
1268 let (pdimno, x, y, pdim
) = a.(i
) in
1269 a.(i
) <- (pdimno, x, y+ips, pdim
)
1275 fixrow (pageno
- columns
);
1280 a.(pageno
) <- (pdimno, x, y, pdim
);
1281 let x = x + w + xoff
*2 + conf
.interpagespace
in
1282 loop (pageno
+1) pdimno pdim
x y rowh' pdims
1284 loop 0 ~
-1 (-1,-1,-1,-1) 0 0 0 state
.pdims
;
1285 conf
.columns
<- Cmulti
((columns
, coverA
, coverB
), a);
1288 let a = Array.make
(state
.pagecount
*c) (-1, -1, -1, (-1, -1, -1, -1)) in
1289 let rec loop pageno
pdimno pdim
y pdims
=
1290 if pageno
= state
.pagecount
1293 let pdimno, ((_
, w, h, _
) as pdim
), pdims
=
1295 | ((pageno'
, _
, _
, _
) as pdim
) :: rest
when pageno'
= pageno
->
1296 pdimno+1, pdim
, rest
1301 let rec loop1 n x y =
1302 if n = c then y else (
1303 a.(pageno
*c + n) <- (pdimno, x, y, pdim
);
1304 loop1 (n+1) (x+cw) (y + h + conf
.interpagespace
)
1307 let y = loop1 0 0 y in
1308 loop (pageno
+1) pdimno pdim
y pdims
1310 loop 0 ~
-1 (-1,-1,-1,-1) 0 state
.pdims
;
1311 conf
.columns
<- Csplit
(c, a);
1315 docolumns conf
.columns
;
1316 state
.maxy
<- calcheight
();
1317 if state
.reprf
== noreprf
1319 match state
.mode
with
1320 | Birdseye
(_
, _
, pageno
, _
, _
) ->
1321 let y, h = getpageyh pageno
in
1322 let top = (state
.winh
- h) / 2 in
1323 gotoy (max
0 (y - top))
1327 let y = getanchory state
.anchor in
1328 let y = min
y (state
.maxy
- state
.winw
- hscrollh ()) in
1333 state
.reprf
<- noreprf
;
1337 let reshape ?
(firsttime
=false) w h =
1338 GlDraw.viewport ~
x:0 ~
y:0 ~
w:w ~
h:h;
1339 if not firsttime
&& nogeomcmds state
.geomcmds
1340 then state
.anchor <- getanchor
();
1343 let w = wadjsb () + (truncate
(float w *. conf
.zoom
)) in
1346 setfontsize fstate
.fontsize
;
1347 GlMat.mode `modelview
;
1348 GlMat.load_identity
();
1350 GlMat.mode `projection
;
1351 GlMat.load_identity
();
1352 GlMat.rotate ~
x:1.0 ~angle
:180.0 ();
1353 GlMat.translate ~
x:~
-.1.0 ~
y:~
-.1.0 ();
1354 GlMat.scale3
(2.0 /. float state
.winw
, 2.0 /. float state
.winh
, 1.0);
1359 else float state
.x /. float state
.w
1361 invalidate "geometry"
1365 then state
.x <- truncate
(relx *. float w);
1367 match conf
.columns
with
1369 | Cmulti
((c, _
, _
), _
) -> (w - (c-1)*conf
.interpagespace
) / c
1370 | Csplit
(c, _
) -> w * c
1372 wcmd "geometry %d %d %d"
1373 w (stateh h) (FMTE.to_int conf
.fitmodel
)
1378 let len = String.length state
.text in
1379 let x0 = xadjsb () in
1382 match state
.mode
with
1383 | Textentry _
| View
| LinkNav _
->
1384 let h, _
, _
= state
.uioh#scrollpw
in
1389 filledrect x (float (state
.winh
- (fstate
.fontsize
+ 4) - hscrollh))
1390 (x+.w) (float (state
.winh
- hscrollh))
1393 let w = float (wadjsb () + state
.winw
- 1) in
1394 if state
.progress
>= 0.0 && state
.progress
< 1.0
1396 GlDraw.color (0.3, 0.3, 0.3);
1397 let w1 = w *. state
.progress
in
1399 GlDraw.color (0.0, 0.0, 0.0);
1400 rect (float x0+.w1) (float x0+.w-.w1)
1403 GlDraw.color (0.0, 0.0, 0.0);
1407 GlDraw.color (1.0, 1.0, 1.0);
1408 drawstring fstate
.fontsize
1409 (if conf
.leftscroll
then x0 + 2 else x0 + if len > 0 then 8 else 2)
1410 (state
.winh
- hscrollh - 5) s;
1413 match state
.mode
with
1414 | Textentry
((prefix
, text, _
, _
, _
, _
), _
) ->
1418 Printf.sprintf
"%s%s_ [%s]" prefix
text state
.text
1420 Printf.sprintf
"%s%s_" prefix
text
1426 | LinkNav _
-> state
.text
1431 if not
(istextentry state
.mode
) && state
.uioh#eformsgs
1433 let s1 = "(press 'e' to review error messasges)" in
1434 if nonemptystr
s then s ^
" " ^
s1 else s1
1444 let len = Queue.length state
.tilelru
in
1446 match state
.throttle
with
1449 then preloadlayout state
.x state
.y state
.winw state
.winh
1451 | Some
(layout, _
, _
) ->
1455 if state
.memused
<= conf
.memlimit
1460 let (k
, p
, s) as lruitem
= Queue.pop state
.tilelru
in
1461 let n, gen
, colorspace
, angle
, pagew
, pageh
, col, row = k
in
1462 let (_
, pw, ph
, _
) = getpagedim
n in
1465 && colorspace
= conf
.colorspace
1466 && angle
= conf
.angle
1470 let x = col*conf
.tilew
1471 and y = row*conf
.tileh
in
1472 tilevisible (Lazy.force_val
layout) n x y
1474 then Queue.push lruitem state
.tilelru
1477 wcmd "freetile %s" (~
> p
);
1478 state
.memused
<- state
.memused
- s;
1479 state
.uioh#infochanged Memused
;
1480 Hashtbl.remove state
.tilemap k
;
1488 let onpagerect pageno
f =
1490 match conf
.columns
with
1491 | Cmulti
(_
, b) -> b
1493 | Csplit
(_
, b) -> b
1495 if pageno
>= 0 && pageno
< Array.length
b
1497 let (_
, _
, _
, (_
, w, h, _
)) = b.(pageno
) in
1501 let gotopagexy1 wtmode pageno
x y =
1502 let _,w1,h1
,leftx
= getpagedim pageno
in
1503 let top = y /. (float h1
) in
1504 let left = x /. (float w1) in
1505 let py, w, h = getpageywh pageno
in
1506 let wh = state
.winh
- hscrollh () in
1507 let x = left *. (float w) in
1508 let x = leftx
+ state
.x + truncate
x in
1509 let wadj = wadjsb () in
1511 if x < 0 || x >= wadj + state
.winw
1515 let pdy = truncate
(top *. float h) in
1516 let y'
= py + pdy in
1517 let dy = y'
- state
.y in
1519 if x != state
.x || not
(dy > 0 && dy < wh)
1521 if conf
.presentation
1523 if abs
(py - y'
) > wh
1530 if state
.x != sx || state
.y != sy
1535 let ww = wadj + state
.winw
in
1537 and qy
= pdy / wh in
1539 and y = py + qy
* wh in
1540 let x = if -x + ww > w1 then -(w1-ww) else x
1541 and y'
= if y + wh > state
.maxy
then state
.maxy
- wh else y in
1543 if conf
.presentation
1545 if abs
(py - y'
) > wh
1555 gotoy_and_clear_text y;
1557 else gotoy_and_clear_text state
.y;
1560 let gotopagexy wtmode pageno
x y =
1561 match state
.mode
with
1562 | Birdseye
_ -> gotopage pageno
0.0
1565 | LinkNav
_ -> gotopagexy1 wtmode pageno
x y
1568 let getpassword () =
1569 let passcmd = getenvwithdef
"LLPP_ASKPASS" conf
.passcmd in
1574 impmsg "error getting password: %s" s;
1575 dolog
"%s" s) passcmd;
1578 let pgoto opaque pageno
x y =
1579 let pdimno = getpdimno pageno
in
1580 let x, y = project opaque pageno
pdimno x y in
1581 gotopagexy false pageno
x y;
1585 (* dolog "%S" cmds; *)
1586 let spl = splitatspace cmds
in
1588 try Scanf.sscanf
s fmt
f
1590 dolog
"error processing '%S': %s" cmds
@@ exntos exn
;
1593 let addoutline outline
=
1594 match state
.currently
with
1595 | Outlining outlines
->
1596 state
.currently
<- Outlining
(outline
:: outlines
)
1597 | Idle
-> state
.currently
<- Outlining
[outline
]
1600 dolog
"invalid outlining state";
1601 logcurrently state
.currently
1605 state
.uioh#infochanged Pdim
;
1608 | "clearrects", "" ->
1609 state
.rects
<- state
.rects1
;
1610 G.postRedisplay "clearrects";
1612 | "continue", args
->
1613 let n = scan args
"%u" (fun n -> n) in
1614 state
.pagecount
<- n;
1615 begin match state
.currently
with
1617 state
.currently
<- Idle
;
1618 state
.outlines
<- Array.of_list
(List.rev
l)
1624 let cur, cmds
= state
.geomcmds
in
1626 then failwith
"umpossible";
1628 begin match List.rev cmds
with
1630 state
.geomcmds
<- E.s, [];
1631 state
.throttle
<- None
;
1635 state
.geomcmds
<- s, List.rev rest
;
1637 if conf
.maxwait
= None
&& not
!wtmode
1638 then G.postRedisplay "continue";
1645 then showtext ' ' args
1648 Buffer.add_string state
.errmsgs args
;
1649 state
.newerrmsgs
<- true;
1650 G.postRedisplay "error message"
1652 | "progress", args
->
1653 let progress, text =
1656 f, String.sub args pos
(String.length args
- pos
))
1659 state
.progress <- progress;
1660 G.postRedisplay "progress"
1662 | "firstmatch", args
->
1663 let pageno, c, x0, y0, x1, y1, x2
, y2
, x3
, y3
=
1664 scan args
"%u %d %f %f %f %f %f %f %f %f"
1665 (fun p
c x0 y0 x1 y1 x2 y2 x3 y3
->
1666 (p
, c, x0, y0, x1, y1, x2
, y2
, x3
, y3
))
1668 let xoff = float (xadjsb ()) in
1672 and x3
= x3
+. xoff in
1673 let y = (getpagey
pageno) + truncate
y0 in
1675 then state
.x <- truncate
(xoff -. x0) + state
.winw
/2;
1678 let color = (0.0, 0.0, 1.0 /. float c, 0.5) in
1679 state
.rects1
<- [pageno, color, (x0, y0, x1, y1, x2
, y2
, x3
, y3
)]
1682 let pageno, c, x0, y0, x1, y1, x2
, y2
, x3
, y3
=
1683 scan args
"%u %d %f %f %f %f %f %f %f %f"
1684 (fun p
c x0 y0 x1 y1 x2 y2 x3 y3
->
1685 (p
, c, x0, y0, x1, y1, x2
, y2
, x3
, y3
))
1687 let xoff = float (xadjsb ()) in
1691 and x3
= x3
+. xoff in
1692 let color = (0.0, 0.0, 1.0 /. float c, 0.5) in
1694 (pageno, color, (x0, y0, x1, y1, x2
, y2
, x3
, y3
)) :: state
.rects1
1697 let pageopaques, t
= scan args
"%s %f" (fun p t
-> p
, t
) in
1698 let pageopaque = ~
< pageopaques in
1699 begin match state
.currently
with
1700 | Loading
(l, gen
) ->
1701 vlog "page %d took %f sec" l.pageno t
;
1702 Hashtbl.replace state
.pagemap
(l.pageno, gen
) pageopaque;
1703 begin match state
.throttle
with
1705 let preloadedpages =
1707 then preloadlayout state
.x state
.y state
.winw state
.winh
1712 List.fold_left
(fun s l -> IntSet.add
l.pageno s)
1713 IntSet.empty
preloadedpages
1716 Hashtbl.fold (fun ((pageno, _) as key) opaque
accu ->
1717 if not
(IntSet.mem
pageno set)
1719 wcmd "freepage %s" (~
> opaque
);
1725 List.iter
(Hashtbl.remove state
.pagemap
) evictedpages;
1728 state
.currently
<- Idle
;
1731 tilepage l.pageno pageopaque state
.layout;
1733 load preloadedpages;
1734 let visible = pagevisible state
.layout l.pageno in
1737 match state
.mode
with
1738 | LinkNav
(Ltnotready
(pageno, dir
)) ->
1739 if pageno = l.pageno
1744 then LDfirstvisible
(l.pagex
, l.pagey, dir
)
1746 if dir
> 0 then LDfirst
else LDlast
1749 findlink
pageopaque ld
1754 showlinktype (getlink
pageopaque n);
1755 state
.mode
<- LinkNav
(Ltexact
(l.pageno, n))
1757 | LinkNav
(Ltgendir
_)
1758 | LinkNav
(Ltexact
_)
1764 if visible && layoutready state
.layout
1766 G.postRedisplay "page";
1770 | Some
(layout, _, _) ->
1771 state
.currently
<- Idle
;
1772 tilepage l.pageno pageopaque layout;
1779 dolog
"Inconsistent loading state";
1780 logcurrently state
.currently
;
1785 let (x, y, opaques
, size
, t
) =
1786 scan args
"%u %u %s %u %f"
1787 (fun x y p size t
-> (x, y, p
, size
, t
))
1789 let opaque = ~
< opaques
in
1790 begin match state
.currently
with
1791 | Tiling
(l, pageopaque, cs
, angle
, gen
, col, row, tilew
, tileh
) ->
1792 vlog "tile %d [%d,%d] took %f sec" l.pageno col row t
;
1795 if tilew
!= conf
.tilew
|| tileh
!= conf
.tileh
1797 wcmd "freetile %s" (~
> opaque);
1798 state
.currently
<- Idle
;
1802 puttileopaque l col row gen cs angle
opaque size t
;
1803 state
.memused
<- state
.memused
+ size
;
1804 state
.uioh#infochanged Memused
;
1806 Queue.push
((l.pageno, gen
, cs
, angle
, l.pagew
, l.pageh
, col, row),
1807 opaque, size
) state
.tilelru
;
1810 match state
.throttle
with
1811 | None
-> state
.layout
1812 | Some
(layout, _, _) -> layout
1815 state
.currently
<- Idle
;
1817 && conf
.colorspace
= cs
1818 && conf
.angle
= angle
1819 && tilevisible layout l.pageno x y
1820 then conttiling l.pageno pageopaque;
1822 begin match state
.throttle
with
1824 preload state
.layout;
1826 && conf
.colorspace
= cs
1827 && conf
.angle
= angle
1828 && tilevisible state
.layout l.pageno x y
1829 && (not
!wtmode || layoutready state
.layout)
1830 then G.postRedisplay "tile nothrottle";
1832 | Some
(layout, y, _) ->
1833 let ready = layoutready layout in
1837 state
.layout <- layout;
1838 state
.throttle
<- None
;
1839 G.postRedisplay "throttle";
1848 dolog
"Inconsistent tiling state";
1849 logcurrently state
.currently
;
1854 let (n, w, h, _) as pdim
=
1855 scan args
"%u %u %u %u" (fun n w h x -> n, w, h, x)
1858 match conf
.fitmodel
with
1860 | FitPage
| FitProportional
->
1861 match conf
.columns
with
1862 | Csplit
_ -> (n, w, h, 0)
1863 | Csingle
_ | Cmulti
_ -> pdim
1865 state
.uioh#infochanged Pdim
;
1866 state
.pdims
<- pdim :: state
.pdims
1869 let (l, n, t
, h, pos
) =
1870 scan args
"%u %u %d %u %n"
1871 (fun l n t
h pos
-> l, n, t
, h, pos
)
1873 let s = String.sub args pos
(String.length args
- pos
) in
1874 addoutline (s, l, Oanchor
(n, float t
/. float h, 0.0))
1877 let (l, len, pos
) = scan args
"%u %u %n" (fun l len pos
-> l, len, pos
) in
1878 let s = String.sub args pos
len in
1879 let pos2 = pos
+ len + 1 in
1880 let uri = String.sub args
pos2 (String.length args
- pos2) in
1881 addoutline (s, l, Ouri
uri)
1884 let (l, pos
) = scan args
"%u %n" (fun l pos
-> l, pos
) in
1885 let s = String.sub args pos
(String.length args
- pos
) in
1886 addoutline (s, l, Onone
)
1890 scan args
"%u %d %d" (fun n l t
-> n, l, t
)
1892 state
.reprf
<- (fun () -> gotopagexy !wtmode n (float l) (float t
))
1895 let pos = nindex args '
\t'
in
1896 if pos >= 0 && String.sub args
0 pos = "Title"
1898 let s = String.sub args
(pos+1) @@ String.length args
- pos - 1 in
1902 state
.docinfo
<- (1, args
) :: state
.docinfo
1905 state
.uioh#infochanged Docinfo
;
1906 state
.docinfo
<- List.rev state
.docinfo
1910 then Wsi.settitle
"Wrong password";
1911 let password = getpassword () in
1912 if emptystr
password
1913 then error
"document is password protected"
1914 else opendoc state
.path
password
1916 error
"unknown cmd `%S'" cmds
1921 let action = function
1922 | HCprev
-> cbget cb ~
-1
1923 | HCnext
-> cbget cb
1
1924 | HCfirst
-> cbget cb ~
-(cb
.rc)
1925 | HClast
-> cbget cb
(cb
.len - 1 - cb
.rc)
1926 and cancel
() = cb
.rc <- rc
1930 let search pattern forward
=
1931 match conf
.columns
with
1932 | Csplit
_ -> impmsg "searching does not work properly in split columns mode"
1935 if nonemptystr pattern
1938 match state
.layout with
1941 l.pageno, (l.pagey + if forward
then 0 else 0*l.pagevh)
1943 wcmd "search %d %d %d %d,%s\000"
1944 (btod conf
.icase
) pn py (btod forward
) pattern
;
1947 let intentry text key =
1949 if key >= 32 && key < 127
1951 let c = Char.chr
key in
1953 | '
0'
.. '
9'
-> addchar
text c
1955 state
.text <- Printf.sprintf
"invalid char (%d, `%c')" key c;
1958 state
.text <- Printf.sprintf
"invalid key (%d)" key;
1969 let l = String.length
s in
1970 let rec loop pos n = if pos = l then n else
1971 let m = Char.code
s.[pos] - (if pos = 0 && l > 1 then 96 else 97) in
1972 loop (pos+1) (n*26 + m)
1975 let rec loop n = function
1978 match getopaque l.pageno with
1979 | None
-> loop n rest
1981 let m = getlinkcount
opaque in
1984 let under = getlink
opaque n in
1987 else loop (n-m) rest
1989 loop n state
.layout;
1993 let linknentry text key =
1994 if key >= 32 && key < 127
1996 let text = addchar
text (Char.chr
key) in
1997 linknact (fun under -> state
.text <- undertext ~nopath
:true under) text;
2000 state
.text <- Printf.sprintf
"invalid key %d" key;
2005 let textentry text key =
2006 if Wsi.isspecialkey
key
2008 else TEcont
(text ^ toutf8
key)
2011 let reqlayout angle fitmodel
=
2012 match state
.throttle
with
2014 if nogeomcmds state
.geomcmds
2015 then state
.anchor <- getanchor
();
2016 conf
.angle
<- angle
mod 360;
2019 match state
.mode
with
2020 | LinkNav
_ -> state
.mode
<- View
2025 conf
.fitmodel
<- fitmodel
;
2026 invalidate "reqlayout"
2028 wcmd "reqlayout %d %d %d"
2029 conf
.angle
(FMTE.to_int conf
.fitmodel
) (stateh state
.winh
)
2034 let settrim trimmargins trimfuzz
=
2035 if nogeomcmds state
.geomcmds
2036 then state
.anchor <- getanchor
();
2037 conf
.trimmargins
<- trimmargins
;
2038 conf
.trimfuzz
<- trimfuzz
;
2039 let x0, y0, x1, y1 = trimfuzz
in
2040 invalidate "settrim"
2042 wcmd "settrim %d %d %d %d %d" (btod conf
.trimmargins
) x0 y0 x1 y1);
2047 match state
.throttle
with
2049 let zoom = max
0.0001 zoom in
2050 if zoom <> conf
.zoom
2052 state
.prevzoom
<- (conf
.zoom, state
.x);
2054 reshape state
.winw state
.winh
;
2055 state
.text <- Printf.sprintf
"zoom is now %-5.2f" (zoom *. 100.0);
2058 | Some
(layout, y, started
) ->
2060 match conf
.maxwait
with
2064 let dt = now
() -. started
in
2072 let setcolumns mode columns coverA coverB
=
2073 state
.prevcolumns
<- Some
(conf
.columns
, conf
.zoom);
2077 then impmsg "split mode doesn't work in bird's eye"
2079 conf
.columns
<- Csplit
(-columns
, E.a);
2087 conf
.columns
<- Csingle
E.a;
2092 conf
.columns
<- Cmulti
((columns
, coverA
, coverB
), E.a);
2096 reshape state
.winw state
.winh
;
2099 let resetmstate () =
2100 state
.mstate
<- Mnone
;
2101 Wsi.setcursor
Wsi.CURSOR_INHERIT
;
2104 let enterbirdseye () =
2105 let zoom = float conf
.thumbw
/. float state
.winw
in
2106 let birdseyepageno =
2107 let cy = state
.winh
/ 2 in
2111 let rec fold best
= function
2114 let d = cy - (l.pagedispy + l.pagevh/2)
2115 and dbest
= cy - (best
.pagedispy + best
.pagevh/2) in
2116 if abs
d < abs dbest
2123 state
.mode
<- Birdseye
(
2124 { conf
with zoom = conf
.zoom }, state
.x, birdseyepageno, -1, getanchor
()
2128 conf
.presentation
<- false;
2129 conf
.interpagespace
<- 10;
2130 conf
.hlinks
<- false;
2131 conf
.fitmodel
<- FitPage
;
2133 conf
.maxwait
<- None
;
2135 match conf
.beyecolumns
with
2138 Cmulti
((c, 0, 0), E.a)
2139 | None
-> Csingle
E.a
2143 state
.text <- Printf.sprintf
"birds eye mode on (zoom %3.1f%%)"
2148 reshape state
.winw state
.winh
;
2151 let leavebirdseye (c, leftx
, pageno, _, anchor) goback
=
2153 conf
.zoom <- c.zoom;
2154 conf
.presentation
<- c.presentation
;
2155 conf
.interpagespace
<- c.interpagespace
;
2156 conf
.maxwait
<- c.maxwait
;
2157 conf
.hlinks
<- c.hlinks
;
2158 conf
.fitmodel
<- c.fitmodel
;
2159 conf
.beyecolumns
<- (
2160 match conf
.columns
with
2161 | Cmulti
((c, _, _), _) -> Some
c
2163 | Csplit
_ -> failwith
"leaving bird's eye split mode"
2166 match c.columns
with
2167 | Cmulti
(c, _) -> Cmulti
(c, E.a)
2168 | Csingle
_ -> Csingle
E.a
2169 | Csplit
(c, _) -> Csplit
(c, E.a)
2173 state
.text <- Printf.sprintf
"birds eye mode off (zoom %3.1f%%)"
2176 reshape state
.winw state
.winh
;
2177 state
.anchor <- if goback
then anchor else (pageno, 0.0, 1.0);
2181 let togglebirdseye () =
2182 match state
.mode
with
2183 | Birdseye vals
-> leavebirdseye vals
true
2184 | View
-> enterbirdseye ()
2189 let upbirdseye incr
(conf
, leftx
, pageno, hooverpageno
, anchor) =
2190 let pageno = max
0 (pageno - incr
) in
2191 let rec loop = function
2192 | [] -> gotopage1 pageno 0
2193 | l :: _ when l.pageno = pageno ->
2194 if l.pagedispy >= 0 && l.pagey = 0
2195 then G.postRedisplay "upbirdseye"
2196 else gotopage1 pageno 0
2197 | _ :: rest
-> loop rest
2201 state
.mode
<- Birdseye
(conf
, leftx
, pageno, hooverpageno
, anchor)
2204 let downbirdseye incr
(conf
, leftx
, pageno, hooverpageno
, anchor) =
2205 let pageno = min
(state
.pagecount
- 1) (pageno + incr
) in
2206 state
.mode
<- Birdseye
(conf
, leftx
, pageno, hooverpageno
, anchor);
2207 let rec loop = function
2209 let y, h = getpageyh
pageno in
2210 let dy = (y - state
.y) - (state
.winh
- h - conf
.interpagespace
) in
2212 | l :: _ when l.pageno = pageno ->
2213 if l.pagevh != l.pageh
2214 then gotoy (clamp (l.pageh
- l.pagevh + conf
.interpagespace
))
2215 else G.postRedisplay "downbirdseye"
2216 | _ :: rest
-> loop rest
2222 let optentry mode
_ key =
2223 let btos b = if b then "on" else "off" in
2224 if key >= 32 && key < 127
2226 let c = Char.chr
key in
2230 try conf
.scrollstep
<- int_of_string
s with exn
->
2231 state
.text <- Printf.sprintf
"bad integer `%s': %s" s @@ exntos exn
2233 TEswitch
("scroll step: ", E.s, None
, intentry, ondone, true)
2238 conf
.autoscrollstep
<- boundastep state
.winh
(int_of_string
s);
2239 if state
.autoscroll
<> None
2240 then state
.autoscroll
<- Some conf
.autoscrollstep
2242 state
.text <- Printf.sprintf
"bad integer `%s': %s" s @@ exntos exn
2244 TEswitch
("auto scroll step: ", E.s, None
, intentry, ondone, true)
2249 let n, a, b = multicolumns_of_string
s in
2250 setcolumns mode
n a b;
2252 state
.text <- Printf.sprintf
"bad columns `%s': %s" s @@ exntos exn
2254 TEswitch
("columns: ", E.s, None
, textentry, ondone, true)
2259 let zoom = float (int_of_string
s) /. 100.0 in
2262 state
.text <- Printf.sprintf
"bad integer `%s': %s" s @@ exntos exn
2264 TEswitch
("zoom: ", E.s, None
, intentry, ondone, true)
2269 conf
.thumbw
<- bound
(int_of_string
s) 2 4096;
2271 Printf.sprintf
"thumbnail width is set to %d" conf
.thumbw
;
2272 begin match mode
with
2274 leavebirdseye beye
false;
2281 state
.text <- Printf.sprintf
"bad integer `%s': %s" s @@ exntos exn
2283 TEswitch
("thumbnail width: ", E.s, None
, intentry, ondone, true)
2287 match int_of_string
s with
2288 | angle
-> reqlayout angle conf
.fitmodel
2291 Printf.sprintf
"bad integer `%s': %s" s @@ exntos exn
2293 TEswitch
("rotation: ", E.s, None
, intentry, ondone, true)
2296 conf
.icase
<- not conf
.icase
;
2297 TEdone
("case insensitive search " ^
(btos conf
.icase
))
2300 conf
.preload <- not conf
.preload;
2302 TEdone
("preload " ^
(btos conf
.preload))
2305 conf
.verbose
<- not conf
.verbose
;
2306 TEdone
("verbose " ^
(btos conf
.verbose
))
2309 conf
.debug
<- not conf
.debug
;
2310 TEdone
("debug " ^
(btos conf
.debug
))
2313 conf
.maxhfit
<- not conf
.maxhfit
;
2314 state
.maxy
<- calcheight
();
2315 TEdone
("maxhfit " ^
(btos conf
.maxhfit
))
2318 conf
.crophack
<- not conf
.crophack
;
2319 TEdone
("crophack " ^
btos conf
.crophack
)
2323 match conf
.maxwait
with
2325 conf
.maxwait
<- Some infinity
;
2326 "always wait for page to complete"
2328 conf
.maxwait
<- None
;
2329 "show placeholder if page is not ready"
2334 conf
.underinfo
<- not conf
.underinfo
;
2335 TEdone
("underinfo " ^
btos conf
.underinfo
)
2338 conf
.savebmarks
<- not conf
.savebmarks
;
2339 TEdone
("persistent bookmarks " ^
btos conf
.savebmarks
)
2345 match state
.layout with
2350 conf
.interpagespace
<- int_of_string
s;
2351 docolumns conf
.columns
;
2352 state
.maxy
<- calcheight
();
2353 let y = getpagey
pageno in
2356 state
.text <- Printf.sprintf
"bad integer `%s': %s" s @@ exntos exn
2358 TEswitch
("vertical margin: ", E.s, None
, intentry, ondone, true)
2362 match conf
.fitmodel
with
2363 | FitProportional
-> FitWidth
2364 | FitWidth
| FitPage
-> FitProportional
2366 reqlayout conf
.angle
fm;
2367 TEdone
("proportional display " ^
btos (fm == FitProportional
))
2370 settrim (not conf
.trimmargins
) conf
.trimfuzz
;
2371 TEdone
("trim margins " ^
btos conf
.trimmargins
)
2374 conf
.invert
<- not conf
.invert
;
2375 TEdone
("invert colors " ^
btos conf
.invert
)
2379 cbput state
.hists
.sel
s;
2382 TEswitch
("selection command: ", E.s, Some
(onhist state
.hists
.sel
),
2383 textentry, ondone, true)
2387 then conf
.pax
<- Some
(ref (0.0, 0, 0))
2388 else conf
.pax
<- None
;
2389 TEdone
("PAX " ^
btos (conf
.pax
!= None
))
2392 state
.text <- Printf.sprintf
"bad option %d `%c'" key c;
2398 class type lvsource
= object
2399 method getitemcount
: int
2400 method getitem
: int -> (string * int)
2401 method hasaction
: int -> bool
2409 method getactive
: int
2410 method getfirst
: int
2412 method getminfo
: (int * int) array
2415 class virtual lvsourcebase
= object
2416 val mutable m_active
= 0
2417 val mutable m_first
= 0
2418 val mutable m_pan
= 0
2419 method getactive
= m_active
2420 method getfirst
= m_first
2421 method getpan
= m_pan
2422 method getminfo
: (int * int) array
= E.a
2425 let textentrykeyboard
2426 key _mask
((c, text, opthist
, onkey
, ondone, cancelonempty
), onleave
) =
2428 let key = Wsi.keypadtodigitkey
key in
2430 state
.mode
<- Textentry
(te
, onleave
);
2432 G.postRedisplay "textentrykeyboard enttext";
2434 let histaction cmd
=
2437 | Some
(action, _) ->
2438 state
.mode
<- Textentry
(
2439 (c, action cmd
, opthist
, onkey
, ondone, cancelonempty
), onleave
2441 G.postRedisplay "textentry histaction"
2445 if emptystr
text && cancelonempty
2448 G.postRedisplay "textentrykeyboard after cancel";
2451 let s = withoutlastutf8
text in
2452 enttext (c, s, opthist
, onkey
, ondone, cancelonempty
)
2454 | @enter
| @kpenter
->
2457 G.postRedisplay "textentrykeyboard after confirm"
2459 | @up
| @kpup
-> histaction HCprev
2460 | @down
| @kpdown
-> histaction HCnext
2461 | @home
| @kphome
-> histaction HCfirst
2462 | @jend
| @kpend
-> histaction HClast
2467 begin match opthist
with
2469 | Some
(_, onhistcancel
) -> onhistcancel
()
2473 G.postRedisplay "textentrykeyboard after cancel2"
2476 enttext (c, E.s, opthist
, onkey
, ondone, cancelonempty
)
2479 | @delete
| @kpdelete
-> ()
2481 | _ when key != 0 && not
(Wsi.isspecialkey
key) ->
2482 begin match onkey
text key with
2486 G.postRedisplay "textentrykeyboard after confirm2";
2489 enttext (c, text, opthist
, onkey
, ondone, cancelonempty
);
2493 G.postRedisplay "textentrykeyboard after cancel3"
2496 state
.mode
<- Textentry
(te
, onleave
);
2497 G.postRedisplay "textentrykeyboard switch";
2501 vlog "unhandled key %s" (Wsi.keyname
key)
2504 let firstof first active
=
2505 if first
> active
|| abs
(first
- active
) > fstate
.maxrows
- 1
2506 then max
0 (active
- (fstate
.maxrows
/2))
2510 let calcfirst first active
=
2513 let rows = active
- first
in
2514 if rows > fstate
.maxrows
then active
- fstate
.maxrows
else first
2518 let scrollph y maxy
=
2519 let sh = float (maxy
+ state
.winh
) /. float state
.winh
in
2520 let sh = float state
.winh
/. sh in
2521 let sh = max
sh (float conf
.scrollh
) in
2523 let percent = float y /. float maxy
in
2524 let position = (float state
.winh
-. sh) *. percent in
2527 if position +. sh > float state
.winh
2528 then float state
.winh
-. sh
2534 let adderrmsg src msg
=
2535 Buffer.add_string state
.errmsgs msg
;
2536 state
.newerrmsgs
<- true;
2540 let adderrfmt src fmt
=
2541 Format.ksprintf
(fun s -> adderrmsg src
s) fmt
;
2544 let coe s = (s :> uioh
);;
2546 class listview ~zebra ~helpmode ~
(source
:lvsource
) ~trusted ~modehash
=
2548 val m_pan
= source#getpan
2549 val m_first
= source#getfirst
2550 val m_active
= source#getactive
2552 val m_prev_uioh
= state
.uioh
2554 method private elemunder
y =
2558 let n = y / (fstate
.fontsize
+1) in
2559 if m_first
+ n < source#getitemcount
2561 if source#hasaction
(m_first
+ n)
2562 then Some
(m_first
+ n)
2569 GlFunc.blend_func ~src
:`src_alpha ~dst
:`one_minus_src_alpha
;
2570 GlDraw.color (0., 0., 0.) ~alpha
:0.85;
2571 filledrect 0. 0. (float state
.winw
) (float state
.winh
);
2572 GlDraw.color (1., 1., 1.);
2573 Gl.enable `texture_2d
;
2574 let fs = fstate
.fontsize
in
2576 let hw = (wadjsb () + xadjsb () + state
.winw
)/3 in
2577 let ww = fstate
.wwidth
in
2578 let tabw = 17.0*.ww in
2579 let itemcount = source#getitemcount
in
2580 let minfo = source#getminfo
in
2583 then float (xadjsb ()), float (state
.winw
- 1)
2584 else 0.0, float (state
.winw
- conf
.scrollbw
- 1)
2586 let xadj = xadjsb () in
2588 if (row - m_first
) > fstate
.maxrows
2591 if row >= 0 && row < itemcount
2593 let (s, level
) = source#getitem
row in
2594 let y = (row - m_first
) * nfs in
2596 (if conf
.leftscroll
then float xadj else 5.0)
2597 +. (float (level
+ m_pan
)) *. ww in
2600 (let c = if row land 1 = 0 then 1.0 else 0.92 in (c,c,c));
2604 Gl.disable `texture_2d
;
2605 let alpha = if source#hasaction
row then 0.9 else 0.3 in
2606 GlDraw.color (1., 1., 1.) ~
alpha;
2607 linerect (x0 +. 1.) (float (y + 1)) (x1) (float (y + fs + 3));
2608 Gl.enable `texture_2d
;
2611 if zebra
&& row land 1 = 1
2615 GlDraw.color (c,c,c);
2616 let drawtabularstring s =
2618 let x'
= truncate
(x0 +. x) in
2619 let pos = nindex
s '
\000'
in
2621 then drawstring1 fs x'
(y+nfs) s
2623 let s1 = String.sub
s 0 pos
2624 and s2
= String.sub
s (pos+1) (String.length
s - pos - 1) in
2629 let s'
= withoutlastutf8
s in
2630 let s = s' ^
"@Uellipsis" in
2631 let w = measurestr
fs s in
2632 if float x'
+. w +. ww < float (hw + x'
)
2637 if float x'
+. ww +. measurestr
fs s1 > float (hw + x'
)
2641 ignore
(drawstring1 fs x'
(y+nfs) s1);
2642 drawstring1 fs (hw + x'
) (y+nfs) s2
2646 let x = if helpmode
&& row > 0 then x +. ww else x in
2647 let tabpos = nindex
s '
\t'
in
2650 let len = String.length
s - tabpos - 1 in
2651 let s1 = String.sub
s 0 tabpos
2652 and s2
= String.sub
s (tabpos + 1) len in
2653 let nx = drawstr x s1 in
2655 let x = x +. (max
tabw sw) in
2658 let len = String.length
s - 2 in
2659 if len > 0 && s.[0] = '
\xc2'
&& s.[1] = '
\xb7'
2661 let s = String.sub
s 2 len in
2662 let x = if not helpmode
then x +. ww else x in
2663 GlDraw.color (1.2, 1.2, 1.2);
2664 let vinc = drawstring1 (fs+fs/4)
2665 (truncate
(x -. ww)) (y+nfs) s in
2666 GlDraw.color (1., 1., 1.);
2667 vinc +. (float fs *. 0.8)
2673 ignore
(drawtabularstring s);
2679 GlDraw.color (1.0, 1.0, 1.0) ~
alpha:0.5;
2680 let xadj = float (xadjsb () + 5) in
2682 if (row - m_first
) > fstate
.maxrows
2685 if row >= 0 && row < itemcount
2687 let (s, level
) = source#getitem
row in
2688 let pos0 = nindex
s '
\000'
in
2689 let y = (row - m_first
) * nfs in
2690 let x = float (level
+ m_pan
) *. ww in
2691 let (first
, last
) = minfo.(row) in
2693 if pos0 > 0 && first
> pos0
2694 then String.sub
s (pos0+1) (first
-pos0-1)
2695 else String.sub
s 0 first
2697 let suffix = String.sub
s first
(last
- first
) in
2698 let w1 = measurestr fstate
.fontsize
prefix in
2699 let w2 = measurestr fstate
.fontsize
suffix in
2700 let x = x +. if conf
.leftscroll
then xadj else 5.0 in
2701 let x = if pos0 > 0 && first
> pos0 then x +. float hw else x in
2703 and y0 = float (y+2) in
2705 and y1 = float (y+fs+3) in
2706 filledrect x0 y0 x1 y1;
2711 Gl.disable `texture_2d
;
2712 if Array.length
minfo > 0 then loop m_first
;
2715 method updownlevel incr
=
2716 let len = source#getitemcount
in
2718 if m_active
>= 0 && m_active
< len
2719 then snd
(source#getitem m_active
)
2723 if i
= len then i
-1 else if i
= -1 then 0 else
2724 let _, l = source#getitem i
in
2725 if l != curlevel then i
else flow (i
+incr
)
2727 let active = flow m_active
in
2728 let first = calcfirst m_first
active in
2729 G.postRedisplay "outline updownlevel";
2730 {< m_active
= active; m_first
= first >}
2732 method private key1
key mask
=
2733 let set1 active first qsearch
=
2734 coe {< m_active
= active; m_first
= first; m_qsearch
= qsearch
>}
2736 let search active pattern incr
=
2737 let active = if active = -1 then m_first
else active in
2740 if n >= 0 && n < source#getitemcount
2742 let s, _ = source#getitem
n in
2743 match Str.search_forward re
s 0 with
2744 | (exception Not_found
) -> loop (n + incr
)
2751 let qpat = Str.quote pattern
in
2752 match Str.regexp_case_fold
qpat with
2755 adderrfmt "listview key1" "regexp_case_fold for `%S' failed: %S\n"
2756 qpat @@ Printexc.to_string exn
;
2759 let itemcount = source#getitemcount
in
2760 let find start incr
=
2762 if i
= -1 || i
= itemcount
2765 if source#hasaction i
2767 else find (i
+ incr
)
2772 let set active first =
2773 let first = bound
first 0 (itemcount - fstate
.maxrows
) in
2775 coe {< m_active
= active; m_first
= first; m_qsearch
= E.s >}
2778 let isvisible first n = n >= first && n - first <= fstate
.maxrows
in
2780 let incr1 = if incr
> 0 then 1 else -1 in
2781 if isvisible m_first m_active
2784 let next = m_active
+ incr
in
2786 if next < 0 || next >= itemcount
2788 else find next incr1
2790 if abs
(m_active
- next) > fstate
.maxrows
2796 let first = m_first
+ incr
in
2797 let first = bound
first 0 (itemcount - fstate
.maxrows
) in
2799 let next = m_active
+ incr
in
2800 let next = bound
next 0 (itemcount - 1) in
2807 if isvisible first next
2814 let first = min
next m_first
in
2816 if abs
(next - first) > fstate
.maxrows
2822 let first = m_first
+ incr
in
2823 let first = bound
first 0 (itemcount - 1) in
2825 let next = m_active
+ incr
in
2826 let next = bound
next 0 (itemcount - 1) in
2827 let next = find next incr1 in
2829 if next = -1 || abs
(m_active
- first) > fstate
.maxrows
2831 let active = if m_active
= -1 then next else m_active
in
2836 if isvisible first active
2842 G.postRedisplay "listview navigate";
2846 | (@r
|@s) when Wsi.withctrl mask
->
2847 let incr = if key = @r
then -1 else 1 in
2849 match search (m_active
+ incr) m_qsearch
incr with
2851 state
.text <- m_qsearch ^
" [not found]";
2854 state
.text <- m_qsearch
;
2855 active, firstof m_first
active
2857 G.postRedisplay "listview ctrl-r/s";
2858 set1 active first m_qsearch
;
2860 | @insert
when Wsi.withctrl mask
->
2861 if m_active
>= 0 && m_active
< source#getitemcount
2863 let s, _ = source#getitem m_active
in
2869 if emptystr m_qsearch
2872 let qsearch = withoutlastutf8 m_qsearch
in
2876 G.postRedisplay "listview empty qsearch";
2877 set1 m_active m_first
E.s;
2881 match search m_active
qsearch ~
-1 with
2883 state
.text <- qsearch ^
" [not found]";
2886 state
.text <- qsearch;
2887 active, firstof m_first
active
2889 G.postRedisplay "listview backspace qsearch";
2890 set1 active first qsearch
2893 | key when (key != 0 && not
(Wsi.isspecialkey
key)) ->
2894 let pattern = m_qsearch ^ toutf8
key in
2896 match search m_active
pattern 1 with
2898 state
.text <- pattern ^
" [not found]";
2901 state
.text <- pattern;
2902 active, firstof m_first
active
2904 G.postRedisplay "listview qsearch add";
2905 set1 active first pattern;
2909 if emptystr m_qsearch
2911 G.postRedisplay "list view escape";
2912 let mx, my
= state
.mpos
in
2916 source#exit ~uioh
:(coe self
)
2917 ~cancel
:true ~
active:m_active ~
first:m_first ~pan
:m_pan
2919 | None
-> m_prev_uioh
2924 G.postRedisplay "list view kill qsearch";
2925 coe {< m_qsearch
= E.s >}
2928 | @enter
| @kpenter
->
2930 let self = {< m_qsearch
= E.s >} in
2932 G.postRedisplay "listview enter";
2933 if m_active
>= 0 && m_active
< source#getitemcount
2935 source#exit ~uioh
:(coe self) ~cancel
:false
2936 ~
active:m_active ~
first:m_first ~pan
:m_pan
;
2939 source#exit ~uioh
:(coe self) ~cancel
:true
2940 ~
active:m_active ~
first:m_first ~pan
:m_pan
;
2943 begin match opt with
2944 | None
-> m_prev_uioh
2948 | @delete
| @kpdelete
->
2951 | @up
| @kpup
-> navigate ~
-1
2952 | @down
| @kpdown
-> navigate 1
2953 | @prior
| @kpprior
-> navigate ~
-(fstate
.maxrows
)
2954 | @next | @kpnext
-> navigate fstate
.maxrows
2956 | @right
| @kpright
->
2958 G.postRedisplay "listview right";
2959 coe {< m_pan
= m_pan
- 1 >}
2961 | @left | @kpleft
->
2963 G.postRedisplay "listview left";
2964 coe {< m_pan
= m_pan
+ 1 >}
2966 | @home
| @kphome
->
2967 let active = find 0 1 in
2968 G.postRedisplay "listview home";
2972 let first = max
0 (itemcount - fstate
.maxrows
) in
2973 let active = find (itemcount - 1) ~
-1 in
2974 G.postRedisplay "listview end";
2977 | key when (key = 0 || Wsi.isspecialkey
key) ->
2981 dolog
"listview unknown key %#x" key; coe self
2983 method key key mask
=
2984 match state
.mode
with
2985 | Textentry te
-> textentrykeyboard key mask te
; coe self
2988 | LinkNav
_ -> self#key1
key mask
2990 method button button down
x y _ =
2993 | 1 when vscrollhit x ->
2994 G.postRedisplay "listview scroll";
2997 let _, position, sh = self#
scrollph in
2998 if y > truncate
position && y < truncate
(position +. sh)
3000 state
.mstate
<- Mscrolly
;
3004 let s = float (max
0 (y - conf
.scrollh
)) /. float state
.winh
in
3005 let first = truncate
(s *. float source#getitemcount
) in
3006 let first = min source#getitemcount
first in
3007 Some
(coe {< m_first
= first; m_active
= first >})
3009 state
.mstate
<- Mnone
;
3013 begin match self#elemunder
y with
3015 G.postRedisplay "listview click";
3016 source#exit ~uioh
:(coe {< m_active
= n >})
3017 ~cancel
:false ~
active:n ~
first:m_first ~pan
:m_pan
3021 | n when (n == 4 || n == 5) && not down
->
3022 let len = source#getitemcount
in
3024 if n = 5 && m_first
+ fstate
.maxrows
>= len
3028 let first = m_first
+ (if n == 4 then -1 else 1) in
3029 bound
first 0 (len - 1)
3031 G.postRedisplay "listview wheel";
3032 Some
(coe {< m_first
= first >})
3033 | n when (n = 6 || n = 7) && not down
->
3034 let inc = if n = 7 then -1 else 1 in
3035 G.postRedisplay "listview hwheel";
3036 Some
(coe {< m_pan
= m_pan
+ inc >})
3041 | None
-> m_prev_uioh
3044 method multiclick
_ x y = self#button
1 true x y
3047 match state
.mstate
with
3049 let s = float (max
0 (y - conf
.scrollh
)) /. float state
.winh
in
3050 let first = truncate
(s *. float source#getitemcount
) in
3051 let first = min source#getitemcount
first in
3052 G.postRedisplay "listview motion";
3053 coe {< m_first
= first; m_active
= first >}
3061 method pmotion
x y =
3062 if x < state
.winw
- conf
.scrollbw
3065 match self#elemunder
y with
3066 | None
-> Wsi.setcursor
Wsi.CURSOR_INHERIT
; m_active
3067 | Some
n -> Wsi.setcursor
Wsi.CURSOR_INFO
; n
3071 then (G.postRedisplay "listview pmotion"; {< m_active
= n >})
3076 Wsi.setcursor
Wsi.CURSOR_INHERIT
;
3080 method infochanged
_ = ()
3082 method scrollpw
= (0, 0.0, 0.0)
3084 let nfs = fstate
.fontsize
+ 1 in
3085 let y = m_first
* nfs in
3086 let itemcount = source#getitemcount
in
3087 let maxi = max
0 (itemcount - fstate
.maxrows
) in
3088 let maxy = maxi * nfs in
3089 let p, h = scrollph y maxy in
3092 method modehash
= modehash
3093 method eformsgs
= false
3094 method alwaysscrolly
= true
3097 class outlinelistview ~zebra ~source
=
3098 let settext autonarrow
s =
3101 let ss = source#statestr
in
3105 else "{" ^
ss ^
"} [" ^
s ^
"]"
3106 else state
.text <- s
3112 ~source
:(source
:> lvsource
)
3114 ~modehash
:(findkeyhash conf
"outline")
3117 val m_autonarrow
= false
3119 method! key key mask
=
3121 if emptystr state
.text
3123 else fstate
.maxrows - 2
3125 let calcfirst first active =
3128 let rows = active - first in
3129 if rows > maxrows then active - maxrows else first
3133 let active = m_active
+ incr in
3134 let active = bound
active 0 (source#getitemcount
- 1) in
3135 let first = calcfirst m_first
active in
3136 G.postRedisplay "outline navigate";
3137 coe {< m_active
= active; m_first
= first >}
3139 let navscroll first =
3141 let dist = m_active
- first in
3147 else first + maxrows
3150 G.postRedisplay "outline navscroll";
3151 coe {< m_first
= first; m_active
= active >}
3153 let ctrl = Wsi.withctrl mask
in
3158 then (source#denarrow
; E.s)
3160 let pattern = source#renarrow
in
3161 if nonemptystr m_qsearch
3162 then (source#narrow m_qsearch
; m_qsearch
)
3166 settext (not m_autonarrow
) text;
3167 G.postRedisplay "toggle auto narrowing";
3168 coe {< m_first
= 0; m_active
= 0; m_autonarrow
= not m_autonarrow
>}
3170 | @slash
when emptystr m_qsearch
&& not m_autonarrow
->
3172 G.postRedisplay "toggle auto narrowing";
3173 coe {< m_first
= 0; m_active
= 0; m_autonarrow
= true >}
3176 source#narrow m_qsearch
;
3178 then source#add_narrow_pattern m_qsearch
;
3179 G.postRedisplay "outline ctrl-n";
3180 coe {< m_first
= 0; m_active
= 0 >}
3183 let active = source#calcactive
(getanchor
()) in
3184 let first = firstof m_first
active in
3185 G.postRedisplay "outline ctrl-s";
3186 coe {< m_first
= first; m_active
= active >}
3189 G.postRedisplay "outline ctrl-u";
3190 if m_autonarrow
&& nonemptystr m_qsearch
3192 ignore
(source#renarrow
);
3193 settext m_autonarrow
E.s;
3194 coe {< m_first
= 0; m_active
= 0; m_qsearch
= E.s >}
3197 source#del_narrow_pattern
;
3198 let pattern = source#renarrow
in
3200 if emptystr
pattern then E.s else "Narrowed to " ^
pattern
3202 settext m_autonarrow
text;
3203 coe {< m_first
= 0; m_active
= 0; m_qsearch
= E.s >}
3207 let first = max
0 (m_active
- (fstate
.maxrows / 2)) in
3208 G.postRedisplay "outline ctrl-l";
3209 coe {< m_first
= first >}
3211 | @tab
when m_autonarrow
->
3212 if nonemptystr m_qsearch
3214 G.postRedisplay "outline list view tab";
3215 source#add_narrow_pattern m_qsearch
;
3217 coe {< m_qsearch
= E.s >}
3221 | @escape
when m_autonarrow
->
3222 if nonemptystr m_qsearch
3223 then source#add_narrow_pattern m_qsearch
;
3226 | @enter
| @kpenter
when m_autonarrow
->
3227 if nonemptystr m_qsearch
3228 then source#add_narrow_pattern m_qsearch
;
3231 | key when m_autonarrow
&& (not
(Wsi.isspecialkey
key)) ->
3232 let pattern = m_qsearch ^ toutf8
key in
3233 G.postRedisplay "outlinelistview autonarrow add";
3234 source#narrow
pattern;
3235 settext true pattern;
3236 coe {< m_first
= 0; m_active
= 0; m_qsearch
= pattern >}
3238 | key when m_autonarrow
&& key = @backspace
->
3239 if emptystr m_qsearch
3242 let pattern = withoutlastutf8 m_qsearch
in
3243 G.postRedisplay "outlinelistview autonarrow backspace";
3244 ignore
(source#renarrow
);
3245 source#narrow
pattern;
3246 settext true pattern;
3247 coe {< m_first
= 0; m_active
= 0; m_qsearch
= pattern >}
3249 | @up
| @kpup
when ctrl ->
3250 navscroll (max
0 (m_first
- 1))
3252 | @down
| @kpdown
when ctrl ->
3253 navscroll (min
(source#getitemcount
- 1) (m_first
+ 1))
3255 | @up
| @kpup
-> navigate ~
-1
3256 | @down
| @kpdown
-> navigate 1
3257 | @prior
| @kpprior
-> navigate ~
-(fstate
.maxrows)
3258 | @next | @kpnext
-> navigate fstate
.maxrows
3260 | @right
| @kpright
->
3264 G.postRedisplay "outline ctrl right";
3265 {< m_pan
= m_pan
+ 1 >}
3267 else self#updownlevel
1
3271 | @left | @kpleft
->
3275 G.postRedisplay "outline ctrl left";
3276 {< m_pan
= m_pan
- 1 >}
3278 else self#updownlevel ~
-1
3282 | @home
| @kphome
->
3283 G.postRedisplay "outline home";
3284 coe {< m_first
= 0; m_active
= 0 >}
3287 let active = source#getitemcount
- 1 in
3288 let first = max
0 (active - fstate
.maxrows) in
3289 G.postRedisplay "outline end";
3290 coe {< m_active
= active; m_first
= first >}
3292 | _ -> super#
key key mask
3295 let genhistoutlines () =
3297 |> List.sort
(fun (_, c1
, _, _, _, _) (_, c2
, _, _, _, _) ->
3298 compare c2
.lastvisit c1
.lastvisit
)
3300 (fun ((path
, c, _, _, _, origin
) as hist
) ->
3301 let path = if nonemptystr origin
then origin
else path in
3302 let base = mbtoutf8
@@ Filename.basename
path in
3303 (base ^
"\000" ^
c.title
, 1, Ohistory hist
)
3308 let gotohist (path, c, bookmarks
, x, anchor, origin
) =
3309 Config.save
leavebirdseye;
3310 state
.anchor <- anchor;
3311 state
.bookmarks
<- bookmarks
;
3312 state
.origin
<- origin
;
3315 let x0, y0, x1, y1 = conf
.trimfuzz
in
3316 wcmd "trimset %d %d %d %d %d" (btod conf
.trimmargins
) x0 y0 x1 y1;
3317 reshape ~firsttime
:true state
.winw state
.winh
;
3318 opendoc path origin
;
3322 let makecheckers () =
3323 (* Based on lablGL-1.04/LablGlut/examples/lablGL/checker.ml which had
3325 converted by Issac Trotts. July 25, 2002 *)
3326 let image = GlPix.create `ubyte ~format
:`luminance ~width
:2 ~height
:2 in
3327 Raw.sets_string
(GlPix.to_raw
image) ~
pos:0 "\255\200\200\255";
3328 let id = GlTex.gen_texture
() in
3329 GlTex.bind_texture ~target
:`texture_2d
id;
3330 GlPix.store
(`unpack_alignment
1);
3331 GlTex.image2d
image;
3332 List.iter
(GlTex.parameter ~target
:`texture_2d
)
3333 [ `mag_filter `nearest
; `min_filter `nearest
];
3337 let setcheckers enabled
=
3338 match state
.checkerstexid
with
3340 if enabled
then state
.checkerstexid
<- Some
(makecheckers ())
3342 | Some checkerstexid
->
3345 GlTex.delete_texture checkerstexid
;
3346 state
.checkerstexid
<- None
;
3350 let describe_location () =
3351 let fn = page_of_y state
.y in
3352 let ln = page_of_y
(state
.y + state
.winh
- hscrollh () - 1) in
3353 let maxy = state
.maxy - (if conf
.maxhfit
then state
.winh
else 0) in
3357 else (100. *. (float state
.y /. float maxy))
3361 Printf.sprintf
"page %d of %d [%.2f%%]"
3362 (fn+1) state
.pagecount
percent
3365 "pages %d-%d of %d [%.2f%%]"
3366 (fn+1) (ln+1) state
.pagecount
percent
3369 let setpresentationmode v
=
3370 let n = page_of_y state
.y in
3371 state
.anchor <- (n, 0.0, 1.0);
3372 conf
.presentation
<- v
;
3373 if conf
.fitmodel
= FitPage
3374 then reqlayout conf
.angle conf
.fitmodel
;
3378 let setbgcol (r
, g, b) =
3380 let r = r *. 255.0 |> truncate
3381 and g = g *. 255.0 |> truncate
3382 and b = b *. 255.0 |> truncate
in
3383 r lsl 16 |> (lor) (g lsl 8) |> (lor) b
3385 Wsi.setwinbgcol
col;
3389 let btos b = if b then "@Uradical" else E.s in
3390 let showextended = ref false in
3391 let leave mode
_ = state
.mode
<- mode
in
3394 val mutable m_l
= []
3395 val mutable m_a
= E.a
3396 val mutable m_prev_uioh
= nouioh
3397 val mutable m_prev_mode
= View
3399 inherit lvsourcebase
3401 method reset prev_mode prev_uioh
=
3402 m_a
<- Array.of_list
(List.rev m_l
);
3404 m_prev_mode
<- prev_mode
;
3405 m_prev_uioh
<- prev_uioh
;
3407 method int name get
set =
3409 (name
, `
int get
, 1, Action
(
3412 try set (int_of_string
s)
3414 state
.text <- Printf.sprintf
"bad integer `%s': %s"
3418 let te = name ^
": ", E.s, None
, intentry, ondone, true in
3419 state
.mode
<- Textentry
(te, leave m_prev_mode
);
3423 method int_with_suffix name get
set =
3425 (name
, `intws get
, 1, Action
(
3428 try set (int_of_string_with_suffix
s)
3430 state
.text <- Printf.sprintf
"bad integer `%s': %s"
3435 name ^
": ", E.s, None
, intentry_with_suffix, ondone, true
3437 state
.mode
<- Textentry
(te, leave m_prev_mode
);
3441 method bool ?
(offset
=1) ?
(btos=btos) name get
set =
3443 (name
, `
bool (btos, get
), offset
, Action
(
3450 method color name get
set =
3452 (name
, `
color get
, 1, Action
(
3454 let invalid = (nan
, nan
, nan
) in
3457 try color_of_string
s
3459 state
.text <- Printf.sprintf
"bad color `%s': %s"
3466 let te = name ^
": ", E.s, None
, textentry, ondone, true in
3467 state
.text <- color_to_string
(get
());
3468 state
.mode
<- Textentry
(te, leave m_prev_mode
);
3472 method string name get
set =
3474 (name
, `
string get
, 1, Action
(
3476 let ondone s = set s in
3477 let te = name ^
": ", E.s, None
, textentry, ondone, true in
3478 state
.mode
<- Textentry
(te, leave m_prev_mode
);
3482 method colorspace name get
set =
3484 (name
, `
string get
, 1, Action
(
3488 inherit lvsourcebase
3491 m_active
<- CSTE.to_int conf
.colorspace
;
3494 method getitemcount
=
3495 Array.length
CSTE.names
3498 method exit ~uioh ~cancel ~
active ~
first ~pan
=
3499 ignore
(uioh
, first, pan
);
3500 if not cancel
then set active;
3502 method hasaction
_ = true
3506 let modehash = findkeyhash conf
"info" in
3507 coe (new listview ~zebra
:false ~helpmode
:false
3508 ~
source ~trusted
:true ~
modehash)
3511 method paxmark name get
set =
3513 (name
, `
string get
, 1, Action
(
3517 inherit lvsourcebase
3520 m_active
<- MTE.to_int conf
.paxmark
;
3523 method getitemcount
= Array.length
MTE.names
3524 method getitem
n = (MTE.names
.(n), 0)
3525 method exit ~uioh ~cancel ~
active ~
first ~pan
=
3526 ignore
(uioh
, first, pan
);
3527 if not cancel
then set active;
3529 method hasaction
_ = true
3533 let modehash = findkeyhash conf
"info" in
3534 coe (new listview ~zebra
:false ~helpmode
:false
3535 ~
source ~trusted
:true ~
modehash)
3538 method fitmodel name get
set =
3540 (name
, `
string get
, 1, Action
(
3544 inherit lvsourcebase
3547 m_active
<- FMTE.to_int conf
.fitmodel
;
3550 method getitemcount
= Array.length
FMTE.names
3551 method getitem
n = (FMTE.names
.(n), 0)
3552 method exit ~uioh ~cancel ~
active ~
first ~pan
=
3553 ignore
(uioh
, first, pan
);
3554 if not cancel
then set active;
3556 method hasaction
_ = true
3560 let modehash = findkeyhash conf
"info" in
3561 coe (new listview ~zebra
:false ~helpmode
:false
3562 ~
source ~trusted
:true ~
modehash)
3565 method caption
s offset
=
3566 m_l
<- (s, `empty
, offset
, Noaction
) :: m_l
3568 method caption2
s f offset
=
3569 m_l
<- (s, `
string f, offset
, Noaction
) :: m_l
3571 method getitemcount
= Array.length m_a
3574 let tostr = function
3575 | `
int f -> string_of_int
(f ())
3576 | `intws
f -> string_with_suffix_of_int
(f ())
3578 | `
color f -> color_to_string
(f ())
3579 | `
bool (btos, f) -> btos (f ())
3582 let name, t
, offset
, _ = m_a
.(n) in
3583 ((let s = tostr t
in
3585 then Printf.sprintf
"%s\t%s" name s
3589 method exit ~uioh ~cancel ~
active ~
first ~pan
=
3594 match m_a
.(active) with
3595 | _, _, _, Action
f -> f uioh
3596 | _, _, _, Noaction
-> uioh
3607 method hasaction
n =
3609 | _, _, _, Action
_ -> true
3610 | _, _, _, Noaction
-> false
3612 initializer m_active
<- 1
3615 let rec fillsrc prevmode prevuioh
=
3616 let sep () = src#caption
E.s 0 in
3617 let colorp name get
set =
3619 (fun () -> color_to_string
(get
()))
3622 let c = color_of_string
v in
3625 state
.text <- Printf.sprintf
"bad color `%s': %s" v @@ exntos exn
3628 let oldmode = state
.mode
in
3629 let birdseye = isbirdseye state
.mode
in
3631 src#caption
(if birdseye then "Setup (Bird's eye)" else "Setup") 0;
3633 src#
bool "presentation mode"
3634 (fun () -> conf
.presentation
)
3635 (fun v -> setpresentationmode v);
3637 src#
bool "ignore case in searches"
3638 (fun () -> conf
.icase
)
3639 (fun v -> conf
.icase
<- v);
3642 (fun () -> conf
.preload)
3643 (fun v -> conf
.preload <- v);
3645 src#
bool "highlight links"
3646 (fun () -> conf
.hlinks
)
3647 (fun v -> conf
.hlinks
<- v);
3649 src#
bool "under info"
3650 (fun () -> conf
.underinfo
)
3651 (fun v -> conf
.underinfo
<- v);
3653 src#
bool "persistent bookmarks"
3654 (fun () -> conf
.savebmarks
)
3655 (fun v -> conf
.savebmarks
<- v);
3657 src#fitmodel
"fit model"
3658 (fun () -> FMTE.to_string conf
.fitmodel
)
3659 (fun v -> reqlayout conf
.angle
(FMTE.of_int
v));
3661 src#
bool "trim margins"
3662 (fun () -> conf
.trimmargins
)
3663 (fun v -> settrim v conf
.trimfuzz
; fillsrc prevmode prevuioh
);
3665 src#
bool "persistent location"
3666 (fun () -> conf
.jumpback
)
3667 (fun v -> conf
.jumpback
<- v);
3670 src#
int "inter-page space"
3671 (fun () -> conf
.interpagespace
)
3673 conf
.interpagespace
<- n;
3674 docolumns conf
.columns
;
3676 match state
.layout with
3681 state
.maxy <- calcheight
();
3682 let y = getpagey
pageno in
3687 (fun () -> conf
.pagebias
)
3688 (fun v -> conf
.pagebias
<- v);
3690 src#
int "scroll step"
3691 (fun () -> conf
.scrollstep
)
3692 (fun n -> conf
.scrollstep
<- n);
3694 src#
int "horizontal scroll step"
3695 (fun () -> conf
.hscrollstep
)
3696 (fun v -> conf
.hscrollstep
<- v);
3698 src#
int "auto scroll step"
3700 match state
.autoscroll
with
3702 | _ -> conf
.autoscrollstep
)
3704 let n = boundastep state
.winh
n in
3705 if state
.autoscroll
<> None
3706 then state
.autoscroll
<- Some
n;
3707 conf
.autoscrollstep
<- n);
3710 (fun () -> truncate
(conf
.zoom *. 100.))
3711 (fun v -> setzoom ((float v) /. 100.));
3714 (fun () -> conf
.angle
)
3715 (fun v -> reqlayout v conf
.fitmodel
);
3717 src#
int "scroll bar width"
3718 (fun () -> conf
.scrollbw
)
3721 reshape state
.winw state
.winh
;
3724 src#
int "scroll handle height"
3725 (fun () -> conf
.scrollh
)
3726 (fun v -> conf
.scrollh
<- v;);
3728 src#
int "thumbnail width"
3729 (fun () -> conf
.thumbw
)
3731 conf
.thumbw
<- min
4096 v;
3734 leavebirdseye beye
false;
3741 let mode = state
.mode in
3742 src#
string "columns"
3744 match conf
.columns
with
3746 | Cmulti
(multi
, _) -> multicolumns_to_string multi
3747 | Csplit
(count
, _) -> "-" ^ string_of_int count
3750 let n, a, b = multicolumns_of_string
v in
3751 setcolumns mode n a b);
3754 src#caption
"Pixmap cache" 0;
3755 src#int_with_suffix
"size (advisory)"
3756 (fun () -> conf
.memlimit
)
3757 (fun v -> conf
.memlimit
<- v);
3760 (fun () -> Printf.sprintf
"%s bytes, %d tiles"
3761 (string_with_suffix_of_int state
.memused
)
3762 (Hashtbl.length state
.tilemap
)) 1;
3765 src#caption
"Layout" 0;
3766 src#caption2
"Dimension"
3768 Printf.sprintf
"%dx%d (virtual %dx%d)"
3769 state
.winw state
.winh
3774 src#caption2
"Position" (fun () ->
3775 Printf.sprintf
"%dx%d" state
.x state
.y
3778 src#caption2
"Position" (fun () -> describe_location ()) 1
3782 src#
bool ~offset
:0 ~
btos:(fun v -> if v then "(on)" else "(off)")
3783 "Save these parameters as global defaults at exit"
3784 (fun () -> conf
.bedefault
)
3785 (fun v -> conf
.bedefault
<- v)
3789 let btos b = if b then "@Ulguillemet" else "@Urguillemet" in
3790 src#
bool ~offset
:0 ~
btos "Extended parameters"
3791 (fun () -> !showextended)
3792 (fun v -> showextended := v; fillsrc prevmode prevuioh
);
3796 (fun () -> conf
.checkers
)
3797 (fun v -> conf
.checkers
<- v; setcheckers v);
3798 src#
bool "update cursor"
3799 (fun () -> conf
.updatecurs
)
3800 (fun v -> conf
.updatecurs
<- v);
3801 src#
bool "scroll-bar on the left"
3802 (fun () -> conf
.leftscroll
)
3803 (fun v -> conf
.leftscroll
<- v);
3805 (fun () -> conf
.verbose
)
3806 (fun v -> conf
.verbose
<- v);
3807 src#
bool "invert colors"
3808 (fun () -> conf
.invert
)
3809 (fun v -> conf
.invert
<- v);
3811 (fun () -> conf
.maxhfit
)
3812 (fun v -> conf
.maxhfit
<- v);
3814 (fun () -> conf
.pax
!= None
)
3817 then conf
.pax
<- Some
(ref (now
(), 0, 0))
3818 else conf
.pax
<- None
);
3819 src#
string "uri launcher"
3820 (fun () -> conf
.urilauncher
)
3821 (fun v -> conf
.urilauncher
<- v);
3822 src#
string "path launcher"
3823 (fun () -> conf
.pathlauncher
)
3824 (fun v -> conf
.pathlauncher
<- v);
3825 src#
string "tile size"
3826 (fun () -> Printf.sprintf
"%dx%d" conf
.tilew conf
.tileh
)
3829 let w, h = Scanf.sscanf
v "%dx%d" (fun w h -> w, h) in
3830 conf
.tilew
<- max
64 w;
3831 conf
.tileh
<- max
64 h;
3834 state
.text <- Printf.sprintf
"bad tile size `%s': %s"
3837 src#
int "texture count"
3838 (fun () -> conf
.texcount
)
3841 then conf
.texcount
<- v
3842 else impmsg "failed to set texture count please retry later"
3844 src#
int "slice height"
3845 (fun () -> conf
.sliceheight
)
3847 conf
.sliceheight
<- v;
3848 wcmd "sliceh %d" conf
.sliceheight
;
3850 src#
int "anti-aliasing level"
3851 (fun () -> conf
.aalevel
)
3853 conf
.aalevel
<- bound
v 0 8;
3854 state
.anchor <- getanchor
();
3855 opendoc state
.path state
.password;
3857 src#
string "page scroll scaling factor"
3858 (fun () -> string_of_float conf
.pgscale)
3861 let s = float_of_string
v in
3864 state
.text <- Printf.sprintf
3865 "bad page scroll scaling factor `%s': %s" v @@ exntos exn
3868 src#
int "ui font size"
3869 (fun () -> fstate
.fontsize
)
3870 (fun v -> setfontsize (bound
v 5 100));
3871 src#
int "hint font size"
3872 (fun () -> conf
.hfsize
)
3873 (fun v -> conf
.hfsize
<- bound
v 5 100);
3874 colorp "background color"
3875 (fun () -> conf
.bgcolor
)
3876 (fun v -> conf
.bgcolor
<- v; setbgcol v);
3877 src#
bool "crop hack"
3878 (fun () -> conf
.crophack
)
3879 (fun v -> conf
.crophack
<- v);
3880 src#
string "trim fuzz"
3881 (fun () -> irect_to_string conf
.trimfuzz
)
3884 conf
.trimfuzz
<- irect_of_string
v;
3886 then settrim true conf
.trimfuzz
;
3888 state
.text <- Printf.sprintf
"bad irect `%s': %s" v @@ exntos exn
3890 src#
string "throttle"
3892 match conf
.maxwait
with
3893 | None
-> "show place holder if page is not ready"
3896 then "wait for page to fully render"
3898 "wait " ^ string_of_float
time
3899 ^
" seconds before showing placeholder"
3903 let f = float_of_string
v in
3905 then conf
.maxwait
<- None
3906 else conf
.maxwait
<- Some
f
3908 state
.text <- Printf.sprintf
"bad time `%s': %s" v @@ exntos exn
3910 src#
string "ghyll scroll"
3912 match conf
.ghyllscroll
with
3914 | Some nab
-> ghyllscroll_to_string nab
3917 try conf
.ghyllscroll
<- ghyllscroll_of_string
v
3920 state
.text <- Printf.sprintf
"bad ghyll `%s': %s" v msg
3922 state
.text <- Printf.sprintf
"bad ghyll `%s': %s" v @@ exntos exn
3924 src#
string "selection command"
3925 (fun () -> conf
.selcmd
)
3926 (fun v -> conf
.selcmd
<- v);
3927 src#
string "synctex command"
3928 (fun () -> conf
.stcmd
)
3929 (fun v -> conf
.stcmd
<- v);
3930 src#
string "pax command"
3931 (fun () -> conf
.paxcmd
)
3932 (fun v -> conf
.paxcmd
<- v);
3933 src#
string "ask password command"
3934 (fun () -> conf
.passcmd)
3935 (fun v -> conf
.passcmd <- v);
3936 src#
string "save path command"
3937 (fun () -> conf
.savecmd
)
3938 (fun v -> conf
.savecmd
<- v);
3939 src#colorspace
"color space"
3940 (fun () -> CSTE.to_string conf
.colorspace
)
3942 conf
.colorspace
<- CSTE.of_int
v;
3946 src#paxmark
"pax mark method"
3947 (fun () -> MTE.to_string conf
.paxmark
)
3948 (fun v -> conf
.paxmark
<- MTE.of_int
v);
3949 if bousable
() && !opengl_has_pbo
3952 (fun () -> conf
.usepbo
)
3953 (fun v -> conf
.usepbo
<- v);
3954 src#
bool "mouse wheel scrolls pages"
3955 (fun () -> conf
.wheelbypage
)
3956 (fun v -> conf
.wheelbypage
<- v);
3957 src#
bool "open remote links in a new instance"
3958 (fun () -> conf
.riani
)
3959 (fun v -> conf
.riani
<- v);
3960 src#
bool "edit annotations inline"
3961 (fun () -> conf
.annotinline
)
3962 (fun v -> conf
.annotinline
<- v);
3963 src#
bool "coarse positioning in presentation mode"
3964 (fun () -> conf
.coarseprespos
)
3965 (fun v -> conf
.coarseprespos
<- v);
3969 src#caption
"Document" 0;
3970 List.iter
(fun (_, s) -> src#caption
s 1) state
.docinfo
;
3971 src#caption2
"Pages"
3972 (fun () -> string_of_int state
.pagecount
) 1;
3973 src#caption2
"Dimensions"
3974 (fun () -> string_of_int
(List.length state
.pdims
)) 1;
3978 src#caption
"Trimmed margins" 0;
3979 src#caption2
"Dimensions"
3980 (fun () -> string_of_int
(List.length state
.pdims
)) 1;
3984 src#caption
"OpenGL" 0;
3985 src#caption
(Printf.sprintf
"Vendor\t%s" (GlMisc.get_string `vendor
)) 1;
3986 src#caption
(Printf.sprintf
"Renderer\t%s" (GlMisc.get_string `renderer
)) 1;
3989 src#caption
"Location" 0;
3990 if nonemptystr state
.origin
3991 then src#caption
("Orign\t" ^ mbtoutf8 state
.origin
) 1;
3992 src#caption
("Path\t" ^ mbtoutf8 state
.path) 1;
3994 src#reset prevmode prevuioh
;
3999 let prevmode = state
.mode
4000 and prevuioh
= state
.uioh in
4001 fillsrc prevmode prevuioh
;
4002 let source = (src :> lvsource
) in
4003 let modehash = findkeyhash conf
"info" in
4004 state
.uioh <- coe (object (self)
4005 inherit listview ~zebra
:false ~helpmode
:false
4006 ~
source ~trusted
:true ~
modehash as super
4007 val mutable m_prevmemused
= 0
4008 method! infochanged
= function
4010 if m_prevmemused
!= state
.memused
4012 m_prevmemused
<- state
.memused
;
4013 G.postRedisplay "memusedchanged";
4015 | Pdim
-> G.postRedisplay "pdimchanged"
4016 | Docinfo
-> fillsrc prevmode prevuioh
4018 method! key key mask
=
4019 if not
(Wsi.withctrl mask
)
4022 | @left | @kpleft
-> coe (self#updownlevel ~
-1)
4023 | @right
| @kpright
-> coe (self#updownlevel
1)
4024 | _ -> super#
key key mask
4025 else super#
key key mask
4027 G.postRedisplay "info";
4033 inherit lvsourcebase
4034 method getitemcount
= Array.length state
.help
4036 let s, l, _ = state
.help
.(n) in
4039 method exit ~
uioh ~cancel ~
active ~
first ~pan
=
4043 match state
.help
.(active) with
4044 | _, _, Action
f -> Some
(f uioh)
4045 | _, _, Noaction
-> Some
uioh
4054 method hasaction
n =
4055 match state
.help
.(n) with
4056 | _, _, Action
_ -> true
4057 | _, _, Noaction
-> false
4063 let modehash = findkeyhash conf
"help" in
4065 state
.uioh <- coe (new listview
4066 ~zebra
:false ~helpmode
:true
4067 ~
source ~trusted
:true ~
modehash);
4068 G.postRedisplay "help";
4074 inherit lvsourcebase
4075 val mutable m_items
= E.a
4077 method getitemcount
= 1 + Array.length m_items
4082 else m_items
.(n-1), 0
4084 method exit ~
uioh ~cancel ~
active ~
first ~pan
=
4089 then Buffer.clear state
.errmsgs
;
4096 method hasaction
n =
4100 state
.newerrmsgs
<- false;
4101 let l = Str.split newlinere
(Buffer.contents state
.errmsgs
) in
4102 m_items
<- Array.of_list
l
4111 let source = (msgsource :> lvsource
) in
4112 let modehash = findkeyhash conf
"listview" in
4113 state
.uioh <- coe (object
4114 inherit listview ~zebra
:false ~helpmode
:false
4115 ~
source ~trusted
:false ~
modehash as super
4118 then msgsource#reset
;
4121 G.postRedisplay "msgs";
4125 let editor = getenvwithdef
"EDITOR" E.s in
4129 let tmppath = Filename.temp_file
"llpp" "note" in
4132 let oc = open_out
tmppath in
4136 let execstr = editor ^
" " ^
tmppath in
4138 match spawn
execstr [] with
4139 | (exception exn
) ->
4140 impmsg "spawn(%S) failed: %s" execstr @@ exntos exn
;
4143 match Unix.waitpid
[] pid with
4144 | (exception exn
) ->
4145 impmsg "waitpid(%d) failed: %s" pid @@ exntos exn
;
4149 | Unix.WEXITED
0 -> filecontents
tmppath
4151 impmsg "editor process(%s) exited abnormally: %d" execstr n;
4153 | Unix.WSIGNALED
n ->
4154 impmsg "editor process(%s) was killed by signal %d" execstr n;
4156 | Unix.WSTOPPED
n ->
4157 impmsg "editor(%s) process was stopped by signal %d" execstr n;
4160 match Unix.unlink
tmppath with
4161 | (exception exn
) ->
4162 impmsg "failed to ulink %S: %s" tmppath @@ exntos exn
;
4167 let enterannotmode opaque slinkindex
=
4170 inherit lvsourcebase
4171 val mutable m_text
= E.s
4172 val mutable m_items
= E.a
4174 method getitemcount
= Array.length m_items
4177 let label, _func
= m_items
.(n) in
4180 method exit ~
uioh ~cancel ~
active ~
first ~pan
=
4181 ignore
(uioh, first, pan
);
4184 let _label, func
= m_items
.(active) in
4189 method hasaction
n = nonemptystr
@@ fst m_items
.(n)
4192 let rec split accu b i
=
4194 if p = String.length
s
4195 then (String.sub
s b (p-b), unit) :: accu
4197 if (i
> 70 && s.[p] = ' '
) || s.[p] = '
\r'
|| s.[p] = '
\n'
4199 let ss = if i
= 0 then E.s else String.sub
s b i
in
4200 split ((ss, unit)::accu) (p+1) 0
4205 wcmd "freepage %s" (~
> opaque);
4207 Hashtbl.fold (fun key opaque'
accu ->
4208 if opaque'
= opaque'
4209 then key :: accu else accu) state
.pagemap
[]
4211 List.iter
(Hashtbl.remove state
.pagemap
) keys;
4216 delannot
opaque slinkindex
;
4219 let edit inline
() =
4224 modannot
opaque slinkindex
s;
4230 let mode = state
.mode in
4233 ("annotation: ", m_text
, None
, textentry, update, true),
4234 fun _ -> state
.mode <- mode);
4238 let s = getusertext m_text
in
4243 ( "[Copy]", fun () -> selstring m_text
)
4244 :: ("[Delete]", dele)
4245 :: ("[Edit]", edit conf
.annotinline
)
4247 :: split [] 0 0 |> List.rev
|> Array.of_list
4254 let s = getannotcontents
opaque slinkindex
in
4257 let source = (msgsource :> lvsource
) in
4258 let modehash = findkeyhash conf
"listview" in
4259 state
.uioh <- coe (object
4260 inherit listview ~zebra
:false ~helpmode
:false
4261 ~
source ~trusted
:false ~
modehash
4263 G.postRedisplay "enterannotmode";
4266 let gotounder under =
4267 let getpath filename
=
4269 if nonemptystr filename
4271 if Filename.is_relative filename
4273 let dir = Filename.dirname state
.path in
4275 if Filename.is_implicit
dir
4276 then Filename.concat
(Sys.getcwd
()) dir
4279 Filename.concat
dir filename
4283 if Sys.file_exists
path
4288 | Ulinkgoto
(pageno, top) ->
4293 if conf
.presentation
&& conf
.coarseprespos
4297 gotopage1 pageno top;
4300 | Ulinkuri
s -> gotouri
s
4302 | Uremote
(filename
, pageno) ->
4303 let path = getpath filename
in
4308 let command = Printf.sprintf
"%s -page %d %S" !selfexec pageno path in
4309 match spawn
command [] with
4311 | (exception exn
) ->
4312 dolog
"failed to execute `%s': %s" command @@ exntos exn
4314 let anchor = getanchor
() in
4315 let ranchor = state
.path, state
.password, anchor, state
.origin
in
4316 state
.origin
<- E.s;
4317 state
.anchor <- (pageno, 0.0, 0.0);
4318 state
.ranchors
<- ranchor :: state
.ranchors
;
4321 else impmsg "cannot find %s" filename
4323 | Uremotedest
(filename
, destname
) ->
4324 let path = getpath filename
in
4329 let command = !selfexec ^
" " ^
path ^
" -dest " ^ destname
in
4330 match spawn
command [] with
4331 | (exception exn
) ->
4332 dolog
"failed to execute `%s': %s" command @@ exntos exn
4335 let anchor = getanchor
() in
4336 let ranchor = state
.path, state
.password, anchor, state
.origin
in
4337 state
.origin
<- E.s;
4338 state
.nameddest
<- destname
;
4339 state
.ranchors
<- ranchor :: state
.ranchors
;
4342 else impmsg "cannot find %s" filename
4344 | Uunexpected
_ | Ulaunch
_ | Unamed
_ | Utext
_ | Unone
-> ()
4345 | Uannotation
(opaque, slinkindex
) -> enterannotmode opaque slinkindex
4348 let gotooutline (_, _, kind
) =
4352 let (pageno, y, _) = anchor in
4354 (if conf
.presentation
then (pageno, y, 1.0) else anchor)
4358 | Ouri
uri -> gotounder (Ulinkuri
uri)
4359 | Olaunch cmd
-> gotounder (Ulaunch cmd
)
4360 | Oremote remote
-> gotounder (Uremote remote
)
4361 | Ohistory hist
-> gotohist hist
4362 | Oremotedest remotedest
-> gotounder (Uremotedest remotedest
)
4365 class outlinesoucebase fetchoutlines
= object (self)
4366 inherit lvsourcebase
4367 val mutable m_items
= E.a
4368 val mutable m_minfo
= E.a
4369 val mutable m_orig_items
= E.a
4370 val mutable m_orig_minfo
= E.a
4371 val mutable m_narrow_patterns
= []
4372 val mutable m_gen
= -1
4374 method getitemcount
= Array.length m_items
4377 let s, n, _ = m_items
.(n) in
4380 method exit ~
(uioh:uioh) ~cancel ~
active ~
(first:int) ~pan
:
4382 ignore
(uioh, first);
4384 if m_narrow_patterns
= []
4385 then m_orig_items
, m_orig_minfo
4386 else m_items
, m_minfo
4393 gotooutline m_items
.(active);
4401 method hasaction
(_:int) = true
4404 if Array.length m_items
!= Array.length m_orig_items
4407 match m_narrow_patterns
with
4409 | many
-> String.concat
"@Uellipsis" (List.rev many
)
4411 "Narrowed to " ^
s ^
" (ctrl-u to restore)"
4415 match m_narrow_patterns
with
4418 | head
:: _ -> "@Uellipsis" ^ head
4420 method narrow
pattern =
4421 match Str.regexp_case_fold
pattern with
4422 | (exception _) -> ()
4424 let rec loop accu minfo n =
4427 m_items
<- Array.of_list
accu;
4428 m_minfo
<- Array.of_list
minfo;
4431 let (s, _, _) as o = m_items
.(n) in
4433 match Str.search_forward re
s 0 with
4434 | (exception Not_found
) -> accu, minfo
4435 | first -> o :: accu, (first, Str.match_end
()) :: minfo
4437 loop accu minfo (n-1)
4439 loop [] [] (Array.length m_items
- 1)
4441 method! getminfo
= m_minfo
4444 m_orig_items
<- fetchoutlines
();
4445 m_minfo
<- m_orig_minfo
;
4446 m_items
<- m_orig_items
4448 method add_narrow_pattern
pattern =
4449 m_narrow_patterns
<- pattern :: m_narrow_patterns
4451 method del_narrow_pattern
=
4452 match m_narrow_patterns
with
4453 | _ :: rest
-> m_narrow_patterns
<- rest
4458 match m_narrow_patterns
with
4459 | pattern :: [] -> self#narrow
pattern; pattern
4461 List.fold_left
(fun accu pattern ->
4462 self#narrow
pattern;
4463 pattern ^
"@Uellipsis" ^
accu) E.s list
4465 method calcactive
(_:anchor) = 0
4467 method reset
anchor items =
4468 if state
.gen
!= m_gen
4470 m_orig_items
<- items;
4472 m_narrow_patterns
<- [];
4474 m_orig_minfo
<- E.a;
4478 if items != m_orig_items
4480 m_orig_items
<- items;
4481 if m_narrow_patterns
== []
4482 then m_items
<- items;
4485 let active = self#calcactive
anchor in
4487 m_first
<- firstof m_first
active
4491 let outlinesource fetchoutlines
=
4493 inherit outlinesoucebase fetchoutlines
4494 method! calcactive
anchor =
4495 let rely = getanchory anchor in
4496 let rec loop n best bestd
=
4497 if n = Array.length m_items
4500 let _, _, kind
= m_items
.(n) in
4503 let orely = getanchory anchor in
4504 let d = abs
(orely - rely) in
4507 else loop (n+1) best bestd
4508 | Onone
| Oremote
_ | Olaunch
_
4509 | Oremotedest
_ | Ouri
_ | Ohistory
_ ->
4510 loop (n+1) best bestd
4516 let enteroutlinemode, enterbookmarkmode
, enterhistmode
=
4517 let mkselector sourcetype
=
4518 let fetchoutlines () =
4519 match sourcetype
with
4520 | `bookmarks
-> Array.of_list state
.bookmarks
4521 | `outlines
-> state
.outlines
4522 | `history
-> genhistoutlines ()
4525 if sourcetype
= `history
4526 then new outlinesoucebase
fetchoutlines
4527 else outlinesource fetchoutlines
4530 let outlines = fetchoutlines () in
4531 if Array.length
outlines = 0
4533 showtext ' ' errmsg
;
4537 Wsi.setcursor
Wsi.CURSOR_INHERIT
;
4538 let anchor = getanchor
() in
4539 source#reset
anchor outlines;
4540 state
.text <- source#greetmsg
;
4542 coe (new outlinelistview ~zebra
:(sourcetype
=`history
) ~
source);
4543 G.postRedisplay "enter selector";
4546 let mkenter sourcetype errmsg
=
4547 let enter = mkselector sourcetype
in
4548 fun () -> enter errmsg
4550 (**)mkenter `
outlines "document has no outline"
4551 , mkenter `bookmarks
"document has no bookmarks (yet)"
4552 , mkenter `history
"history is empty"
4555 let quickbookmark ?title
() =
4556 match state
.layout with
4562 let tm = Unix.localtime
(now
()) in
4564 "Quick (page %d) (bookmarked at %02d/%02d/%d %02d:%02d)"
4568 (tm.Unix.tm_year
+ 1900)
4571 | Some
title -> title
4573 state
.bookmarks
<- (title, 0, Oanchor
(getanchor1
l)) :: state
.bookmarks
4576 let setautoscrollspeed step goingdown
=
4577 let incr = max
1 ((abs step
) / 2) in
4578 let incr = if goingdown
then incr else -incr in
4579 let astep = boundastep state
.winh
(step
+ incr) in
4580 state
.autoscroll
<- Some
astep;
4584 match conf
.columns
with
4586 | Csingle
_ | Cmulti
_ -> state
.x != 0 || conf
.zoom > 1.0
4589 let panbound x = bound
x (-state
.w) (wadjsb () + state
.winw
);;
4591 let existsinrow pageno (columns
, coverA
, coverB
) p =
4592 let last = ((pageno - coverA
) mod columns
) + columns
in
4593 let rec any = function
4596 if l.pageno = coverA
- 1 || l.pageno = state
.pagecount
- coverB
4600 then (if l.pageno = last then false else any rest
)
4608 match state
.layout with
4610 let pageno = page_of_y state
.y in
4611 gotoghyll (getpagey
(pageno+1))
4613 match conf
.columns
with
4615 if conf
.presentation
&& rest
== [] && l.pageh
> l.pagey + l.pagevh
4617 let y = clamp (pgscale state
.winh
) in
4620 let pageno = min
(l.pageno+1) (state
.pagecount
-1) in
4621 gotoghyll (getpagey
pageno)
4622 | Cmulti
((c, _, _) as cl
, _) ->
4623 if conf
.presentation
4624 && (existsinrow l.pageno cl
4625 (fun l -> l.pageh
> l.pagey + l.pagevh))
4627 let y = clamp (pgscale state
.winh
) in
4630 let pageno = min
(l.pageno+c) (state
.pagecount
-1) in
4631 gotoghyll (getpagey
pageno)
4633 if l.pageno < state
.pagecount
- 1 || l.pagecol
< n - 1
4635 let pagey, pageh
= getpageyh
l.pageno in
4636 let pagey = pagey + pageh
* l.pagecol
in
4637 let ips = if l.pagecol
= 0 then 0 else conf
.interpagespace
in
4638 gotoghyll (pagey + pageh
+ ips)
4642 match state
.layout with
4644 let pageno = page_of_y state
.y in
4645 gotoghyll (getpagey
(pageno-1))
4647 match conf
.columns
with
4649 if conf
.presentation
&& l.pagey != 0
4651 gotoghyll (clamp (pgscale ~
-(state
.winh
)))
4653 let pageno = max
0 (l.pageno-1) in
4654 gotoghyll (getpagey
pageno)
4655 | Cmulti
((c, _, coverB
) as cl
, _) ->
4656 if conf
.presentation
&&
4657 (existsinrow l.pageno cl
(fun l -> l.pagey != 0))
4659 gotoghyll (clamp (pgscale ~
-(state
.winh
)))
4662 if l.pageno = state
.pagecount
- coverB
4666 let pageno = max
0 (l.pageno-decr) in
4667 gotoghyll (getpagey
pageno)
4675 let pageno = max
0 (l.pageno-1) in
4676 let pagey, pageh
= getpageyh
pageno in
4679 let pagey, pageh
= getpageyh
l.pageno in
4680 pagey + pageh
* (l.pagecol
-1) - conf
.interpagespace
4686 if emptystr conf
.savecmd
4687 then error
"don't know where to save modified document"
4689 let savecmd = Str.global_replace percentsre state
.path conf
.savecmd in
4692 (fun s -> error
"failed to obtain path to the saved copy: %s" s)
4697 let tmp = path ^
".tmp" in
4699 Unix.rename
tmp path;
4702 let viewkeyboard key mask
=
4704 let mode = state
.mode in
4705 state
.mode <- Textentry
(te, fun _ -> state
.mode <- mode);
4708 G.postRedisplay "view:enttext"
4710 let ctrl = Wsi.withctrl mask
in
4711 let key = Wsi.keypadtodigitkey
key in
4716 if hasunsavedchanges
()
4720 if conf
.angle
mod 360 = 0 && not
(isbirdseye state
.mode)
4722 state
.mode <- LinkNav
(Ltgendir
0);
4725 else impmsg "keyboard link navigation does not work under rotation"
4728 begin match state
.mstate
with
4731 G.postRedisplay "kill rect";
4734 | Mscrolly
| Mscrollx
4737 begin match state
.mode with
4740 G.postRedisplay "esc leave linknav"
4744 match state
.ranchors
with
4746 | (path, password, anchor, origin
) :: rest
->
4747 state
.ranchors
<- rest
;
4748 state
.anchor <- anchor;
4749 state
.origin
<- origin
;
4750 state
.nameddest
<- E.s;
4751 opendoc path password
4756 gotoghyll (getnav ~
-1)
4767 Hashtbl.iter
(fun _ opaque ->
4769 Hashtbl.clear state
.prects
) state
.pagemap
;
4770 G.postRedisplay "dehighlight";
4772 | @slash
| @question
->
4773 let ondone isforw
s =
4774 cbput state
.hists
.pat
s;
4775 state
.searchpattern
<- s;
4778 let s = String.make
1 (Char.chr
key) in
4779 enttext (s, E.s, Some
(onhist state
.hists
.pat
),
4780 textentry, ondone (key = @slash
), true)
4782 | @plus
| @kpplus
| @equals
when ctrl ->
4783 let incr = if conf
.zoom +. 0.01 > 0.1 then 0.1 else 0.01 in
4784 setzoom (conf
.zoom +. incr)
4786 | @plus
| @kpplus
->
4789 try int_of_string
s with exn
->
4790 state
.text <- Printf.sprintf
"bad integer `%s': %s" s @@ exntos exn
;
4796 state
.text <- "page bias is now " ^ string_of_int
n;
4799 enttext ("page bias: ", E.s, None
, intentry, ondone, true)
4801 | @minus
| @kpminus
when ctrl ->
4802 let decr = if conf
.zoom -. 0.1 < 0.1 then 0.01 else 0.1 in
4803 setzoom (max
0.01 (conf
.zoom -. decr))
4805 | @minus
| @kpminus
->
4806 let ondone msg
= state
.text <- msg
in
4808 "option [acfhilpstvxACFPRSZTISM]: ", E.s, None
,
4809 optentry state
.mode, ondone, true
4820 | (@1 | @2) when ctrl && conf
.fitmodel
!= FitPage
-> (* ctrl-1/2 *)
4822 match conf
.columns
with
4823 | Csingle
_ | Cmulti
_ -> 1
4824 | Csplit
(n, _) -> n
4826 let h = state
.winh
-
4827 conf
.interpagespace
lsl (if conf
.presentation
then 1 else 0)
4829 let zoom = zoomforh state
.winw
h (vscrollw ()) cols in
4830 if zoom > 0.0 && (key = @2 || zoom < 1.0)
4835 match conf
.fitmodel
with
4836 | FitWidth
-> FitProportional
4837 | FitProportional
-> FitPage
4838 | FitPage
-> FitWidth
4840 state
.text <- "fit model: " ^
FMTE.to_string
fm;
4841 reqlayout conf
.angle
fm
4843 | @4 when ctrl -> (* ctrl-4 *)
4844 let zoom = getmaxw
() /. float state
.winw
in
4845 if zoom > 0.0 then setzoom zoom
4853 | (48 | 49 | 50 | 51 | 52 | 53 | 54 | 55 | 56 | 57)
4854 when not
ctrl -> (* 0..9 *)
4857 try int_of_string
s with exn
->
4858 state
.text <- Printf.sprintf
"bad integer `%s': %s" s @@ exntos exn
;
4864 cbput state
.hists
.pag
(string_of_int
n);
4865 gotopage1 (n + conf
.pagebias
- 1) 0;
4868 let pageentry text key =
4869 match Char.unsafe_chr
key with
4870 | '
g'
-> TEdone
text
4871 | _ -> intentry text key
4873 let text = String.make
1 (Char.chr
key) in
4874 enttext (":", text, Some
(onhist state
.hists
.pag
),
4875 pageentry, ondone, true)
4878 conf
.scrollb
<- if conf
.scrollb
= 0 then (scrollbvv
lor scrollbhv
) else 0;
4879 reshape state
.winw state
.winh
;
4882 state
.bzoom
<- not state
.bzoom
;
4884 showtext ' '
("block zoom " ^
if state
.bzoom
then "on" else "off")
4887 conf
.hlinks
<- not conf
.hlinks
;
4888 state
.text <- "highlightlinks " ^
if conf
.hlinks
then "on" else "off";
4889 G.postRedisplay "toggle highlightlinks";
4892 if conf
.angle
mod 360 = 0
4894 state
.glinks
<- true;
4895 let mode = state
.mode in
4898 (":", E.s, None
, linknentry, linknact gotounder, false),
4900 state
.glinks
<- false;
4904 G.postRedisplay "view:linkent(F)"
4906 else impmsg "hint mode does not work under rotation"
4909 state
.glinks
<- true;
4910 let mode = state
.mode in
4911 state
.mode <- Textentry
(
4913 ":", E.s, None
, linknentry, linknact (fun under ->
4914 selstring (undertext under);
4918 state
.glinks
<- false;
4922 G.postRedisplay "view:linkent"
4925 begin match state
.autoscroll
with
4927 conf
.autoscrollstep
<- step
;
4928 state
.autoscroll
<- None
4930 if conf
.autoscrollstep
= 0
4931 then state
.autoscroll
<- Some
1
4932 else state
.autoscroll
<- Some conf
.autoscrollstep
4936 launchpath () (* XXX where do error messages go? *)
4939 setpresentationmode (not conf
.presentation
);
4940 showtext ' '
("presentation mode " ^
4941 if conf
.presentation
then "on" else "off");
4944 if List.mem
Wsi.Fullscreen state
.winstate
4945 then Wsi.reshape conf
.cwinw conf
.cwinh
4946 else Wsi.fullscreen
()
4949 search state
.searchpattern
false
4952 search state
.searchpattern
true
4955 begin match state
.layout with
4958 gotoghyll (getpagey
l.pageno)
4964 | @delete
| @kpdelete
-> (* delete *)
4968 showtext ' '
(describe_location ());
4971 begin match state
.layout with
4974 Wsi.reshape (l.pagew
+ vscrollw ()) l.pageh
;
4979 enterbookmarkmode
()
4987 | @e when Buffer.length state
.errmsgs
> 0 ->
4992 match state
.layout with
4997 (s, 0, Oanchor
(getanchor1
l)) :: state
.bookmarks
5000 enttext ("bookmark: ", E.s, None
, textentry, ondone, true)
5004 showtext ' '
"Quick bookmark added";
5007 begin match state
.layout with
5009 let rect = getpdimrect
l.pagedimno
in
5013 (truncate
(1.8 *. (rect.(1) -. rect.(0))),
5014 truncate
(1.2 *. (rect.(3) -. rect.(0))))
5016 (truncate
(rect.(1) -. rect.(0)),
5017 truncate
(rect.(3) -. rect.(0)))
5019 let w = truncate
((float w)*.conf
.zoom)
5020 and h = truncate
((float h)*.conf
.zoom) in
5023 state
.anchor <- getanchor
();
5024 Wsi.reshape (w + vscrollw ()) (h + conf
.interpagespace
)
5026 G.postRedisplay "z";
5031 | @x -> state
.roam
()
5034 reqlayout (conf
.angle
+
5035 (if key = @Gt
then 30 else -30)) conf
.fitmodel
5039 bound
(conf
.colorscale
+. (if key = 93 then 0.1 else -0.1)) 0.0 1.0
5041 G.postRedisplay "brightness";
5043 | @c when state
.mode = View
->
5048 let m = (wadjsb () + state
.winw
- state
.w) / 2 in
5050 gotoy_and_clear_text state
.y
5054 match state
.prevcolumns
with
5055 | None
-> (1, 0, 0), 1.0
5056 | Some
(columns
, z
) ->
5059 | Csplit
(c, _) -> -c, 0, 0
5060 | Cmulti
((c, a, b), _) -> c, a, b
5061 | Csingle
_ -> 1, 0, 0
5065 setcolumns View
c a b;
5068 | @down
| @up
when ctrl && Wsi.withshift mask
->
5069 let zoom, x = state
.prevzoom
in
5073 | @k
| @up
| @kpup
->
5074 begin match state
.autoscroll
with
5076 begin match state
.mode with
5077 | Birdseye beye
-> upbirdseye 1 beye
5082 then gotoy_and_clear_text (clamp ~
-(state
.winh
/2))
5084 if not
(Wsi.withshift mask
) && conf
.presentation
5086 else gotoghyll1 true (clamp (-conf
.scrollstep
))
5090 setautoscrollspeed n false
5093 | @j
| @down
| @kpdown
->
5094 begin match state
.autoscroll
with
5096 begin match state
.mode with
5097 | Birdseye beye
-> downbirdseye 1 beye
5102 then gotoy_and_clear_text (clamp (state
.winh
/2))
5104 if not
(Wsi.withshift mask
) && conf
.presentation
5106 else gotoghyll1 true (clamp (conf
.scrollstep
))
5110 setautoscrollspeed n true
5113 | @left | @right
| @kpleft
| @kpright
when not
(Wsi.withalt mask
) ->
5119 else conf
.hscrollstep
5121 let dx = if key = @left || key = @kpleft
then dx else -dx in
5122 state
.x <- panbound (state
.x + dx);
5123 gotoy_and_clear_text state
.y
5126 G.postRedisplay "left/right"
5129 | @prior
| @kpprior
->
5133 match state
.layout with
5135 | l :: _ -> state
.y - l.pagey
5137 clamp (pgscale (-state
.winh
))
5141 | @next | @kpnext
->
5145 match List.rev state
.layout with
5147 | l :: _ -> getpagey
l.pageno
5149 clamp (pgscale state
.winh
)
5153 | @g | @home
| @kphome
->
5156 | @G
| @jend
| @kpend
->
5158 gotoghyll (clamp state
.maxy)
5160 | @right
| @kpright
when Wsi.withalt mask
->
5161 gotoghyll (getnav 1)
5162 | @left | @kpleft
when Wsi.withalt mask
->
5163 gotoghyll (getnav ~
-1)
5168 | @v when conf
.debug
->
5171 match getopaque l.pageno with
5174 let x0, y0, x1, y1 = pagebbox
opaque in
5175 let rect = (float x0, float y0,
5178 float x0, float y1) in
5180 let color = (0.0, 0.0, 1.0 /. (l.pageno mod 3 |> float), 0.5) in
5181 state
.rects
<- (l.pageno, color, rect) :: state
.rects
;
5183 G.postRedisplay "v";
5186 let mode = state
.mode in
5187 let cmd = ref E.s in
5188 let onleave = function
5189 | Cancel
-> state
.mode <- mode
5192 match getopaque l.pageno with
5193 | Some
opaque -> pipesel opaque !cmd
5194 | None
-> ()) state
.layout;
5198 cbput state
.hists
.sel
s;
5202 "| ", !cmd, Some
(onhist state
.hists
.sel
), textentry, ondone, true
5204 G.postRedisplay "|";
5205 state
.mode <- Textentry
(te, onleave);
5208 vlog "huh? %s" (Wsi.keyname
key)
5211 let linknavkeyboard key mask
linknav =
5212 let getpage pageno =
5213 let rec loop = function
5215 | l :: _ when l.pageno = pageno -> Some
l
5216 | _ :: rest
-> loop rest
5217 in loop state
.layout
5219 let doexact (pageno, n) =
5220 match getopaque pageno, getpage pageno with
5221 | Some
opaque, Some
l ->
5222 if key = @enter || key = @kpenter
5224 let under = getlink
opaque n in
5225 G.postRedisplay "link gotounder";
5232 Some
(findlink
opaque LDfirst
), -1
5235 Some
(findlink
opaque LDlast
), 1
5238 Some
(findlink
opaque (LDleft
n)), -1
5241 Some
(findlink
opaque (LDright
n)), 1
5244 Some
(findlink
opaque (LDup
n)), -1
5247 Some
(findlink
opaque (LDdown
n)), 1
5252 begin match findpwl
l.pageno dir with
5256 state
.mode <- LinkNav
(Ltgendir
dir);
5257 let y, h = getpageyh
pageno in
5260 then y + h - state
.winh
5265 begin match getopaque pageno, getpage pageno with
5266 | Some
opaque, Some
_ ->
5268 let ld = if dir > 0 then LDfirst
else LDlast
in
5271 begin match link with
5273 showlinktype (getlink
opaque m);
5274 state
.mode <- LinkNav
(Ltexact
(pageno, m));
5275 G.postRedisplay "linknav jpage";
5276 | Lnotfound
-> notfound dir
5282 begin match opt with
5283 | Some Lnotfound
-> pwl l dir;
5284 | Some
(Lfound
m) ->
5288 let _, y0, _, y1 = getlinkrect
opaque m in
5290 then gotopage1 l.pageno y0
5292 let d = fstate
.fontsize
+ 1 in
5293 if y1 - l.pagey > l.pagevh - d
5294 then gotopage1 l.pageno (y1 - state
.winh
- hscrollh () + d)
5295 else G.postRedisplay "linknav";
5297 showlinktype (getlink
opaque m);
5298 state
.mode <- LinkNav
(Ltexact
(l.pageno, m));
5301 | None
-> viewkeyboard key mask
5303 | _ -> viewkeyboard key mask
5308 G.postRedisplay "leave linknav"
5312 | Ltgendir
_ | Ltnotready
_ -> viewkeyboard key mask
5313 | Ltexact exact
-> doexact exact
5316 let keyboard key mask
=
5317 if (key = @g && Wsi.withctrl mask
) && not
(istextentry state
.mode)
5318 then wcmd "interrupt"
5319 else state
.uioh <- state
.uioh#
key key mask
5322 let birdseyekeyboard key mask
5323 ((oconf
, leftx
, pageno, hooverpageno
, anchor) as beye
) =
5325 match conf
.columns
with
5327 | Cmulti
((c, _, _), _) -> c
5328 | Csplit
_ -> failwith
"bird's eye split mode"
5330 let pgh layout = List.fold_left
5331 (fun m l -> max
l.pageh
m) state
.winh
layout in
5333 | @l when Wsi.withctrl mask
->
5334 let y, h = getpageyh
pageno in
5335 let top = (state
.winh
- h) / 2 in
5336 gotoy (max
0 (y - top))
5337 | @enter | @kpenter
-> leavebirdseye beye
false
5338 | @escape
-> leavebirdseye beye
true
5339 | @up
-> upbirdseye incr beye
5340 | @down
-> downbirdseye incr beye
5341 | @left -> upbirdseye 1 beye
5342 | @right
-> downbirdseye 1 beye
5345 begin match state
.layout with
5349 state
.mode <- Birdseye
(
5350 oconf
, leftx
, l.pageno, hooverpageno
, anchor
5352 gotopage1 l.pageno 0;
5355 let layout = layout state
.x (state
.y-state
.winh
)
5357 (pgh state
.layout) in
5359 | [] -> gotoy (clamp (-state
.winh
))
5361 state
.mode <- Birdseye
(
5362 oconf
, leftx
, l.pageno, hooverpageno
, anchor
5364 gotopage1 l.pageno 0
5367 | [] -> gotoy (clamp (-state
.winh
))
5371 begin match List.rev state
.layout with
5373 let layout = layout state
.x
5374 (state
.y + (pgh state
.layout))
5375 state
.winw state
.winh
in
5376 begin match layout with
5378 let incr = l.pageh
- l.pagevh in
5383 oconf
, leftx
, state
.pagecount
- 1, hooverpageno
, anchor
5385 G.postRedisplay "birdseye pagedown";
5387 else gotoy (clamp (incr + conf
.interpagespace
*2));
5391 Birdseye
(oconf
, leftx
, l.pageno, hooverpageno
, anchor);
5392 gotopage1 l.pageno 0;
5395 | [] -> gotoy (clamp state
.winh
)
5399 state
.mode <- Birdseye
(oconf
, leftx
, 0, hooverpageno
, anchor);
5403 let pageno = state
.pagecount
- 1 in
5404 state
.mode <- Birdseye
(oconf
, leftx
, pageno, hooverpageno
, anchor);
5405 if not
(pagevisible state
.layout pageno)
5408 match List.rev state
.pdims
with
5410 | (_, _, h, _) :: _ -> h
5412 gotoy (max
0 (getpagey
pageno - (state
.winh
- h - conf
.interpagespace
)))
5413 else G.postRedisplay "birdseye end";
5415 | _ -> viewkeyboard key mask
5420 match state
.mode with
5421 | Textentry
_ -> scalecolor 0.4
5423 | View
-> scalecolor 1.0
5424 | Birdseye
(_, _, pageno, hooverpageno
, _) ->
5425 if l.pageno = hooverpageno
5428 if l.pageno = pageno
5430 let c = scalecolor 1.0 in
5432 GlDraw.line_width
3.0;
5433 let dispx = xadjsb () + l.pagedispx in
5435 (float (dispx-1)) (float (l.pagedispy-1))
5436 (float (dispx+l.pagevw+1))
5437 (float (l.pagedispy+l.pagevh+1))
5439 GlDraw.line_width
1.0;
5448 let postdrawpage l linkindexbase
=
5449 match getopaque l.pageno with
5451 if tileready l l.pagex
l.pagey
5453 let x = l.pagedispx - l.pagex
+ xadjsb ()
5454 and y = l.pagedispy - l.pagey in
5456 match conf
.columns
with
5457 | Csingle
_ | Cmulti
_ ->
5458 (if conf
.hlinks
then 1 else 0)
5460 && not
(isbirdseye state
.mode) then 2 else 0)
5464 match state
.mode with
5465 | Textentry
((_, s, _, _, _, _), _) when state
.glinks
-> s
5471 Hashtbl.find_all state
.prects
l.pageno |>
5472 List.iter
(fun vals
-> drawprect
opaque x y vals
);
5473 let n = postprocess
opaque hlmask x y (linkindexbase
, s, conf
.hfsize
) in
5475 then (state
.redisplay
<- true; 0)
5481 let scrollindicator () =
5482 let sbw, ph
, sh = state
.uioh#
scrollph in
5483 let sbh, pw, sw = state
.uioh#scrollpw
in
5488 else ((state
.winw
- sbw), state
.winw
, 0)
5491 GlDraw.color (0.64, 0.64, 0.64);
5492 filledrect (float x0) 0. (float x1) (float state
.winh
);
5494 (float hx0
) (float (state
.winh
- sbh))
5495 (float (hx0
+ wadjsb () + state
.winw
)) (float state
.winh
)
5497 GlDraw.color (0.0, 0.0, 0.0);
5499 filledrect (float x0) ph
(float x1) (ph
+. sh);
5500 let pw = pw +. float hx0
in
5501 filledrect pw (float (state
.winh
- sbh)) (pw +. sw) (float state
.winh
);
5505 match state
.mstate
with
5506 | Mnone
| Mscrolly
| Mscrollx
| Mpan
_ | Mzoom
_ | Mzoomrect
_ ->
5509 | Msel
((x0, y0), (x1, y1)) ->
5510 let identify opaque l px py = Some
(opaque, l.pageno, px, py) in
5511 let o0,n0
,px0
,py0
= onppundermouse identify x0 y0 (~
< E.s, -1, 0, 0) in
5512 let _o1,n1
,px1
,py1
= onppundermouse identify x1 y1 (~
< E.s, -1, 0, 0) in
5513 if n0
!= -1 && n0
= n1
then seltext
o0 (px0
, py0
, px1
, py1
);
5516 let showrects = function [] -> () | rects
->
5518 GlDraw.color (0.0, 0.0, 1.0) ~
alpha:0.5;
5519 GlFunc.blend_func ~
src:`src_alpha ~dst
:`one_minus_src_alpha
;
5521 (fun (pageno, c, (x0, y0, x1, y1, x2
, y2
, x3
, y3
)) ->
5523 if l.pageno = pageno
5525 let dx = float (l.pagedispx - l.pagex
) in
5526 let dy = float (l.pagedispy - l.pagey) in
5527 let r, g, b, alpha = c in
5528 GlDraw.color (r, g, b) ~
alpha;
5529 filledrect2 (x0+.dx) (y0+.dy)
5541 begin match conf
.columns
, state
.layout with
5542 | Csingle
_, _ :: _ ->
5543 GlDraw.color (scalecolor2 conf
.bgcolor
);
5545 List.fold_left
(fun y l ->
5548 let x1 = l.pagedispx + xadjsb () in
5549 let y1 = (l.pagedispy + l.pagevh) in
5550 filledrect (float x0) (float y0) (float x1) (float y1);
5551 let x0 = x1 + l.pagevw in
5552 let x1 = state
.winw
in
5553 filledrect1 (float x0) (float y0) (float x1) (float y1);
5557 and x1 = state
.winw
in
5559 and y1 = l.pagedispy in
5560 filledrect1 (float x0) (float y0) (float x1) (float y1);
5562 l.pagedispy + l.pagevh) 0 state
.layout
5565 and x1 = state
.winw
in
5567 and y1 = state
.winh
in
5568 filledrect1 (float x0) (float y0) (float x1) (float y1)
5569 | (Cmulti
_ | Csplit
_), _ | Csingle
_, [] ->
5570 GlClear.color (scalecolor2 conf
.bgcolor
);
5571 GlClear.clear
[`
color];
5573 List.iter
drawpage state
.layout;
5575 match state
.mode with
5576 | LinkNav
(Ltexact
(pageno, linkno
)) ->
5577 begin match getopaque pageno with
5579 let dx = xadjsb () in
5580 let x0, y0, x1, y1 = getlinkrect
opaque linkno
in
5581 let x0 = x0 + dx and x1 = x1 + dx in
5582 let color = (0.0, 0.0, 0.5, 0.5) in
5589 | None
-> state
.rects
5591 | LinkNav
(Ltgendir
_) | LinkNav
(Ltnotready
_)
5594 | View
-> state
.rects
5597 let rec postloop linkindexbase
= function
5599 let linkindexbase = linkindexbase + postdrawpage l linkindexbase in
5600 postloop linkindexbase rest
5604 postloop 0 state
.layout;
5606 begin match state
.mstate
with
5607 | Mzoomrect
((x0, y0), (x1, y1)) ->
5609 GlDraw.color (0.3, 0.3, 0.3) ~
alpha:0.5;
5610 GlFunc.blend_func ~
src:`src_alpha ~dst
:`one_minus_src_alpha
;
5611 filledrect (float x0) (float y0) (float x1) (float y1);
5615 | Mscrolly
| Mscrollx
5624 let zoomrect x y x1 y1 =
5627 and y0 = min
y y1 in
5628 gotoy (state
.y + y0);
5629 state
.anchor <- getanchor
();
5630 let zoom = (float state
.w) /. float (x1 - x0) in
5633 let adjw = wadjsb () + state
.winw
in
5635 then (adjw - state
.w) / 2
5638 match conf
.fitmodel
with
5639 | FitWidth
| FitProportional
-> simple ()
5641 match conf
.columns
with
5643 onppundermouse (fun _ l _ _ -> Some
l.pagedispx) x0 y0 x0
5644 | Cmulti
_ | Csingle
_ -> simple ()
5646 state
.x <- (state
.x + margin) - x0;
5651 let annot inline
x y =
5652 match unproject x y with
5653 | Some
(opaque, n, ux
, uy
) ->
5655 addannot
opaque ux uy
text;
5656 wcmd "freepage %s" (~
> opaque);
5657 Hashtbl.remove state
.pagemap
(n, state
.gen
);
5663 let ondone s = add s in
5664 let mode = state
.mode in
5665 state
.mode <- Textentry
(
5666 ("annotation: ", E.s, None
, textentry, ondone, true),
5667 fun _ -> state
.mode <- mode);
5670 G.postRedisplay "annot"
5672 add @@ getusertext E.s
5677 let g opaque l px py =
5678 match rectofblock
opaque px py with
5680 let x0 = a.(0) -. 20. in
5681 let x1 = a.(1) +. 20. in
5682 let y0 = a.(2) -. 20. in
5683 let zoom = (float state
.w) /. (x1 -. x0) in
5684 let pagey = getpagey
l.pageno in
5685 gotoy_and_clear_text (pagey + truncate
y0);
5686 state
.anchor <- getanchor
();
5687 let margin = (state
.w - l.pagew
)/2 in
5688 state
.x <- -truncate
x0 - margin;
5693 match conf
.columns
with
5695 impmsg "block zooming does not work properly in split columns mode"
5696 | Cmulti
_ | Csingle
_ -> onppundermouse g x y ()
5700 let winw = wadjsb () + state
.winw - 1 in
5701 let s = float x /. float winw in
5702 let destx = truncate
(float (state
.w + winw) *. s) in
5703 state
.x <- winw - destx;
5704 gotoy_and_clear_text state
.y;
5705 state
.mstate
<- Mscrollx
;
5709 let s = float y /. float state
.winh
in
5710 let desty = truncate
(float (state
.maxy - state
.winh
) *. s) in
5711 gotoy_and_clear_text desty;
5712 state
.mstate
<- Mscrolly
;
5715 let viewmulticlick clicks
x y mask
=
5716 let g opaque l px py =
5724 if markunder
opaque px py mark
5728 match getopaque l.pageno with
5730 | Some
opaque -> pipesel opaque cmd
5732 state
.roam
<- (fun () -> dopipe conf
.paxcmd
);
5733 if not
(Wsi.withctrl mask
) then dopipe conf
.selcmd
;
5738 G.postRedisplay "viewmulticlick";
5739 onppundermouse g x y (fun () -> impmsg "nothing to select") ();
5743 match conf
.columns
with
5745 | Csingle
_ | Cmulti
_ -> conf
.angle
mod 360 = 0
5748 let viewmouse button down
x y mask
=
5750 | n when (n == 4 || n == 5) && not down
->
5751 if Wsi.withctrl mask
5753 match state
.mstate
with
5754 | Mzoom
(oldn
, i
) ->
5762 if conf
.zoom +. 0.01 > 0.1 then 0.1 else 0.01
5764 if conf
.zoom -. 0.1 < 0.1 then -0.01 else -0.1
5766 let zoom = conf
.zoom -. incr in
5768 state
.mstate
<- Mzoom
(n, 0);
5770 state
.mstate
<- Mzoom
(n, i
+1);
5772 else state
.mstate
<- Mzoom
(n, 0)
5776 | Mscrolly
| Mscrollx
5778 | Mnone
-> state
.mstate
<- Mzoom
(n, 0)
5781 match state
.autoscroll
with
5782 | Some step
-> setautoscrollspeed step
(n=4)
5784 if conf
.wheelbypage
|| conf
.presentation
5793 then -conf
.scrollstep
5794 else conf
.scrollstep
5796 let incr = incr * 2 in
5797 let y = clamp incr in
5798 gotoy_and_clear_text y
5801 | n when (n = 6 || n = 7) && not down
&& canpan () ->
5803 panbound (state
.x + (if n = 7 then -2 else 2) * conf
.hscrollstep
);
5804 gotoy_and_clear_text state
.y
5806 | 1 when Wsi.withshift mask
->
5807 state
.mstate
<- Mnone
;
5810 match unproject x y with
5812 | Some
(_, pageno, ux
, uy
) ->
5813 let cmd = Printf.sprintf
5815 conf
.stcmd state
.path pageno ux uy
5817 match spawn
cmd [] with
5818 | (exception exn
) ->
5819 impmsg "execution of synctex command(%S) failed: %S"
5820 conf
.stcmd
@@ exntos exn
5824 | 1 when Wsi.withctrl mask
->
5827 Wsi.setcursor
Wsi.CURSOR_FLEUR
;
5828 state
.mstate
<- Mpan
(x, y)
5831 state
.mstate
<- Mnone
5836 if Wsi.withshift mask
5838 annot conf
.annotinline
x y;
5839 G.postRedisplay "addannot"
5843 Wsi.setcursor
Wsi.CURSOR_CYCLE
;
5844 state
.mstate
<- Mzoomrect
(p, p)
5847 match state
.mstate
with
5848 | Mzoomrect
((x0, y0), _) ->
5849 if abs
(x-x0) > 10 && abs
(y - y0) > 10
5850 then zoomrect x0 y0 x y
5853 G.postRedisplay "kill accidental zoom rect";
5857 | Mscrolly
| Mscrollx
5863 | 1 when vscrollhit x ->
5866 let _, position, sh = state
.uioh#
scrollph in
5867 if y > truncate
position && y < truncate
(position +. sh)
5868 then state
.mstate
<- Mscrolly
5871 state
.mstate
<- Mnone
5873 | 1 when y > state
.winh
- hscrollh () ->
5876 let _, position, sw = state
.uioh#scrollpw
in
5877 if x > truncate
position && x < truncate
(position +. sw)
5878 then state
.mstate
<- Mscrollx
5881 state
.mstate
<- Mnone
5883 | 1 when state
.bzoom
-> if not down
then zoomblock x y
5886 let dest = if down
then getunder x y else Unone
in
5887 begin match dest with
5890 | Uremote
_ | Uremotedest
_
5891 | Uunexpected
_ | Ulaunch
_ | Unamed
_ ->
5894 | Unone
when down
->
5895 Wsi.setcursor
Wsi.CURSOR_FLEUR
;
5896 state
.mstate
<- Mpan
(x, y);
5898 | Uannotation
(opaque, slinkindex
) -> enterannotmode opaque slinkindex
5900 | Unone
| Utext
_ ->
5905 state
.mstate
<- Msel
((x, y), (x, y));
5906 G.postRedisplay "mouse select";
5910 match state
.mstate
with
5913 | Mzoom
_ | Mscrollx
| Mscrolly
->
5914 state
.mstate
<- Mnone
5916 | Mzoomrect
((x0, y0), _) ->
5920 Wsi.setcursor
Wsi.CURSOR_INHERIT
;
5921 state
.mstate
<- Mnone
5923 | Msel
((x0, y0), (x1, y1)) ->
5924 let rec loop = function
5928 let a0 = l.pagedispy in
5929 let a1 = a0 + l.pagevh in
5930 let b0 = l.pagedispx in
5931 let b1 = b0 + l.pagevw in
5932 ((y0 >= a0 && y0 <= a1) || (y1 >= a0 && y1 <= a1))
5933 && ((x0 >= b0 && x0 <= b1) || (x1 >= b0 && x1 <= b1))
5937 match getopaque l.pageno with
5940 match Unix.pipe
() with
5941 | (exception exn
) ->
5942 impmsg "cannot create sel pipe: %s" @@
5946 Ne.clo fd
(fun msg
->
5947 dolog
"%s close failed: %s" what msg
)
5950 try spawn
cmd [r, 0; w, -1]
5952 dolog
"cannot execute %S: %s"
5959 G.postRedisplay "copysel";
5961 else clo "Msel pipe/w" w;
5962 clo "Msel pipe/r" r;
5964 dosel conf
.selcmd
();
5965 state
.roam
<- dosel conf
.paxcmd
;
5977 let birdseyemouse button down
x y mask
5978 (conf
, leftx
, _, hooverpageno
, anchor) =
5981 let rec loop = function
5984 if y > l.pagedispy && y < l.pagedispy + l.pagevh
5985 && x > l.pagedispx && x < l.pagedispx + l.pagevw
5987 leavebirdseye (conf
, leftx
, l.pageno, hooverpageno
, anchor) false;
5993 | _ -> viewmouse button down
x y mask
5999 method key key mask
=
6000 begin match state
.mode with
6001 | Textentry
textentry -> textentrykeyboard key mask
textentry
6002 | Birdseye
birdseye -> birdseyekeyboard key mask
birdseye
6003 | View
-> viewkeyboard key mask
6004 | LinkNav
linknav -> linknavkeyboard key mask
linknav
6008 method button button bstate
x y mask
=
6009 begin match state
.mode with
6011 | View
-> viewmouse button bstate
x y mask
6012 | Birdseye beye
-> birdseyemouse button bstate
x y mask beye
6017 method multiclick clicks
x y mask
=
6018 begin match state
.mode with
6020 | View
-> viewmulticlick clicks
x y mask
6027 begin match state
.mode with
6029 | View
| Birdseye
_ | LinkNav
_ ->
6030 match state
.mstate
with
6031 | Mzoom
_ | Mnone
-> ()
6036 state
.mstate
<- Mpan
(x, y);
6038 then state
.x <- panbound (state
.x + dx);
6040 gotoy_and_clear_text y
6043 state
.mstate
<- Msel
(a, (x, y));
6044 G.postRedisplay "motion select";
6047 let y = min state
.winh
(max
0 y) in
6051 let x = min state
.winw (max
0 x) in
6054 | Mzoomrect
(p0
, _) ->
6055 state
.mstate
<- Mzoomrect
(p0
, (x, y));
6056 G.postRedisplay "motion zoomrect";
6060 method pmotion
x y =
6061 begin match state
.mode with
6062 | Birdseye
(conf
, leftx
, pageno, hooverpageno
, anchor) ->
6063 let rec loop = function
6065 if hooverpageno
!= -1
6067 state
.mode <- Birdseye
(conf
, leftx
, pageno, -1, anchor);
6068 G.postRedisplay "pmotion birdseye no hoover";
6071 if y > l.pagedispy && y < l.pagedispy + l.pagevh
6072 && x > l.pagedispx && x < l.pagedispx + l.pagevw
6074 state
.mode <- Birdseye
(conf
, leftx
, pageno, l.pageno, anchor);
6075 G.postRedisplay "pmotion birdseye hoover";
6085 match state
.mstate
with
6086 | Mpan
_ | Msel
_ | Mzoom
_ | Mscrolly
| Mscrollx
| Mzoomrect
_ -> ()
6094 let past, _, _ = !r in
6096 let delta = now -. past in
6099 else r := (now, x, y)
6103 method infochanged
_ = ()
6106 let maxy = state
.maxy - (if conf
.maxhfit
then state
.winh
else 0) in
6109 then 0.0, float state
.winh
6110 else scrollph state
.y maxy
6115 let winw = wadjsb () + state
.winw in
6116 let fwinw = float winw in
6118 let sw = fwinw /. float state
.w in
6119 let sw = fwinw *. sw in
6120 max
sw (float conf
.scrollh
)
6123 let maxx = state
.w + winw in
6124 let x = winw - state
.x in
6125 let percent = float x /. float maxx in
6126 (fwinw -. sw) *. percent
6128 hscrollh (), position, sw
6132 match state
.mode with
6133 | LinkNav
_ -> "links"
6134 | Textentry
_ -> "textentry"
6135 | Birdseye
_ -> "birdseye"
6138 findkeyhash conf
modename
6140 method eformsgs
= true
6141 method alwaysscrolly
= false
6144 let addrect pageno r g b a x0 y0 x1 y1 =
6145 Hashtbl.add state
.prects
pageno [|r; g; b; a; x0; y0; x1; y1|];
6149 let cl = splitatspace cmds
in
6151 try Scanf.sscanf
s fmt
f
6153 adderrfmt "remote exec"
6154 "error processing '%S': %s\n" cmds
@@ exntos exn
6156 let rectx s pageno (r, g, b, a) x0 y0 x1 y1 =
6157 vlog "%s page %d color (%f %f %f %f) x0,y0,x1,y1 = %f %f %f %f"
6158 s pageno r g b a x0 y0 x1 y1;
6162 let _,w1,h1
,_ = getpagedim
pageno in
6163 let sw = float w1 /. float w
6164 and sh = float h1
/. float h in
6168 and y1s
= y1 *. sh in
6169 let rect = (x0s,y0s
,x1s
,y0s
,x1s
,y1s
,x0s,y1s
) in
6170 let color = (r, g, b, a) in
6171 if conf
.verbose
then debugrect rect;
6172 state
.rects <- (pageno, color, rect) :: state
.rects;
6177 | "reload", "" -> reload ()
6179 scan args
"%u %f %f"
6181 let cmd, _ = state
.geomcmds
in
6183 then gotopagexy !wtmode pageno x y
6186 gotopagexy !wtmode pageno x y;
6189 state
.reprf
<- f state
.reprf
6191 | "goto1", args
-> scan args
"%u %f" gotopage
6194 (fun filename
pageno -> gotounder (Uremote
(filename
, pageno)))
6197 (fun filename
dest -> gotounder (Uremotedest
(filename
, dest)))
6199 scan args
"%u %u %f %f %f %f"
6200 (fun pageno c x0 y0 x1 y1 ->
6201 let color = (0.0, 0.0, 1.0 /. float c, 0.5) in
6202 rectx "rect" pageno color x0 y0 x1 y1;
6205 scan args
"%u %f %f %f %f %f %f %f %f"
6206 (fun pageno r g b alpha x0 y0 x1 y1 ->
6207 addrect pageno r g b alpha x0 y0 x1 y1;
6208 G.postRedisplay "prect"
6211 scan args
"%u %f %f"
6214 match getopaque pageno with
6215 | Some
opaque -> opaque
6218 pgoto optopaque pageno x y;
6219 let rec fixx = function
6222 if l.pageno = pageno
6224 state
.x <- state
.x - l.pagedispx;
6231 match conf
.columns
with
6232 | Csingle
_ | Csplit
_ -> 1
6233 | Cmulti
((n, _, _), _) -> n
6235 layout 0 state
.y (state
.winw * mult) state
.winh
6239 | "activatewin", "" -> Wsi.activatewin
()
6240 | "quit", "" -> raise Quit
6243 let l = Config.keys_of_string
keys in
6244 List.iter
(fun (k
, m) -> keyboard k
m) l
6246 adderrfmt "error processing keys" "`%S': %s\n" cmds
@@ exntos exn
6248 | "clearrects", "" ->
6249 Hashtbl.clear state
.prects
;
6250 G.postRedisplay "clearrects"
6252 adderrfmt "remote command"
6253 "error processing remote command: %S\n" cmds
;
6257 let scratch = Bytes.create
80 in
6258 let buf = Buffer.create
80 in
6260 match tempfailureretry
(Unix.read fd
scratch 0) 80 with
6261 | (exception Unix.Unix_error
(Unix.EAGAIN
, _, _)) -> None
6264 if Buffer.length
buf > 0
6266 let s = Buffer.contents
buf in
6274 match Bytes.index_from
scratch ppos '
\n'
with
6275 | pos -> if pos >= n then -1 else pos
6276 | (exception Not_found
) -> -1
6280 Buffer.add_subbytes
buf scratch ppos
(nlpos-ppos
);
6281 let s = Buffer.contents
buf in
6287 Buffer.add_subbytes
buf scratch ppos
(n-ppos
);
6293 let remoteopen path =
6294 try Some
(Unix.openfile
path [Unix.O_NONBLOCK
; Unix.O_RDONLY
] 0o0)
6296 adderrfmt "remoteopen" "error opening %S: %s" path @@ exntos exn
;
6301 let gcconfig = ref E.s in
6302 let trimcachepath = ref E.s in
6303 let rcmdpath = ref E.s in
6304 let pageno = ref None
in
6305 let rootwid = ref 0 in
6306 let openlast = ref false in
6307 let nofc = ref false in
6308 let doreap = ref false in
6309 selfexec := Sys.executable_name
;
6312 [("-p", Arg.String
(fun s -> state
.password <- s),
6313 "<password> Set password");
6317 Config.fontpath
:= s;
6318 selfexec := !selfexec ^
" -f " ^
Filename.quote
s;
6320 "<path> Set path to the user interface font");
6324 selfexec := !selfexec ^
" -c " ^
Filename.quote
s;
6325 Config.confpath
:= s),
6326 "<path> Set path to the configuration file");
6328 ("-last", Arg.Set
openlast, " Open last document");
6330 ("-page", Arg.Int
(fun pageno1
-> pageno := Some
(pageno1
-1)),
6331 "<page-number> Jump to page");
6333 ("-tcf", Arg.String
(fun s -> trimcachepath := s),
6334 "<path> Set path to the trim cache file");
6336 ("-dest", Arg.String
(fun s -> state
.nameddest
<- s),
6337 "<named-destination> Set named destination");
6339 ("-wtmode", Arg.Set
wtmode, " Operate in wt mode");
6340 ("-cxack", Arg.Set
cxack, " Cut corners");
6342 ("-remote", Arg.String
(fun s -> rcmdpath := s),
6343 "<path> Set path to the remote commands source");
6345 ("-origin", Arg.String
(fun s -> state
.origin
<- s),
6346 "<original-path> Set original path");
6348 ("-gc", Arg.Set_string
gcconfig,
6349 "<script-path> Collect garbage with the help of a script");
6351 ("-nofc", Arg.Set
nofc, " Do not use fontconfig");
6353 ("-v", Arg.Unit
(fun () ->
6355 "%s\nconfiguration path: %s\n"
6359 exit
0), " Print version and exit");
6361 ("-embed", Arg.Set_int
rootwid,
6362 "<window-id> Embed into window")
6365 (fun s -> state
.path <- s)
6366 ("Usage: " ^
Sys.argv
.(0) ^
" [options] some.pdf\nOptions:")
6369 then selfexec := !selfexec ^
" -wtmode";
6371 let histmode = emptystr state
.path && not
!openlast in
6373 if not
(Config.load !openlast)
6374 then dolog
"failed to load configuration";
6376 begin match !pageno with
6377 | Some
pageno -> state
.anchor <- (pageno, 0.0, 0.0)
6381 if nonemptystr
!gcconfig
6384 match Unix.socketpair
Unix.PF_UNIX
Unix.SOCK_STREAM
0 with
6385 | (exception exn
) -> error
"socketpair for gc failed: %s" @@ exntos exn
6388 match spawn
!gcconfig [(c, 0); (c, 1); (s, -1)] with
6389 | (exception exn
) -> error
"failed to execute gc script: %s" @@ exntos exn
6391 Ne.clo c @@ (fun s -> error
"failed to close gc fd %s" s);
6396 let wsfd, winw, winh
= Wsi.init
(object (self)
6397 val mutable m_clicks
= 0
6398 val mutable m_click_x
= 0
6399 val mutable m_click_y
= 0
6400 val mutable m_lastclicktime
= infinity
6402 method private cleanup =
6403 state
.roam
<- noroam
;
6404 Hashtbl.iter
(fun _ opaque -> clearmark
opaque) state
.pagemap
6405 method expose
= G.postRedisplay "expose"
6409 | Wsi.Unobscured
-> "unobscured"
6410 | Wsi.PartiallyObscured
-> "partiallyobscured"
6411 | Wsi.FullyObscured
-> "fullyobscured"
6413 vlog "visibility change %s" name
6414 method display = display ()
6415 method map mapped
= vlog "mapped %b" mapped
6416 method reshape w h =
6419 method mouse
b d x y m =
6420 if d && canselect ()
6422 (* http://blogs.msdn.com/b/oldnewthing/archive/2004/10/18/243925.aspx *)
6428 if abs
x - m_click_x
> 10
6429 || abs
y - m_click_y
> 10
6430 || abs_float
(t -. m_lastclicktime
) > 0.3
6432 m_clicks
<- m_clicks
+ 1;
6433 m_lastclicktime
<- t;
6437 G.postRedisplay "cleanup";
6438 state
.uioh <- state
.uioh#button
b d x y m;
6440 else state
.uioh <- state
.uioh#multiclick m_clicks
x y m
6445 m_lastclicktime
<- infinity
;
6446 state
.uioh <- state
.uioh#button
b d x y m
6450 state
.uioh <- state
.uioh#button
b d x y m
6453 state
.mpos
<- (x, y);
6454 state
.uioh <- state
.uioh#motion
x y
6455 method pmotion
x y =
6456 state
.mpos
<- (x, y);
6457 state
.uioh <- state
.uioh#pmotion
x y
6459 let mascm = m land (
6460 Wsi.altmask
+ Wsi.shiftmask
+ Wsi.ctrlmask
+ Wsi.metamask
6463 let x = state
.x and y = state
.y in
6465 if x != state
.x || y != state
.y then self#
cleanup
6467 match state
.keystate
with
6469 let km = k
, mascm in
6472 let modehash = state
.uioh#
modehash in
6473 try Hashtbl.find modehash km
6475 try Hashtbl.find (findkeyhash conf
"global") km
6476 with Not_found
-> KMinsrt
(k
, m)
6478 | KMinsrt
(k
, m) -> keyboard k
m
6479 | KMinsrl
l -> List.iter
(fun (k
, m) -> keyboard k
m) l
6480 | KMmulti
(l, r) -> state
.keystate
<- KSinto
(l, r)
6482 | KSinto
((k'
, m'
) :: [], insrt
) when k'
=k
&& m'
land mascm = m'
->
6483 List.iter
(fun (k
, m) -> keyboard k
m) insrt
;
6484 state
.keystate
<- KSnone
6485 | KSinto
((k'
, m'
) :: keys, insrt
) when k'
=k
&& m'
land mascm = m'
->
6486 state
.keystate
<- KSinto
(keys, insrt
)
6487 | KSinto
_ -> state
.keystate
<- KSnone
6490 state
.mpos
<- (x, y);
6491 state
.uioh <- state
.uioh#pmotion
x y
6492 method leave = state
.mpos
<- (-1, -1)
6493 method winstate wsl
= state
.winstate
<- wsl
6494 method quit
= raise Quit
6495 end) !rootwid conf
.cwinw conf
.cwinh platform
in
6497 setbgcol conf
.bgcolor
;
6501 List.exists
GlMisc.check_extension
6502 [ "GL_ARB_texture_rectangle"
6503 ; "GL_EXT_texture_recangle"
6504 ; "GL_NV_texture_rectangle" ]
6506 then (dolog
"OpenGL does not suppport rectangular textures"; exit
1);
6509 let r = GlMisc.get_string `renderer
in
6510 let p = "Mesa DRI Intel(" in
6511 let l = String.length
p in
6512 String.length
r > l && String.sub
r 0 l = p
6515 defconf
.sliceheight
<- 1024;
6516 defconf
.texcount
<- 32;
6517 defconf
.usepbo
<- true;
6521 match Unix.socketpair
Unix.PF_UNIX
Unix.SOCK_STREAM
0 with
6522 | (exception exn
) ->
6523 dolog
"socketpair failed: %s" @@ exntos exn
;
6531 setcheckers conf
.checkers
;
6533 opengl_has_pbo := GlMisc.check_extension
"GL_ARB_pixel_buffer_object";
6536 conf
.angle
, conf
.fitmodel
, (conf
.trimmargins
, conf
.trimfuzz
),
6537 conf
.texcount
, conf
.sliceheight
, conf
.mustoresize
, conf
.colorspace
,
6538 !Config.fontpath
, !trimcachepath,
6542 List.iter
GlArray.enable
[`texture_coord
; `vertex
];
6544 reshape ~firsttime
:true winw winh
;
6548 Wsi.settitle
"llpp (history)";
6552 state
.text <- "Opening " ^
(mbtoutf8 state
.path);
6553 opendoc state
.path state
.password;
6557 Wsi.setcursor
Wsi.CURSOR_INHERIT
;
6558 Sys.set_signal
Sys.sighup
(Sys.Signal_handle
(fun _ -> reload ()));
6561 match Unix.waitpid
[Unix.WNOHANG
] ~
-1 with
6562 | (exception (Unix.Unix_error
(Unix.ECHILD
, _, _))) -> ()
6563 | (exception exn
) -> dolog
"Unix.waitpid: %s" @@ exntos exn
6565 | _pid
, _status
-> reap ()
6567 Sys.set_signal
Sys.sigchld
(Sys.Signal_handle
(fun _ -> doreap := true));
6571 if nonemptystr
!rcmdpath
6572 then remoteopen !rcmdpath
6577 let rec loop deadline
=
6583 let r = [state
.ss; state
.wsfd] in
6587 | Some fd
-> fd
:: r
6591 state
.redisplay
<- false;
6598 if deadline
= infinity
6600 else max
0.0 (deadline
-. now)
6605 try Unix.select
r [] [] timeout
6606 with Unix.Unix_error
(Unix.EINTR
, _, _) -> [], [], []
6612 if state
.ghyll
== noghyll
6614 match state
.autoscroll
with
6615 | Some step
when step
!= 0 ->
6616 let y = state
.y + step
in
6617 let fy = if conf
.maxhfit
then state
.winh
else 0 in
6620 then state
.maxy - fy
6621 else if y >= state
.maxy - fy then 0 else y
6623 if state
.mode = View
6624 then gotoy_and_clear_text y
6628 else deadline
+. 0.01
6633 let rec checkfds = function
6635 | fd
:: rest
when fd
= state
.ss ->
6636 let cmd = rcmd state
.ss in
6640 | fd
:: rest
when fd
= state
.wsfd ->
6644 | fd
:: rest
when Some fd
= !optrfd ->
6645 begin match remote fd
with
6646 | None
-> optrfd := remoteopen !rcmdpath;
6647 | opt -> optrfd := opt
6652 dolog
"select returned unknown descriptor";
6658 if deadline
= infinity
6662 match state
.autoscroll
with
6663 | Some step
when step
!= 0 -> deadline1
6664 | _ -> if state
.ghyll
== noghyll
then infinity
else deadline1
6672 Config.save leavebirdseye;
6673 if hasunsavedchanges
()