6 external init
: Unix.file_descr
-> params
-> unit = "ml_init";;
7 external seltext
: opaque
-> (int * int * int * int) -> unit = "ml_seltext";;
8 external hassel
: opaque
-> bool = "ml_hassel";;
9 external copysel
: Unix.file_descr
-> opaque
-> unit = "ml_copysel";;
10 external getpdimrect
: int -> float array
= "ml_getpdimrect";;
11 external whatsunder
: opaque
-> int -> int -> under
= "ml_whatsunder";;
12 external markunder
: opaque
-> int -> int -> mark
-> bool = "ml_markunder";;
13 external clearmark
: opaque
-> unit = "ml_clearmark";;
14 external zoomforh
: int -> int -> int -> int -> float = "ml_zoom_for_height";;
15 external drawstr
: int -> int -> int -> string -> float = "ml_draw_string";;
16 external measurestr
: int -> string -> float = "ml_measure_string";;
17 external postprocess
:
18 opaque
-> int -> int -> int -> (int * string * int) -> int
20 external pagebbox
: opaque
-> (int * int * int * int) = "ml_getpagebox";;
21 external setaalevel
: int -> unit = "ml_setaalevel";;
22 external realloctexts
: int -> bool = "ml_realloctexts";;
23 external findlink
: opaque
-> linkdir
-> link
= "ml_findlink";;
24 external getlink
: opaque
-> int -> under
= "ml_getlink";;
25 external getlinkrect
: opaque
-> int -> irect
= "ml_getlinkrect";;
26 external getlinkcount
: opaque
-> int = "ml_getlinkcount";;
27 external findpwl
: int -> int -> pagewithlinks
= "ml_find_page_with_links";;
28 external getpbo
: width
-> height
-> colorspace
-> opaque
= "ml_getpbo";;
29 external freepbo
: opaque
-> unit = "ml_freepbo";;
30 external unmappbo
: opaque
-> unit = "ml_unmappbo";;
31 external pbousable
: unit -> bool = "ml_pbo_usable";;
32 external unproject
: opaque
-> int -> int -> (int * int) option
34 external drawtile
: tileparams
-> opaque
-> unit = "ml_drawtile";;
35 external rectofblock
: opaque
-> int -> int -> float array
option
37 external begintiles
: unit -> unit = "ml_begintiles";;
38 external endtiles
: unit -> unit = "ml_endtiles";;
39 external addannot
: opaque
-> int -> int -> string -> unit = "ml_addannot";;
40 external modannot
: opaque
-> slinkindex
-> string -> unit = "ml_modannot";;
41 external delannot
: opaque
-> slinkindex
-> unit = "ml_delannot";;
42 external hasunsavedchanges
: unit -> bool = "ml_hasunsavedchanges";;
43 external savedoc
: string -> unit = "ml_savedoc";;
44 external getannotcontents
: opaque
-> slinkindex
-> string
45 = "ml_getannotcontents";;
47 let selfexec = ref E.s
;;
49 let drawstring size x y s
=
51 Gl.enable `texture_2d
;
52 GlFunc.blend_func ~src
:`src_alpha ~dst
:`one_minus_src_alpha
;
53 ignore
(drawstr size x y s
);
55 Gl.disable `texture_2d
;
58 let drawstring1 size x y s
=
62 let drawstring2 size x y fmt
=
63 Printf.kprintf
(drawstring size
(x
+1) (y
+size
+1)) fmt
67 dolog
"l %d dim=%d {" l
.pageno l
.pagedimno
;
68 dolog
" WxH %dx%d" l
.pagew l
.pageh
;
69 dolog
" vWxH %dx%d" l
.pagevw l
.pagevh
;
70 dolog
" pagex,y %d,%d" l
.pagex l
.pagey
;
71 dolog
" dispx,y %d,%d" l
.pagedispx l
.pagedispy
;
72 dolog
" column %d" l
.pagecol
;
76 let debugrect (x0
, y0
, x1
, y1
, x2
, y2
, x3
, y3
) =
78 dolog
" x0,y0=(% f, % f)" x0 y0
;
79 dolog
" x1,y1=(% f, % f)" x1 y1
;
80 dolog
" x2,y2=(% f, % f)" x2 y2
;
81 dolog
" x3,y3=(% f, % f)" x3 y3
;
85 let isbirdseye = function
92 let istextentry = function
99 let wtmode = ref false;;
100 let cxack = ref false;;
102 let pgscale h
= truncate
(float h
*. conf
.pgscale);;
105 if not state
.uioh#alwaysscrolly
&& (conf
.scrollb
land scrollbhv
= 0)
106 || (state
.x
= 0 && state
.w
<= state
.winw
- conf
.scrollbw
)
112 if not state
.uioh#alwaysscrolly
&& (conf
.scrollb
land scrollbvv
= 0)
117 let wadjsb () = -vscrollw ();;
118 let xadjsb () = if conf
.leftscroll
then vscrollw () else 0;;
121 fstate
.fontsize
<- n
;
122 fstate
.wwidth
<- measurestr fstate
.fontsize
"w";
123 fstate
.maxrows
<- (state
.winh
- fstate
.fontsize
- 1) / (fstate
.fontsize
+ 1);
129 else Printf.kprintf ignore fmt
133 if emptystr conf
.pathlauncher
134 then dolog
"%s" state
.path
136 let command = Str.global_replace percentsre state
.path conf
.pathlauncher
in
137 try addpid
@@ spawn
command []
138 with exn
-> dolog
"failed to execute `%s': %s" command @@ exntos exn
144 let postRedisplay who
=
145 vlog "redisplay for [%S]" who
;
146 state
.redisplay
<- true;
150 let getopaque pageno
=
151 try Some
(Hashtbl.find state
.pagemap
(pageno
, state
.gen
))
152 with Not_found
-> None
155 let pagetranslatepoint l x y
=
156 let dy = y
- l
.pagedispy
in
157 let y = dy + l
.pagey
in
158 let dx = x
- l
.pagedispx
in
159 let x = dx + l
.pagex
in
163 let onppundermouse g
x y d
=
166 begin match getopaque l
.pageno
with
168 let x0 = l
.pagedispx
in
169 let x1 = x0 + l
.pagevw
in
170 let y0 = l
.pagedispy
in
171 let y1 = y0 + l
.pagevh
in
172 if y >= y0 && y <= y1 && x >= x0 && x <= x1
174 let px, py
= pagetranslatepoint l
x y in
175 match g opaque l
px py
with
188 let g opaque l
px py
=
191 match rectofblock opaque
px py
with
193 let rect = (a
.(0),a
.(2),a
.(1),a
.(2),a
.(1),a
.(3),a
.(0),a
.(3)) in
194 state
.rects
<- [l
.pageno
, l
.pageno
mod 3, rect];
195 G.postRedisplay "getunder";
198 let under = whatsunder opaque
px py
in
199 if under = Unone
then None
else Some
under
201 onppundermouse g x y Unone
206 match unproject opaque
x y with
207 | Some
(x, y) -> Some
(Some
(opaque
, l
.pageno
, x, y))
210 onppundermouse g x y None
;
214 state
.text
<- Printf.sprintf
"%c%s" c s
;
215 G.postRedisplay "showtext";
218 let pipesel opaque cmd
=
221 match Unix.pipe
() with
222 | exception exn
-> dolog
"pipesel cannot create pipe: %S" @@ exntos exn
;
224 let doclose what fd
=
225 Ne.clo fd
(fun msg
-> dolog
"%s close failed: %s" what msg
)
228 try spawn cmd
[r
, 0; w
, -1]
230 dolog
"cannot execute %S: %s" cmd
@@ exntos exn
;
236 G.postRedisplay "pipesel";
238 else doclose "pipesel pipe/w" w
;
239 doclose "pipesel pipe/r" r
;
243 let g opaque l
px py
=
244 if markunder opaque
px py conf
.paxmark
247 match getopaque l
.pageno
with
249 | Some opaque
-> pipesel opaque conf
.paxcmd
254 G.postRedisplay "paxunder";
255 if conf
.paxmark
= Mark_page
258 match getopaque l
.pageno
with
260 | Some opaque
-> clearmark opaque
) state
.layout
;
262 onppundermouse g x y (fun () -> showtext '
!'
"Whoopsie daisy");
266 match Unix.pipe
() with
268 showtext '
!'
(Printf.sprintf
"pipe failed: %s" @@ exntos exn
)
271 Ne.clo fd
(fun msg
->
272 showtext '
!'
(Printf.sprintf
"failed to close %s: %s" cap msg
)
276 try spawn conf
.selcmd
[r
, 0; w
, -1]
279 (Printf.sprintf
"failed to execute %s: %s"
280 conf
.selcmd
@@ exntos exn
);
286 let l = String.length s
in
287 let bytes = Bytes.unsafe_of_string s
in
288 let n = tempfailureretry
(Unix.write w
bytes 0) l in
293 "failed to write %d characters to sel pipe, wrote %d"
298 (Printf.sprintf
"failed to write to sel pipe: %s" @@ exntos exn
)
301 clo "selstring pipe/r" r
;
302 clo "selstring pipe/w" w
;
305 let undertext ?
(nopath
=false) = function
308 | Ulinkgoto
(pageno
, _
) ->
310 then "page " ^ string_of_int
(pageno
+1)
311 else Printf.sprintf
"%s: page %d" state
.path
(pageno
+1)
312 | Utext s
-> "font: " ^ s
313 | Uunexpected s
-> "unexpected: " ^ s
314 | Ulaunch s
-> "launch: " ^ s
315 | Unamed s
-> "named: " ^ s
316 | Uremote
(filename
, pageno
) ->
317 Printf.sprintf
"%s: page %d" filename
(pageno
+1)
318 | Uremotedest
(filename
, destname
) ->
319 Printf.sprintf
"%s: destination %S" filename destname
320 | Uannotation
(opaque
, slinkindex
) ->
321 "annotation: " ^ getannotcontents opaque slinkindex
324 let updateunder x y =
325 match getunder x y with
326 | Unone
-> Wsi.setcursor
Wsi.CURSOR_INHERIT
328 if conf
.underinfo
then showtext 'u'
("ri: " ^ uri
);
329 Wsi.setcursor
Wsi.CURSOR_INFO
330 | Ulinkgoto
(pageno
, _
) ->
332 then showtext 'p'
("age: " ^ string_of_int
(pageno
+1));
333 Wsi.setcursor
Wsi.CURSOR_INFO
335 if conf
.underinfo
then showtext '
f'
("ont: " ^ s
);
336 Wsi.setcursor
Wsi.CURSOR_TEXT
338 if conf
.underinfo
then showtext 'u'
("nexpected: " ^ s
);
339 Wsi.setcursor
Wsi.CURSOR_INHERIT
341 if conf
.underinfo
then showtext '
l'
("aunch: " ^ s
);
342 Wsi.setcursor
Wsi.CURSOR_INHERIT
344 if conf
.underinfo
then showtext '
n'
("amed: " ^ s
);
345 Wsi.setcursor
Wsi.CURSOR_INHERIT
346 | Uremote
(filename
, pageno
) ->
347 if conf
.underinfo
then showtext 'r'
348 (Printf.sprintf
"emote: %s (%d)" filename
(pageno
+1));
349 Wsi.setcursor
Wsi.CURSOR_INFO
350 | Uremotedest
(filename
, destname
) ->
351 if conf
.underinfo
then showtext 'r'
352 (Printf.sprintf
"emote destination: %s (%S)" filename destname
);
353 Wsi.setcursor
Wsi.CURSOR_INFO
355 if conf
.underinfo
then showtext 'a'
"nnotation";
356 Wsi.setcursor
Wsi.CURSOR_INFO
359 let showlinktype under =
360 if conf
.underinfo
&& under != Unone
361 then showtext ' '
@@ undertext under
364 let intentry_with_suffix text key
=
366 if key
>= 32 && key
< 127
370 match Char.lowercase
c with
372 let text = addchar
text c in
376 let text = addchar
text c in
380 state
.text <- Printf.sprintf
"invalid char (%d, `%c')" key
c;
385 let s = Bytes.create
4 in
386 let n = tempfailureretry
(Unix.read fd
s 0) 4 in
387 if n != 4 then error
"incomplete read(len) = %d" n;
388 let len = (Char.code
(Bytes.get
s 0) lsl 24)
389 lor (Char.code
(Bytes.get
s 1) lsl 16)
390 lor (Char.code
(Bytes.get
s 2) lsl 8)
391 lor (Char.code
(Bytes.get
s 3))
393 let s = Bytes.create
len in
394 let n = tempfailureretry
(Unix.read fd
s 0) len in
395 if n != len then error
"incomplete read(data) %d vs %d" n len;
400 let b = Buffer.create
16 in
401 Buffer.add_string
b "llll";
404 let s = Buffer.to_bytes
b in
405 let n = Bytes.length
s in
407 (* dolog "wcmd %S" (String.sub s 4 len); *)
408 Bytes.set
s 0 (Char.chr
((len lsr 24) land 0xff));
409 Bytes.set
s 1 (Char.chr
((len lsr 16) land 0xff));
410 Bytes.set
s 2 (Char.chr
((len lsr 8) land 0xff));
411 Bytes.set
s 3 (Char.chr
(len land 0xff));
412 let n'
= tempfailureretry
(Unix.write state
.ss
s 0) n in
413 if n'
!= n then error
"write failed %d vs %d" n'
n;
417 let nogeomcmds cmds
=
419 | s, [] -> emptystr
s
423 let layoutN ((columns
, coverA
, coverB
), b) y sh
=
424 let sh = sh - (hscrollh ()) in
425 let wadj = wadjsb () in
426 let rec fold accu
n =
427 if n = Array.length
b
430 let pdimno, dx, vy
, (_
, w
, h
, xoff
) = b.(n) in
433 || n = state
.pagecount
- coverB
434 || (n - coverA
) mod columns
= columns
- 1)
440 let pagey = max
0 (y - vy
) in
441 let pagedispy = if pagey > 0 then 0 else vy
- y in
442 let pagedispx, pagex
=
444 if n = coverA
- 1 || n = state
.pagecount
- coverB
445 then state
.x + (wadj + state
.winw
- w
) / 2
446 else dx + xoff
+ state
.x
453 let vw = wadj + state
.winw
- pagedispx in
454 let pw = w
- pagex
in
457 let pagevh = min
(h
- pagey) (sh - pagedispy) in
458 if pagevw > 0 && pagevh > 0
469 ; pagedispx = pagedispx
470 ; pagedispy = pagedispy
482 if Array.length
b = 0
484 else List.rev
(fold [] (page_of_y
y))
487 let layoutS (columns
, b) y sh =
488 let sh = sh - hscrollh () in
489 let wadj = wadjsb () in
490 let rec fold accu n =
491 if n = Array.length
b
494 let pdimno, px, vy
, (_
, pagew
, pageh
, xoff
) = b.(n) in
501 let x = xoff
+ state
.x in
502 let pagey = max
0 (y - vy
) in
503 let pagedispy = if pagey > 0 then 0 else vy
- y in
504 let pagedispx, pagex
=
518 let pagecolw = pagew
/columns
in
520 if pagecolw < state
.winw
521 then pagedispx + ((wadj + state
.winw
- pagecolw) / 2)
525 let vw = wadj + state
.winw
- pagedispx in
526 let pw = pagew
- pagex
in
529 let pagevw = min
pagevw pagecolw in
530 let pagevh = min
(pageh
- pagey) (sh - pagedispy) in
531 if pagevw > 0 && pagevh > 0
542 ; pagedispx = pagedispx
543 ; pagedispy = pagedispy
544 ; pagecol
= n mod columns
559 if nogeomcmds state
.geomcmds
561 match conf
.columns
with
562 | Csingle
b -> layoutN ((1, 0, 0), b) y sh
563 | Cmulti
c -> layoutN c y sh
564 | Csplit
s -> layoutS s y sh
569 let y = state
.y + incr
in
571 let y = min
y (state
.maxy
- (if conf
.maxhfit
then state
.winh
else 0)) in
576 let tilex = l.pagex
mod conf
.tilew
in
577 let tiley = l.pagey mod conf
.tileh
in
579 let col = l.pagex
/ conf
.tilew
in
580 let row = l.pagey / conf
.tileh
in
582 let xadj = xadjsb () in
583 let rec rowloop row y0 dispy h
=
587 let dh = conf
.tileh
- y0 in
589 let rec colloop col x0 dispx w
=
593 let dw = conf
.tilew
- x0 in
595 let dispx'
= xadj + dispx in
596 f col row dispx' dispy
x0 y0 dw dh;
597 colloop (col+1) 0 (dispx+dw) (w
-dw)
600 colloop col tilex l.pagedispx l.pagevw;
601 rowloop (row+1) 0 (dispy
+dh) (h
-dh)
604 if l.pagevw > 0 && l.pagevh > 0
605 then rowloop row tiley l.pagedispy l.pagevh;
608 let gettileopaque l col row =
610 l.pageno
, state
.gen
, conf
.colorspace
, conf
.angle
, l.pagew
, l.pageh
, col, row
612 try Some
(Hashtbl.find state
.tilemap
key)
613 with Not_found
-> None
616 let puttileopaque l col row gen colorspace angle opaque size elapsed
=
617 let key = l.pageno
, gen
, colorspace
, angle
, l.pagew
, l.pageh
, col, row in
618 Hashtbl.add state
.tilemap
key (opaque
, size
, elapsed
)
621 let filledrect x0 y0 x1 y1 =
622 GlArray.disable `texture_coord
;
623 Raw.sets_float state
.vraw ~pos
:0 [| x0; y0; x0; y1; x1; y0; x1; y1 |];
624 GlArray.vertex `two state
.vraw
;
625 GlArray.draw_arrays `triangle_strip ~first
:0 ~count
:4;
626 GlArray.enable `texture_coord
;
629 let linerect x0 y0 x1 y1 =
630 GlArray.disable `texture_coord
;
631 Raw.sets_float state
.vraw ~pos
:0 [| x0; y0; x0; y1; x1; y1; x1; y0 |];
632 GlArray.vertex `two state
.vraw
;
633 GlArray.draw_arrays `line_loop ~first
:0 ~count
:4;
634 GlArray.enable `texture_coord
;
637 let drawtiles l color
=
639 let wadj = wadjsb () in
641 let f col row x y tilex tiley w h
=
642 match gettileopaque l col row with
643 | Some
(opaque
, _
, t
) ->
644 let params = x, y, w
, h
, tilex, tiley in
646 then GlTex.env
(`mode `blend
);
647 drawtile
params opaque
;
649 then GlTex.env
(`mode `modulate
);
653 let s = Printf.sprintf
657 let w = measurestr fstate
.fontsize
s in
658 GlDraw.color
(0.0, 0.0, 0.0);
659 filledrect (float (x-2))
662 (float (y + fstate
.fontsize
+ 2));
663 GlDraw.color
(1.0, 1.0, 1.0);
664 drawstring fstate
.fontsize
x (y + fstate
.fontsize
- 1) s;
674 let lw = wadj + state
.winw
- x in
677 let lh = state
.winh
- y in
681 then GlTex.env
(`mode `blend
);
682 begin match state
.checkerstexid
with
684 Gl.enable `texture_2d
;
685 GlTex.bind_texture ~target
:`texture_2d id
;
689 and y1 = float (y+h
) in
691 let tw = float w /. 16.0
692 and th
= float h
/. 16.0 in
693 let tx0 = float tilex /. 16.0
694 and ty0
= float tiley /. 16.0 in
696 and ty1
= ty0
+. th
in
697 Raw.sets_float state
.vraw ~pos
:0
698 [| x0; y0; x0; y1; x1; y0; x1; y1 |];
699 Raw.sets_float state
.traw ~pos
:0
700 [| tx0; ty0
; tx0; ty1
; tx1; ty0
; tx1; ty1
|];
701 GlArray.vertex `two state
.vraw
;
702 GlArray.tex_coord `two state
.traw
;
703 GlArray.draw_arrays `triangle_strip ~first
:0 ~count
:4;
704 Gl.disable `texture_2d
;
707 GlDraw.color
(1.0, 1.0, 1.0);
708 filledrect (float x) (float y) (float (x+w)) (float (y+h
));
711 then GlTex.env
(`mode `modulate
);
712 if w > 128 && h
> fstate
.fontsize
+ 10
714 let c = if conf
.invert
then 1.0 else 0.0 in
715 GlDraw.color
(c, c, c);
718 then (col*conf
.tilew
, row*conf
.tileh
)
721 drawstring2 fstate
.fontsize
x y "Loading %d [%d,%d]" l.pageno
c r
;
730 let pagevisible layout n = List.exists
(fun l -> l.pageno
= n) layout;;
732 let tilevisible1 l x y =
734 and ax1
= l.pagex
+ l.pagevw
736 and ay1
= l.pagey + l.pagevh in
740 let bx1 = min
(bx0 + conf
.tilew
) l.pagew
741 and by1
= min
(by0
+ conf
.tileh
) l.pageh
in
743 let rx0 = max
ax0 bx0
744 and ry0
= max ay0 by0
745 and rx1
= min ax1
bx1
746 and ry1
= min ay1 by1
in
748 let nonemptyintersection = rx1
> rx0 && ry1
> ry0
in
752 let tilevisible layout n x y =
753 let rec findpageinlayout m
= function
754 | l :: rest
when l.pageno
= n ->
755 tilevisible1 l x y || (
756 match conf
.columns
with
757 | Csplit
(c, _
) when c > m
-> findpageinlayout (m
+1) rest
762 | _
:: rest
-> findpageinlayout 0 rest
765 findpageinlayout 0 layout;
768 let tileready l x y =
769 tilevisible1 l x y &&
770 gettileopaque l (x/conf
.tilew
) (y/conf
.tileh
) != None
773 let tilepage n p
layout =
774 let rec loop = function
778 let f col row _ _ _ _ _ _
=
779 if state
.currently
= Idle
781 match gettileopaque l col row with
784 let x = col*conf
.tilew
785 and y = row*conf
.tileh
in
787 let w = l.pagew
- x in
791 let h = l.pageh
- y in
796 then getpbo
w h conf
.colorspace
799 wcmd "tile %s %d %d %d %d %s"
800 (~
> p
) x y w h (~
> pbo);
803 l, p
, conf
.colorspace
, conf
.angle
,
804 state
.gen
, col, row, conf
.tilew
, conf
.tileh
813 if nogeomcmds state
.geomcmds
817 let preloadlayout y =
818 let y = if y < state
.winh
then 0 else y - state
.winh
in
819 let h = state
.winh
*3 in
825 if state
.currently
!= Idle
830 begin match getopaque l.pageno
with
832 wcmd "page %d %d" l.pageno
l.pagedimno
;
833 state
.currently
<- Loading
(l, state
.gen
);
835 tilepage l.pageno opaque pages
;
840 if nogeomcmds state
.geomcmds
846 if conf
.preload && state
.currently
= Idle
847 then load (preloadlayout state
.y);
850 let layoutready layout =
851 let rec fold all ls
=
854 let seen = ref false in
855 let allvisible = ref true in
856 let foo col row _ _ _ _ _ _
=
858 allvisible := !allvisible &&
859 begin match gettileopaque l col row with
865 fold (!seen && !allvisible) rest
868 let alltilesvisible = fold true layout in
873 let y = bound
y 0 state
.maxy
in
874 let y, layout, proceed
=
875 match conf
.maxwait
with
876 | Some time
when state
.ghyll
== noghyll
->
877 begin match state
.throttle
with
879 let layout = layout y state
.winh
in
880 let ready = layoutready layout in
884 state
.throttle
<- Some
(layout, y, now
());
886 else G.postRedisplay "gotoy showall (None)";
888 | Some
(_
, _
, started
) ->
889 let dt = now
() -. started
in
892 state
.throttle
<- None
;
893 let layout = layout y state
.winh
in
895 G.postRedisplay "maxwait";
902 let layout = layout y state
.winh
in
903 if not
!wtmode || layoutready layout
904 then G.postRedisplay "gotoy ready";
910 state
.layout <- layout;
911 begin match state
.mode
with
914 | Ltexact
(pageno
, linkno
) ->
915 let rec loop = function
917 state
.mode
<- LinkNav
(Ltgendir
0)
918 | l :: _
when l.pageno
= pageno
->
919 begin match getopaque pageno
with
920 | None
-> state
.mode
<- LinkNav
(Ltnotready
(pageno
, 0))
922 let x0, y0, x1, y1 = getlinkrect opaque linkno
in
923 if not
(x0 >= l.pagex
&& x1 <= l.pagex
+ l.pagevw
924 && y0 >= l.pagey && y1 <= l.pagey + l.pagevh)
925 then state
.mode
<- LinkNav
(Ltgendir
0)
927 | _
:: rest
-> loop rest
930 | Ltnotready _
| Ltgendir _
-> ()
936 begin match state
.mode
with
937 | Birdseye
(conf
, leftx
, pageno
, hooverpageno
, anchor
) ->
938 if not
(pagevisible layout pageno
)
940 match state
.layout with
943 state
.mode
<- Birdseye
(
944 conf
, leftx
, l.pageno
, hooverpageno
, anchor
949 | Ltnotready
(_
, dir
)
952 let rec loop = function
955 match getopaque l.pageno
with
956 | None
-> Ltnotready
(l.pageno
, dir
)
961 then LDfirstvisible
(l.pagex
, l.pagey, dir
)
963 if dir
> 0 then LDfirst
else LDlast
969 | Lnotfound
-> loop rest
971 showlinktype (getlink opaque
n);
972 Ltexact
(l.pageno
, n)
976 state
.mode
<- LinkNav
linknav
984 state
.ghyll
<- noghyll
;
987 let mx, my
= state
.mpos
in
992 let conttiling pageno opaque
=
993 tilepage pageno opaque
994 (if conf
.preload then preloadlayout state
.y else state
.layout)
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))
1326 | LinkNav _
-> gotoanchor state
.anchor
1330 state
.reprf
<- noreprf
;
1334 let reshape ?
(firsttime
=false) w h =
1335 GlDraw.viewport ~
x:0 ~
y:0 ~
w:w ~
h:h;
1336 if not firsttime
&& nogeomcmds state
.geomcmds
1337 then state
.anchor <- getanchor
();
1340 let w = wadjsb () + (truncate
(float w *. conf
.zoom
)) in
1343 setfontsize fstate
.fontsize
;
1344 GlMat.mode `modelview
;
1345 GlMat.load_identity
();
1347 GlMat.mode `projection
;
1348 GlMat.load_identity
();
1349 GlMat.rotate ~
x:1.0 ~angle
:180.0 ();
1350 GlMat.translate ~
x:~
-.1.0 ~
y:~
-.1.0 ();
1351 GlMat.scale3
(2.0 /. float state
.winw
, 2.0 /. float state
.winh
, 1.0);
1356 else float state
.x /. float state
.w
1358 invalidate "geometry"
1362 then state
.x <- truncate
(relx *. float w);
1364 match conf
.columns
with
1366 | Cmulti
((c, _
, _
), _
) -> (w - (c-1)*conf
.interpagespace
) / c
1367 | Csplit
(c, _
) -> w * c
1369 wcmd "geometry %d %d %d"
1370 w (stateh h) (FMTE.to_int conf
.fitmodel
)
1375 let len = String.length state
.text in
1376 let x0 = xadjsb () in
1379 match state
.mode
with
1380 | Textentry _
| View
| LinkNav _
->
1381 let h, _
, _
= state
.uioh#scrollpw
in
1386 filledrect x (float (state
.winh
- (fstate
.fontsize
+ 4) - hscrollh))
1387 (x+.w) (float (state
.winh
- hscrollh))
1390 let w = float (wadjsb () + state
.winw
- 1) in
1391 if state
.progress
>= 0.0 && state
.progress
< 1.0
1393 GlDraw.color
(0.3, 0.3, 0.3);
1394 let w1 = w *. state
.progress
in
1396 GlDraw.color
(0.0, 0.0, 0.0);
1397 rect (float x0+.w1) (float x0+.w-.w1)
1400 GlDraw.color
(0.0, 0.0, 0.0);
1404 GlDraw.color
(1.0, 1.0, 1.0);
1405 drawstring fstate
.fontsize
1406 (if conf
.leftscroll
then x0 + 2 else x0 + if len > 0 then 8 else 2)
1407 (state
.winh
- hscrollh - 5) s;
1410 match state
.mode
with
1411 | Textentry
((prefix
, text, _
, _
, _
, _
), _
) ->
1415 Printf.sprintf
"%s%s_ [%s]" prefix
text state
.text
1417 Printf.sprintf
"%s%s_" prefix
text
1423 | LinkNav _
-> state
.text
1428 if not
(istextentry state
.mode
) && state
.uioh#eformsgs
1430 let s1 = "(press 'e' to review error messasges)" in
1431 if nonemptystr
s then s ^
" " ^
s1 else s1
1441 let len = Queue.length state
.tilelru
in
1443 match state
.throttle
with
1446 then preloadlayout state
.y
1448 | Some
(layout, _
, _
) ->
1452 if state
.memused
<= conf
.memlimit
1457 let (k
, p
, s) as lruitem
= Queue.pop state
.tilelru
in
1458 let n, gen
, colorspace
, angle
, pagew
, pageh
, col, row = k
in
1459 let (_
, pw, ph
, _
) = getpagedim
n in
1462 && colorspace
= conf
.colorspace
1463 && angle
= conf
.angle
1467 let x = col*conf
.tilew
1468 and y = row*conf
.tileh
in
1469 tilevisible (Lazy.force_val
layout) n x y
1471 then Queue.push lruitem state
.tilelru
1474 wcmd "freetile %s" (~
> p
);
1475 state
.memused
<- state
.memused
- s;
1476 state
.uioh#infochanged Memused
;
1477 Hashtbl.remove state
.tilemap k
;
1485 let onpagerect pageno
f =
1487 match conf
.columns
with
1488 | Cmulti
(_
, b) -> b
1490 | Csplit
(_
, b) -> b
1492 if pageno
>= 0 && pageno
< Array.length
b
1494 let (_
, _
, _
, (_
, w, h, _
)) = b.(pageno
) in
1498 let gotopagexy1 pageno
x y =
1499 let _,w1,h1
,leftx
= getpagedim pageno
in
1500 let top = y /. (float h1
) in
1501 let left = x /. (float w1) in
1502 let py, w, h = getpageywh pageno
in
1503 let wh = state
.winh
- hscrollh () in
1504 let x = left *. (float w) in
1505 let x = leftx
+ state
.x + truncate
x in
1506 let wadj = wadjsb () in
1508 if x < 0 || x >= wadj + state
.winw
1512 let pdy = truncate
(top *. float h) in
1513 let y'
= py + pdy in
1514 let dy = y'
- state
.y in
1516 if x != state
.x || not
(dy > 0 && dy < wh)
1518 if conf
.presentation
1520 if abs
(py - y'
) > wh
1527 if state
.x != sx || state
.y != sy
1532 let ww = wadj + state
.winw
in
1534 and qy
= pdy / wh in
1536 and y = py + qy
* wh in
1537 let x = if -x + ww > w1 then -(w1-ww) else x
1538 and y'
= if y + wh > state
.maxy
then state
.maxy
- wh else y in
1540 if conf
.presentation
1542 if abs
(py - y'
) > wh
1552 gotoy_and_clear_text y;
1554 else gotoy_and_clear_text state
.y;
1557 let gotopagexy pageno
x y =
1558 match state
.mode
with
1559 | Birdseye
_ -> gotopage pageno
0.0
1562 | LinkNav
_ -> gotopagexy1 pageno
x y
1565 let getpassword () =
1566 let passcmd = getenvwithdef
"LLPP_ASKPASS" conf
.passcmd in
1571 showtext '
!'
@@ "error getting password: " ^
s;
1572 dolog
"%s" s) passcmd;
1576 (* dolog "%S" cmds; *)
1577 let cl = splitatspace cmds
in
1579 try Scanf.sscanf
s fmt
f
1581 dolog
"error processing '%S': %s" cmds
@@ exntos exn
;
1584 let addoutline outline
=
1585 match state
.currently
with
1586 | Outlining outlines
->
1587 state
.currently
<- Outlining
(outline
:: outlines
)
1588 | Idle
-> state
.currently
<- Outlining
[outline
]
1591 dolog
"invalid outlining state";
1592 logcurrently state
.currently
1596 state
.uioh#infochanged Pdim
;
1599 | "clearrects" :: [] ->
1600 state
.rects
<- state
.rects1
;
1601 G.postRedisplay "clearrects";
1603 | "continue" :: args
:: [] ->
1604 let n = scan args
"%u" (fun n -> n) in
1605 state
.pagecount
<- n;
1606 begin match state
.currently
with
1608 state
.currently
<- Idle
;
1609 state
.outlines
<- Array.of_list
(List.rev
l)
1615 let cur, cmds
= state
.geomcmds
in
1617 then failwith
"umpossible";
1619 begin match List.rev cmds
with
1621 state
.geomcmds
<- E.s, [];
1622 state
.throttle
<- None
;
1626 state
.geomcmds
<- s, List.rev rest
;
1628 if conf
.maxwait
= None
&& not
!wtmode
1629 then G.postRedisplay "continue";
1631 | "msg" :: args
:: [] ->
1634 | "vmsg" :: args
:: [] ->
1636 then showtext ' ' args
1638 | "emsg" :: args
:: [] ->
1639 Buffer.add_string state
.errmsgs args
;
1640 state
.newerrmsgs
<- true;
1641 G.postRedisplay "error message"
1643 | "progress" :: args
:: [] ->
1644 let progress, text =
1647 f, String.sub args pos
(String.length args
- pos
))
1650 state
.progress <- progress;
1651 G.postRedisplay "progress"
1653 | "firstmatch" :: args
:: [] ->
1654 let pageno, c, x0, y0, x1, y1, x2
, y2
, x3
, y3
=
1655 scan args
"%u %d %f %f %f %f %f %f %f %f"
1656 (fun p
c x0 y0 x1 y1 x2 y2 x3 y3
->
1657 (p
, c, x0, y0, x1, y1, x2
, y2
, x3
, y3
))
1659 let xoff = float (xadjsb ()) in
1663 and x3
= x3
+. xoff in
1664 let y = (getpagey
pageno) + truncate
y0 in
1667 state
.rects1
<- [pageno, c, (x0, y0, x1, y1, x2
, y2
, x3
, y3
)]
1669 | "match" :: args
:: [] ->
1670 let pageno, c, x0, y0, x1, y1, x2
, y2
, x3
, y3
=
1671 scan args
"%u %d %f %f %f %f %f %f %f %f"
1672 (fun p
c x0 y0 x1 y1 x2 y2 x3 y3
->
1673 (p
, c, x0, y0, x1, y1, x2
, y2
, x3
, y3
))
1675 let xoff = float (xadjsb ()) in
1679 and x3
= x3
+. xoff in
1681 (pageno, c, (x0, y0, x1, y1, x2
, y2
, x3
, y3
)) :: state
.rects1
1683 | "page" :: args
:: [] ->
1684 let pageopaques, t
= scan args
"%s %f" (fun p t
-> p
, t
) in
1685 let pageopaque = ~
< pageopaques in
1686 begin match state
.currently
with
1687 | Loading
(l, gen
) ->
1688 vlog "page %d took %f sec" l.pageno t
;
1689 Hashtbl.replace state
.pagemap
(l.pageno, gen
) pageopaque;
1690 begin match state
.throttle
with
1692 let preloadedpages =
1694 then preloadlayout state
.y
1699 List.fold_left
(fun s l -> IntSet.add
l.pageno s)
1700 IntSet.empty
preloadedpages
1703 Hashtbl.fold (fun ((pageno, _) as key) opaque
accu ->
1704 if not
(IntSet.mem
pageno set)
1706 wcmd "freepage %s" (~
> opaque
);
1712 List.iter
(Hashtbl.remove state
.pagemap
) evictedpages;
1715 state
.currently
<- Idle
;
1718 tilepage l.pageno pageopaque state
.layout;
1720 load preloadedpages;
1721 let visible = pagevisible state
.layout l.pageno in
1724 match state
.mode
with
1725 | LinkNav
(Ltnotready
(pageno, dir
)) ->
1726 if pageno = l.pageno
1731 then LDfirstvisible
(l.pagex
, l.pagey, dir
)
1733 if dir
> 0 then LDfirst
else LDlast
1736 findlink
pageopaque ld
1741 showlinktype (getlink
pageopaque n);
1742 state
.mode
<- LinkNav
(Ltexact
(l.pageno, n))
1744 | LinkNav
(Ltgendir
_)
1745 | LinkNav
(Ltexact
_)
1751 if visible && layoutready state
.layout
1753 G.postRedisplay "page";
1757 | Some
(layout, _, _) ->
1758 state
.currently
<- Idle
;
1759 tilepage l.pageno pageopaque layout;
1766 dolog
"Inconsistent loading state";
1767 logcurrently state
.currently
;
1771 | "tile" :: args
:: [] ->
1772 let (x, y, opaques
, size
, t
) =
1773 scan args
"%u %u %s %u %f"
1774 (fun x y p size t
-> (x, y, p
, size
, t
))
1776 let opaque = ~
< opaques
in
1777 begin match state
.currently
with
1778 | Tiling
(l, pageopaque, cs
, angle
, gen
, col, row, tilew
, tileh
) ->
1779 vlog "tile %d [%d,%d] took %f sec" l.pageno col row t
;
1782 if tilew
!= conf
.tilew
|| tileh
!= conf
.tileh
1784 wcmd "freetile %s" (~
> opaque);
1785 state
.currently
<- Idle
;
1789 puttileopaque l col row gen cs angle
opaque size t
;
1790 state
.memused
<- state
.memused
+ size
;
1791 state
.uioh#infochanged Memused
;
1793 Queue.push
((l.pageno, gen
, cs
, angle
, l.pagew
, l.pageh
, col, row),
1794 opaque, size
) state
.tilelru
;
1797 match state
.throttle
with
1798 | None
-> state
.layout
1799 | Some
(layout, _, _) -> layout
1802 state
.currently
<- Idle
;
1804 && conf
.colorspace
= cs
1805 && conf
.angle
= angle
1806 && tilevisible layout l.pageno x y
1807 then conttiling l.pageno pageopaque;
1809 begin match state
.throttle
with
1811 preload state
.layout;
1813 && conf
.colorspace
= cs
1814 && conf
.angle
= angle
1815 && tilevisible state
.layout l.pageno x y
1816 && (not
!wtmode || layoutready state
.layout)
1817 then G.postRedisplay "tile nothrottle";
1819 | Some
(layout, y, _) ->
1820 let ready = layoutready layout in
1824 state
.layout <- layout;
1825 state
.throttle
<- None
;
1826 G.postRedisplay "throttle";
1835 dolog
"Inconsistent tiling state";
1836 logcurrently state
.currently
;
1840 | "pdim" :: args
:: [] ->
1841 let (n, w, h, _) as pdim
=
1842 scan args
"%u %u %u %u" (fun n w h x -> n, w, h, x)
1845 match conf
.fitmodel
with
1847 | FitPage
| FitProportional
->
1848 match conf
.columns
with
1849 | Csplit
_ -> (n, w, h, 0)
1850 | Csingle
_ | Cmulti
_ -> pdim
1852 state
.uioh#infochanged Pdim
;
1853 state
.pdims
<- pdim :: state
.pdims
1855 | "o" :: args
:: [] ->
1856 let (l, n, t
, h, pos
) =
1857 scan args
"%u %u %d %u %n"
1858 (fun l n t
h pos
-> l, n, t
, h, pos
)
1860 let s = String.sub args pos
(String.length args
- pos
) in
1861 addoutline (s, l, Oanchor
(n, float t
/. float h, 0.0))
1863 | "ou" :: args
:: [] ->
1864 let (l, len, pos
) = scan args
"%u %u %n" (fun l len pos
-> l, len, pos
) in
1865 let s = String.sub args pos
len in
1866 let pos2 = pos
+ len + 1 in
1867 let uri = String.sub args
pos2 (String.length args
- pos2) in
1868 addoutline (s, l, Ouri
uri)
1870 | "on" :: args
:: [] ->
1871 let (l, pos
) = scan args
"%u %n" (fun l pos
-> l, pos
) in
1872 let s = String.sub args pos
(String.length args
- pos
) in
1873 addoutline (s, l, Onone
)
1875 | "a" :: args
:: [] ->
1877 scan args
"%u %d %d" (fun n l t
-> n, l, t
)
1879 state
.reprf
<- (fun () -> gotopagexy n (float l) (float t
))
1881 | "info" :: args
:: [] ->
1882 let pos = nindex args '
\t'
in
1883 if pos >= 0 && String.sub args
0 pos = "Title"
1885 let s = String.sub args
(pos+1) @@ String.length args
- pos - 1 in
1889 state
.docinfo
<- (1, args
) :: state
.docinfo
1891 | "infoend" :: [] ->
1892 state
.uioh#infochanged Docinfo
;
1893 state
.docinfo
<- List.rev state
.docinfo
1897 then Wsi.settitle
"Wrong password";
1898 let password = getpassword () in
1899 if emptystr
password
1900 then error
"document is password protected"
1901 else opendoc state
.path
password
1904 error
"unknown cmd `%S'" cmds
1909 let action = function
1910 | HCprev
-> cbget cb ~
-1
1911 | HCnext
-> cbget cb
1
1912 | HCfirst
-> cbget cb ~
-(cb
.rc)
1913 | HClast
-> cbget cb
(cb
.len - 1 - cb
.rc)
1914 and cancel
() = cb
.rc <- rc
1918 let search pattern forward
=
1919 match conf
.columns
with
1921 showtext '
!'
"searching does not work properly in split columns mode"
1924 if nonemptystr pattern
1927 match state
.layout with
1930 l.pageno, (l.pagey + if forward
then 0 else 0*l.pagevh)
1932 wcmd "search %d %d %d %d,%s\000"
1933 (btod conf
.icase
) pn py (btod forward
) pattern
;
1936 let intentry text key =
1938 if key >= 32 && key < 127
1944 let text = addchar
text c in
1948 state
.text <- Printf.sprintf
"invalid char (%d, `%c')" key c;
1956 let l = String.length
s in
1957 let rec loop pos n = if pos = l then n else
1958 let m = Char.code
s.[pos] - (if pos = 0 && l > 1 then 96 else 97) in
1959 loop (pos+1) (n*26 + m)
1962 let rec loop n = function
1965 match getopaque l.pageno with
1966 | None
-> loop n rest
1968 let m = getlinkcount
opaque in
1971 let under = getlink
opaque n in
1974 else loop (n-m) rest
1976 loop n state
.layout;
1980 let linknentry text key =
1982 if key >= 32 && key < 127
1988 let text = addchar
text c in
1989 linknact (fun under -> state
.text <- undertext ~nopath
:true under) text;
1993 state
.text <- Printf.sprintf
"invalid char (%d, `%c')" key c;
1997 let textentry text key =
1998 if key land 0xff00 = 0xff00
2000 else TEcont
(text ^ toutf8
key)
2003 let reqlayout angle fitmodel
=
2004 match state
.throttle
with
2006 if nogeomcmds state
.geomcmds
2007 then state
.anchor <- getanchor
();
2008 conf
.angle
<- angle
mod 360;
2011 match state
.mode
with
2012 | LinkNav
_ -> state
.mode
<- View
2017 conf
.fitmodel
<- fitmodel
;
2018 invalidate "reqlayout"
2020 wcmd "reqlayout %d %d %d"
2021 conf
.angle
(FMTE.to_int conf
.fitmodel
) (stateh state
.winh
)
2026 let settrim trimmargins trimfuzz
=
2027 if nogeomcmds state
.geomcmds
2028 then state
.anchor <- getanchor
();
2029 conf
.trimmargins
<- trimmargins
;
2030 conf
.trimfuzz
<- trimfuzz
;
2031 let x0, y0, x1, y1 = trimfuzz
in
2032 invalidate "settrim"
2034 wcmd "settrim %d %d %d %d %d" (btod conf
.trimmargins
) x0 y0 x1 y1);
2039 match state
.throttle
with
2041 let zoom = max
0.0001 zoom in
2042 if zoom <> conf
.zoom
2044 state
.prevzoom
<- (conf
.zoom, state
.x);
2046 reshape state
.winw state
.winh
;
2047 state
.text <- Printf.sprintf
"zoom is now %-5.2f" (zoom *. 100.0);
2050 | Some
(layout, y, started
) ->
2052 match conf
.maxwait
with
2056 let dt = now
() -. started
in
2064 let setcolumns mode columns coverA coverB
=
2065 state
.prevcolumns
<- Some
(conf
.columns
, conf
.zoom);
2069 then showtext '
!'
"split mode doesn't work in bird's eye"
2071 conf
.columns
<- Csplit
(-columns
, E.a);
2079 conf
.columns
<- Csingle
E.a;
2084 conf
.columns
<- Cmulti
((columns
, coverA
, coverB
), E.a);
2088 reshape state
.winw state
.winh
;
2091 let resetmstate () =
2092 state
.mstate
<- Mnone
;
2093 Wsi.setcursor
Wsi.CURSOR_INHERIT
;
2096 let enterbirdseye () =
2097 let zoom = float conf
.thumbw
/. float state
.winw
in
2098 let birdseyepageno =
2099 let cy = state
.winh
/ 2 in
2103 let rec fold best
= function
2106 let d = cy - (l.pagedispy + l.pagevh/2)
2107 and dbest
= cy - (best
.pagedispy + best
.pagevh/2) in
2108 if abs
d < abs dbest
2115 state
.mode
<- Birdseye
(
2116 { conf
with zoom = conf
.zoom }, state
.x, birdseyepageno, -1, getanchor
()
2120 conf
.presentation
<- false;
2121 conf
.interpagespace
<- 10;
2122 conf
.hlinks
<- false;
2123 conf
.fitmodel
<- FitPage
;
2125 conf
.maxwait
<- None
;
2127 match conf
.beyecolumns
with
2130 Cmulti
((c, 0, 0), E.a)
2131 | None
-> Csingle
E.a
2135 state
.text <- Printf.sprintf
"birds eye mode on (zoom %3.1f%%)"
2140 reshape state
.winw state
.winh
;
2143 let leavebirdseye (c, leftx
, pageno, _, anchor) goback
=
2145 conf
.zoom <- c.zoom;
2146 conf
.presentation
<- c.presentation
;
2147 conf
.interpagespace
<- c.interpagespace
;
2148 conf
.maxwait
<- c.maxwait
;
2149 conf
.hlinks
<- c.hlinks
;
2150 conf
.fitmodel
<- c.fitmodel
;
2151 conf
.beyecolumns
<- (
2152 match conf
.columns
with
2153 | Cmulti
((c, _, _), _) -> Some
c
2155 | Csplit
_ -> failwith
"leaving bird's eye split mode"
2158 match c.columns
with
2159 | Cmulti
(c, _) -> Cmulti
(c, E.a)
2160 | Csingle
_ -> Csingle
E.a
2161 | Csplit
(c, _) -> Csplit
(c, E.a)
2165 state
.text <- Printf.sprintf
"birds eye mode off (zoom %3.1f%%)"
2168 reshape state
.winw state
.winh
;
2169 state
.anchor <- if goback
then anchor else (pageno, 0.0, 1.0);
2173 let togglebirdseye () =
2174 match state
.mode
with
2175 | Birdseye vals
-> leavebirdseye vals
true
2176 | View
-> enterbirdseye ()
2181 let upbirdseye incr
(conf
, leftx
, pageno, hooverpageno
, anchor) =
2182 let pageno = max
0 (pageno - incr
) in
2183 let rec loop = function
2184 | [] -> gotopage1 pageno 0
2185 | l :: _ when l.pageno = pageno ->
2186 if l.pagedispy >= 0 && l.pagey = 0
2187 then G.postRedisplay "upbirdseye"
2188 else gotopage1 pageno 0
2189 | _ :: rest
-> loop rest
2193 state
.mode
<- Birdseye
(conf
, leftx
, pageno, hooverpageno
, anchor)
2196 let downbirdseye incr
(conf
, leftx
, pageno, hooverpageno
, anchor) =
2197 let pageno = min
(state
.pagecount
- 1) (pageno + incr
) in
2198 state
.mode
<- Birdseye
(conf
, leftx
, pageno, hooverpageno
, anchor);
2199 let rec loop = function
2201 let y, h = getpageyh
pageno in
2202 let dy = (y - state
.y) - (state
.winh
- h - conf
.interpagespace
) in
2204 | l :: _ when l.pageno = pageno ->
2205 if l.pagevh != l.pageh
2206 then gotoy (clamp (l.pageh
- l.pagevh + conf
.interpagespace
))
2207 else G.postRedisplay "downbirdseye"
2208 | _ :: rest
-> loop rest
2214 let optentry mode
_ key =
2215 let btos b = if b then "on" else "off" in
2216 if key >= 32 && key < 127
2218 let c = Char.chr
key in
2222 try conf
.scrollstep
<- int_of_string
s with exc
->
2223 state
.text <- Printf.sprintf
"bad integer `%s': %s" s @@ exntos exc
2225 TEswitch
("scroll step: ", E.s, None
, intentry, ondone, true)
2230 conf
.autoscrollstep
<- boundastep state
.winh
(int_of_string
s);
2231 if state
.autoscroll
<> None
2232 then state
.autoscroll
<- Some conf
.autoscrollstep
2234 state
.text <- Printf.sprintf
"bad integer `%s': %s" s @@ exntos exc
2236 TEswitch
("auto scroll step: ", E.s, None
, intentry, ondone, true)
2241 let n, a, b = multicolumns_of_string
s in
2242 setcolumns mode
n a b;
2244 state
.text <- Printf.sprintf
"bad columns `%s': %s" s @@ exntos exc
2246 TEswitch
("columns: ", E.s, None
, textentry, ondone, true)
2251 let zoom = float (int_of_string
s) /. 100.0 in
2254 state
.text <- Printf.sprintf
"bad integer `%s': %s" s @@ exntos exc
2256 TEswitch
("zoom: ", E.s, None
, intentry, ondone, true)
2261 conf
.thumbw
<- bound
(int_of_string
s) 2 4096;
2263 Printf.sprintf
"thumbnail width is set to %d" conf
.thumbw
;
2264 begin match mode
with
2266 leavebirdseye beye
false;
2273 state
.text <- Printf.sprintf
"bad integer `%s': %s" s @@ exntos exc
2275 TEswitch
("thumbnail width: ", E.s, None
, intentry, ondone, true)
2280 Some
(int_of_string
s)
2283 Printf.sprintf
"bad integer `%s': %s" s @@ exntos exc
;
2286 | Some angle
-> reqlayout angle conf
.fitmodel
2289 TEswitch
("rotation: ", E.s, None
, intentry, ondone, true)
2292 conf
.icase
<- not conf
.icase
;
2293 TEdone
("case insensitive search " ^
(btos conf
.icase
))
2296 conf
.preload <- not conf
.preload;
2298 TEdone
("preload " ^
(btos conf
.preload))
2301 conf
.verbose
<- not conf
.verbose
;
2302 TEdone
("verbose " ^
(btos conf
.verbose
))
2305 conf
.debug
<- not conf
.debug
;
2306 TEdone
("debug " ^
(btos conf
.debug
))
2309 conf
.maxhfit
<- not conf
.maxhfit
;
2310 state
.maxy
<- calcheight
();
2311 TEdone
("maxhfit " ^
(btos conf
.maxhfit
))
2314 conf
.crophack
<- not conf
.crophack
;
2315 TEdone
("crophack " ^
btos conf
.crophack
)
2319 match conf
.maxwait
with
2321 conf
.maxwait
<- Some infinity
;
2322 "always wait for page to complete"
2324 conf
.maxwait
<- None
;
2325 "show placeholder if page is not ready"
2330 conf
.underinfo
<- not conf
.underinfo
;
2331 TEdone
("underinfo " ^
btos conf
.underinfo
)
2334 conf
.savebmarks
<- not conf
.savebmarks
;
2335 TEdone
("persistent bookmarks " ^
btos conf
.savebmarks
)
2341 match state
.layout with
2346 conf
.interpagespace
<- int_of_string
s;
2347 docolumns conf
.columns
;
2348 state
.maxy
<- calcheight
();
2349 let y = getpagey
pageno in
2352 state
.text <- Printf.sprintf
"bad integer `%s': %s" s @@ exntos exc
2354 TEswitch
("vertical margin: ", E.s, None
, intentry, ondone, true)
2358 match conf
.fitmodel
with
2359 | FitProportional
-> FitWidth
2360 | FitWidth
| FitPage
-> FitProportional
2362 reqlayout conf
.angle
fm;
2363 TEdone
("proportional display " ^
btos (fm == FitProportional
))
2366 settrim (not conf
.trimmargins
) conf
.trimfuzz
;
2367 TEdone
("trim margins " ^
btos conf
.trimmargins
)
2370 conf
.invert
<- not conf
.invert
;
2371 TEdone
("invert colors " ^
btos conf
.invert
)
2375 cbput state
.hists
.sel
s;
2378 TEswitch
("selection command: ", E.s, Some
(onhist state
.hists
.sel
),
2379 textentry, ondone, true)
2383 then conf
.pax
<- Some
(ref (0.0, 0, 0))
2384 else conf
.pax
<- None
;
2385 TEdone
("PAX " ^
btos (conf
.pax
!= None
))
2388 state
.text <- Printf.sprintf
"bad option %d `%c'" key c;
2394 class type lvsource
= object
2395 method getitemcount
: int
2396 method getitem
: int -> (string * int)
2397 method hasaction
: int -> bool
2405 method getactive
: int
2406 method getfirst
: int
2408 method getminfo
: (int * int) array
2411 class virtual lvsourcebase
= object
2412 val mutable m_active
= 0
2413 val mutable m_first
= 0
2414 val mutable m_pan
= 0
2415 method getactive
= m_active
2416 method getfirst
= m_first
2417 method getpan
= m_pan
2418 method getminfo
: (int * int) array
= E.a
2421 let textentrykeyboard
2422 key _mask
((c, text, opthist
, onkey
, ondone, cancelonempty
), onleave
) =
2425 if key >= 0xffb0 && key <= 0xffb9
2426 then key - 0xffb0 + 48 else key
2429 state
.mode
<- Textentry
(te
, onleave
);
2431 G.postRedisplay "textentrykeyboard enttext";
2433 let histaction cmd
=
2436 | Some
(action, _) ->
2437 state
.mode
<- Textentry
(
2438 (c, action cmd
, opthist
, onkey
, ondone, cancelonempty
), onleave
2440 G.postRedisplay "textentry histaction"
2444 if emptystr
text && cancelonempty
2447 G.postRedisplay "textentrykeyboard after cancel";
2450 let s = withoutlastutf8
text in
2451 enttext (c, s, opthist
, onkey
, ondone, cancelonempty
)
2453 | @enter
| @kpenter
->
2456 G.postRedisplay "textentrykeyboard after confirm"
2458 | @up
| @kpup
-> histaction HCprev
2459 | @down
| @kpdown
-> histaction HCnext
2460 | @home
| @kphome
-> histaction HCfirst
2461 | @jend
| @kpend
-> histaction HClast
2466 begin match opthist
with
2468 | Some
(_, onhistcancel
) -> onhistcancel
()
2472 G.postRedisplay "textentrykeyboard after cancel2"
2475 enttext (c, E.s, opthist
, onkey
, ondone, cancelonempty
)
2478 | @delete
| @kpdelete
-> ()
2481 && key land 0xff00 != 0xff00 (* keyboard *)
2482 && key land 0xfe00 != 0xfe00 (* xkb *)
2483 && key land 0xfd00 != 0xfd00 (* 3270 *)
2485 begin match onkey
text key with
2489 G.postRedisplay "textentrykeyboard after confirm2";
2492 enttext (c, text, opthist
, onkey
, ondone, cancelonempty
);
2496 G.postRedisplay "textentrykeyboard after cancel3"
2499 state
.mode
<- Textentry
(te
, onleave
);
2500 G.postRedisplay "textentrykeyboard switch";
2504 vlog "unhandled key %s" (Wsi.keyname
key)
2507 let firstof first active
=
2508 if first
> active
|| abs
(first
- active
) > fstate
.maxrows
- 1
2509 then max
0 (active
- (fstate
.maxrows
/2))
2513 let calcfirst first active
=
2516 let rows = active
- first
in
2517 if rows > fstate
.maxrows
then active
- fstate
.maxrows
else first
2521 let scrollph y maxy
=
2522 let sh = float (maxy
+ state
.winh
) /. float state
.winh
in
2523 let sh = float state
.winh
/. sh in
2524 let sh = max
sh (float conf
.scrollh
) in
2526 let percent = float y /. float maxy
in
2527 let position = (float state
.winh
-. sh) *. percent in
2530 if position +. sh > float state
.winh
2531 then float state
.winh
-. sh
2537 let coe s = (s :> uioh
);;
2539 class listview ~zebra ~helpmode ~
(source
:lvsource
) ~trusted ~modehash
=
2541 val m_pan
= source#getpan
2542 val m_first
= source#getfirst
2543 val m_active
= source#getactive
2545 val m_prev_uioh
= state
.uioh
2547 method private elemunder
y =
2551 let n = y / (fstate
.fontsize
+1) in
2552 if m_first
+ n < source#getitemcount
2554 if source#hasaction
(m_first
+ n)
2555 then Some
(m_first
+ n)
2562 GlFunc.blend_func ~src
:`src_alpha ~dst
:`one_minus_src_alpha
;
2563 GlDraw.color
(0., 0., 0.) ~alpha
:0.85;
2564 filledrect 0. 0. (float state
.winw
) (float state
.winh
);
2565 GlDraw.color
(1., 1., 1.);
2566 Gl.enable `texture_2d
;
2567 let fs = fstate
.fontsize
in
2569 let hw = (wadjsb () + xadjsb () + state
.winw
)/3 in
2570 let ww = fstate
.wwidth
in
2571 let tabw = 17.0*.ww in
2572 let itemcount = source#getitemcount
in
2573 let minfo = source#getminfo
in
2576 then float (xadjsb ()), float (state
.winw
- 1)
2577 else 0.0, float (state
.winw
- conf
.scrollbw
- 1)
2579 let xadj = xadjsb () in
2581 if (row - m_first
) > fstate
.maxrows
2584 if row >= 0 && row < itemcount
2586 let (s, level
) = source#getitem
row in
2587 let y = (row - m_first
) * nfs in
2589 (if conf
.leftscroll
then float xadj else 5.0)
2590 +. (float (level
+ m_pan
)) *. ww in
2593 (let c = if row land 1 = 0 then 1.0 else 0.92 in (c,c,c));
2597 Gl.disable `texture_2d
;
2598 let alpha = if source#hasaction
row then 0.9 else 0.3 in
2599 GlDraw.color
(1., 1., 1.) ~
alpha;
2600 linerect (x0 +. 1.) (float (y + 1)) (x1) (float (y + fs + 3));
2601 Gl.enable `texture_2d
;
2604 if zebra
&& row land 1 = 1
2608 GlDraw.color
(c,c,c);
2609 let drawtabularstring s =
2611 let x'
= truncate
(x0 +. x) in
2612 let pos = nindex
s '
\000'
in
2614 then drawstring1 fs x'
(y+nfs) s
2616 let s1 = String.sub
s 0 pos
2617 and s2
= String.sub
s (pos+1) (String.length
s - pos - 1) in
2622 let s'
= withoutlastutf8
s in
2623 let s = s' ^
"@Uellipsis" in
2624 let w = measurestr
fs s in
2625 if float x'
+. w +. ww < float (hw + x'
)
2630 if float x'
+. ww +. measurestr
fs s1 > float (hw + x'
)
2634 ignore
(drawstring1 fs x'
(y+nfs) s1);
2635 drawstring1 fs (hw + x'
) (y+nfs) s2
2639 let x = if helpmode
&& row > 0 then x +. ww else x in
2640 let tabpos = nindex
s '
\t'
in
2643 let len = String.length
s - tabpos - 1 in
2644 let s1 = String.sub
s 0 tabpos
2645 and s2
= String.sub
s (tabpos + 1) len in
2646 let nx = drawstr x s1 in
2648 let x = x +. (max
tabw sw) in
2651 let len = String.length
s - 2 in
2652 if len > 0 && s.[0] = '
\xc2'
&& s.[1] = '
\xb7'
2654 let s = String.sub
s 2 len in
2655 let x = if not helpmode
then x +. ww else x in
2656 GlDraw.color
(1.2, 1.2, 1.2);
2657 let vinc = drawstring1 (fs+fs/4)
2658 (truncate
(x -. ww)) (y+nfs) s in
2659 GlDraw.color
(1., 1., 1.);
2660 vinc +. (float fs *. 0.8)
2666 ignore
(drawtabularstring s);
2672 GlDraw.color
(1.0, 1.0, 1.0) ~
alpha:0.5;
2673 let xadj = float (xadjsb () + 5) in
2675 if (row - m_first
) > fstate
.maxrows
2678 if row >= 0 && row < itemcount
2680 let (s, level
) = source#getitem
row in
2681 let pos0 = nindex
s '
\000'
in
2682 let y = (row - m_first
) * nfs in
2683 let x = float (level
+ m_pan
) *. ww in
2684 let (first
, last
) = minfo.(row) in
2686 if pos0 > 0 && first
> pos0
2687 then String.sub
s (pos0+1) (first
-pos0-1)
2688 else String.sub
s 0 first
2690 let suffix = String.sub
s first
(last
- first
) in
2691 let w1 = measurestr fstate
.fontsize
prefix in
2692 let w2 = measurestr fstate
.fontsize
suffix in
2693 let x = x +. if conf
.leftscroll
then xadj else 5.0 in
2694 let x = if pos0 > 0 && first
> pos0 then x +. float hw else x in
2696 and y0 = float (y+2) in
2698 and y1 = float (y+fs+3) in
2699 filledrect x0 y0 x1 y1;
2704 Gl.disable `texture_2d
;
2705 if Array.length
minfo > 0 then loop m_first
;
2708 method updownlevel incr
=
2709 let len = source#getitemcount
in
2711 if m_active
>= 0 && m_active
< len
2712 then snd
(source#getitem m_active
)
2716 if i
= len then i
-1 else if i
= -1 then 0 else
2717 let _, l = source#getitem i
in
2718 if l != curlevel then i
else flow (i
+incr
)
2720 let active = flow m_active
in
2721 let first = calcfirst m_first
active in
2722 G.postRedisplay "outline updownlevel";
2723 {< m_active
= active; m_first
= first >}
2725 method private key1
key mask
=
2726 let set1 active first qsearch
=
2727 coe {< m_active
= active; m_first
= first; m_qsearch
= qsearch
>}
2729 let search active pattern incr
=
2730 let active = if active = -1 then m_first
else active in
2733 if n >= 0 && n < source#getitemcount
2735 let s, _ = source#getitem
n in
2737 (try ignore
(Str.search_forward re
s 0); true
2738 with Not_found
-> false)
2740 else loop (n + incr
)
2747 let re = Str.regexp_case_fold pattern
in
2753 let itemcount = source#getitemcount
in
2754 let find start incr
=
2756 if i
= -1 || i
= itemcount
2759 if source#hasaction i
2761 else find (i
+ incr
)
2766 let set active first =
2767 let first = bound
first 0 (itemcount - fstate
.maxrows
) in
2769 coe {< m_active
= active; m_first
= first; m_qsearch
= E.s >}
2772 let isvisible first n = n >= first && n - first <= fstate
.maxrows
in
2774 let incr1 = if incr
> 0 then 1 else -1 in
2775 if isvisible m_first m_active
2778 let next = m_active
+ incr
in
2780 if next < 0 || next >= itemcount
2782 else find next incr1
2784 if abs
(m_active
- next) > fstate
.maxrows
2790 let first = m_first
+ incr
in
2791 let first = bound
first 0 (itemcount - fstate
.maxrows
) in
2793 let next = m_active
+ incr
in
2794 let next = bound
next 0 (itemcount - 1) in
2801 if isvisible first next
2808 let first = min
next m_first
in
2810 if abs
(next - first) > fstate
.maxrows
2816 let first = m_first
+ incr
in
2817 let first = bound
first 0 (itemcount - 1) in
2819 let next = m_active
+ incr
in
2820 let next = bound
next 0 (itemcount - 1) in
2821 let next = find next incr1 in
2823 if next = -1 || abs
(m_active
- first) > fstate
.maxrows
2825 let active = if m_active
= -1 then next else m_active
in
2830 if isvisible first active
2836 G.postRedisplay "listview navigate";
2840 | (@r
|@s) when Wsi.withctrl mask
->
2841 let incr = if key = @r
then -1 else 1 in
2843 match search (m_active
+ incr) m_qsearch
incr with
2845 state
.text <- m_qsearch ^
" [not found]";
2848 state
.text <- m_qsearch
;
2849 active, firstof m_first
active
2851 G.postRedisplay "listview ctrl-r/s";
2852 set1 active first m_qsearch
;
2854 | @insert
when Wsi.withctrl mask
->
2855 if m_active
>= 0 && m_active
< source#getitemcount
2857 let s, _ = source#getitem m_active
in
2863 if emptystr m_qsearch
2866 let qsearch = withoutlastutf8 m_qsearch
in
2870 G.postRedisplay "listview empty qsearch";
2871 set1 m_active m_first
E.s;
2875 match search m_active
qsearch ~
-1 with
2877 state
.text <- qsearch ^
" [not found]";
2880 state
.text <- qsearch;
2881 active, firstof m_first
active
2883 G.postRedisplay "listview backspace qsearch";
2884 set1 active first qsearch
2887 | key when (key != 0 && key land 0xff00 != 0xff00) ->
2888 let pattern = m_qsearch ^ toutf8
key in
2890 match search m_active
pattern 1 with
2892 state
.text <- pattern ^
" [not found]";
2895 state
.text <- pattern;
2896 active, firstof m_first
active
2898 G.postRedisplay "listview qsearch add";
2899 set1 active first pattern;
2903 if emptystr m_qsearch
2905 G.postRedisplay "list view escape";
2906 let mx, my
= state
.mpos
in
2910 source#exit ~uioh
:(coe self
)
2911 ~cancel
:true ~
active:m_active ~
first:m_first ~pan
:m_pan
2913 | None
-> m_prev_uioh
2918 G.postRedisplay "list view kill qsearch";
2919 coe {< m_qsearch
= E.s >}
2922 | @enter
| @kpenter
->
2924 let self = {< m_qsearch
= E.s >} in
2926 G.postRedisplay "listview enter";
2927 if m_active
>= 0 && m_active
< source#getitemcount
2929 source#exit ~uioh
:(coe self) ~cancel
:false
2930 ~
active:m_active ~
first:m_first ~pan
:m_pan
;
2933 source#exit ~uioh
:(coe self) ~cancel
:true
2934 ~
active:m_active ~
first:m_first ~pan
:m_pan
;
2937 begin match opt with
2938 | None
-> m_prev_uioh
2942 | @delete
| @kpdelete
->
2945 | @up
| @kpup
-> navigate ~
-1
2946 | @down
| @kpdown
-> navigate 1
2947 | @prior
| @kpprior
-> navigate ~
-(fstate
.maxrows
)
2948 | @next | @kpnext
-> navigate fstate
.maxrows
2950 | @right
| @kpright
->
2952 G.postRedisplay "listview right";
2953 coe {< m_pan
= m_pan
- 1 >}
2955 | @left | @kpleft
->
2957 G.postRedisplay "listview left";
2958 coe {< m_pan
= m_pan
+ 1 >}
2960 | @home
| @kphome
->
2961 let active = find 0 1 in
2962 G.postRedisplay "listview home";
2966 let first = max
0 (itemcount - fstate
.maxrows
) in
2967 let active = find (itemcount - 1) ~
-1 in
2968 G.postRedisplay "listview end";
2971 | key when (key = 0 || key land 0xff00 = 0xff00) ->
2975 dolog
"listview unknown key %#x" key; coe self
2977 method key key mask
=
2978 match state
.mode
with
2979 | Textentry te
-> textentrykeyboard key mask te
; coe self
2982 | LinkNav
_ -> self#key1
key mask
2984 method button button down
x y _ =
2987 | 1 when x > state
.winw
- conf
.scrollbw
->
2988 G.postRedisplay "listview scroll";
2991 let _, position, sh = self#
scrollph in
2992 if y > truncate
position && y < truncate
(position +. sh)
2994 state
.mstate
<- Mscrolly
;
2998 let s = float (max
0 (y - conf
.scrollh
)) /. float state
.winh
in
2999 let first = truncate
(s *. float source#getitemcount
) in
3000 let first = min source#getitemcount
first in
3001 Some
(coe {< m_first
= first; m_active
= first >})
3003 state
.mstate
<- Mnone
;
3007 begin match self#elemunder
y with
3009 G.postRedisplay "listview click";
3010 source#exit ~uioh
:(coe {< m_active
= n >})
3011 ~cancel
:false ~
active:n ~
first:m_first ~pan
:m_pan
3015 | n when (n == 4 || n == 5) && not down
->
3016 let len = source#getitemcount
in
3018 if n = 5 && m_first
+ fstate
.maxrows
>= len
3022 let first = m_first
+ (if n == 4 then -1 else 1) in
3023 bound
first 0 (len - 1)
3025 G.postRedisplay "listview wheel";
3026 Some
(coe {< m_first
= first >})
3027 | n when (n = 6 || n = 7) && not down
->
3028 let inc = if n = 7 then -1 else 1 in
3029 G.postRedisplay "listview hwheel";
3030 Some
(coe {< m_pan
= m_pan
+ inc >})
3035 | None
-> m_prev_uioh
3038 method multiclick
_ x y = self#button
1 true x y
3041 match state
.mstate
with
3043 let s = float (max
0 (y - conf
.scrollh
)) /. float state
.winh
in
3044 let first = truncate
(s *. float source#getitemcount
) in
3045 let first = min source#getitemcount
first in
3046 G.postRedisplay "listview motion";
3047 coe {< m_first
= first; m_active
= first >}
3055 method pmotion
x y =
3056 if x < state
.winw
- conf
.scrollbw
3059 match self#elemunder
y with
3060 | None
-> Wsi.setcursor
Wsi.CURSOR_INHERIT
; m_active
3061 | Some
n -> Wsi.setcursor
Wsi.CURSOR_INFO
; n
3065 then (G.postRedisplay "listview pmotion"; {< m_active
= n >})
3070 Wsi.setcursor
Wsi.CURSOR_INHERIT
;
3074 method infochanged
_ = ()
3076 method scrollpw
= (0, 0.0, 0.0)
3078 let nfs = fstate
.fontsize
+ 1 in
3079 let y = m_first
* nfs in
3080 let itemcount = source#getitemcount
in
3081 let maxi = max
0 (itemcount - fstate
.maxrows
) in
3082 let maxy = maxi * nfs in
3083 let p, h = scrollph y maxy in
3086 method modehash
= modehash
3087 method eformsgs
= false
3088 method alwaysscrolly
= true
3091 class outlinelistview ~zebra ~source
=
3092 let settext autonarrow
s =
3095 let ss = source#statestr
in
3099 else "{" ^
ss ^
"} [" ^
s ^
"]"
3100 else state
.text <- s
3106 ~source
:(source
:> lvsource
)
3108 ~modehash
:(findkeyhash conf
"outline")
3111 val m_autonarrow
= false
3113 method! key key mask
=
3115 if emptystr state
.text
3117 else fstate
.maxrows - 2
3119 let calcfirst first active =
3122 let rows = active - first in
3123 if rows > maxrows then active - maxrows else first
3127 let active = m_active
+ incr in
3128 let active = bound
active 0 (source#getitemcount
- 1) in
3129 let first = calcfirst m_first
active in
3130 G.postRedisplay "outline navigate";
3131 coe {< m_active
= active; m_first
= first >}
3133 let navscroll first =
3135 let dist = m_active
- first in
3141 else first + maxrows
3144 G.postRedisplay "outline navscroll";
3145 coe {< m_first
= first; m_active
= active >}
3147 let ctrl = Wsi.withctrl mask
in
3152 then (source#denarrow
; E.s)
3154 let pattern = source#renarrow
in
3155 if nonemptystr m_qsearch
3156 then (source#narrow m_qsearch
; m_qsearch
)
3160 settext (not m_autonarrow
) text;
3161 G.postRedisplay "toggle auto narrowing";
3162 coe {< m_first
= 0; m_active
= 0; m_autonarrow
= not m_autonarrow
>}
3164 | @slash
when emptystr m_qsearch
&& not m_autonarrow
->
3166 G.postRedisplay "toggle auto narrowing";
3167 coe {< m_first
= 0; m_active
= 0; m_autonarrow
= true >}
3170 source#narrow m_qsearch
;
3172 then source#add_narrow_pattern m_qsearch
;
3173 G.postRedisplay "outline ctrl-n";
3174 coe {< m_first
= 0; m_active
= 0 >}
3177 let active = source#calcactive
(getanchor
()) in
3178 let first = firstof m_first
active in
3179 G.postRedisplay "outline ctrl-s";
3180 coe {< m_first
= first; m_active
= active >}
3183 G.postRedisplay "outline ctrl-u";
3184 if m_autonarrow
&& nonemptystr m_qsearch
3186 ignore
(source#renarrow
);
3187 settext m_autonarrow
E.s;
3188 coe {< m_first
= 0; m_active
= 0; m_qsearch
= E.s >}
3191 source#del_narrow_pattern
;
3192 let pattern = source#renarrow
in
3194 if emptystr
pattern then E.s else "Narrowed to " ^
pattern
3196 settext m_autonarrow
text;
3197 coe {< m_first
= 0; m_active
= 0; m_qsearch
= E.s >}
3201 let first = max
0 (m_active
- (fstate
.maxrows / 2)) in
3202 G.postRedisplay "outline ctrl-l";
3203 coe {< m_first
= first >}
3205 | @tab
when m_autonarrow
->
3206 if nonemptystr m_qsearch
3208 G.postRedisplay "outline list view tab";
3209 source#add_narrow_pattern m_qsearch
;
3211 coe {< m_qsearch
= E.s >}
3215 | @escape
when m_autonarrow
->
3216 if nonemptystr m_qsearch
3217 then source#add_narrow_pattern m_qsearch
;
3220 | @enter
| @kpenter
when m_autonarrow
->
3221 if nonemptystr m_qsearch
3222 then source#add_narrow_pattern m_qsearch
;
3225 | key when m_autonarrow
&& (key != 0 && key land 0xff00 != 0xff00) ->
3226 let pattern = m_qsearch ^ toutf8
key in
3227 G.postRedisplay "outlinelistview autonarrow add";
3228 source#narrow
pattern;
3229 settext true pattern;
3230 coe {< m_first
= 0; m_active
= 0; m_qsearch
= pattern >}
3232 | key when m_autonarrow
&& key = @backspace
->
3233 if emptystr m_qsearch
3236 let pattern = withoutlastutf8 m_qsearch
in
3237 G.postRedisplay "outlinelistview autonarrow backspace";
3238 ignore
(source#renarrow
);
3239 source#narrow
pattern;
3240 settext true pattern;
3241 coe {< m_first
= 0; m_active
= 0; m_qsearch
= pattern >}
3243 | @delete
| @kpdelete
->
3244 if source#remove m_active
3246 G.postRedisplay "outline delete";
3247 let active = max
0 (m_active
-1) in
3248 coe {< m_first
= firstof m_first
active;
3249 m_active
= active >}
3253 | @up
| @kpup
when ctrl ->
3254 navscroll (max
0 (m_first
- 1))
3256 | @down
| @kpdown
when ctrl ->
3257 navscroll (min
(source#getitemcount
- 1) (m_first
+ 1))
3259 | @up
| @kpup
-> navigate ~
-1
3260 | @down
| @kpdown
-> navigate 1
3261 | @prior
| @kpprior
-> navigate ~
-(fstate
.maxrows)
3262 | @next | @kpnext
-> navigate fstate
.maxrows
3264 | @right
| @kpright
->
3268 G.postRedisplay "outline ctrl right";
3269 {< m_pan
= m_pan
+ 1 >}
3271 else self#updownlevel
1
3275 | @left | @kpleft
->
3279 G.postRedisplay "outline ctrl left";
3280 {< m_pan
= m_pan
- 1 >}
3282 else self#updownlevel ~
-1
3286 | @home
| @kphome
->
3287 G.postRedisplay "outline home";
3288 coe {< m_first
= 0; m_active
= 0 >}
3291 let active = source#getitemcount
- 1 in
3292 let first = max
0 (active - fstate
.maxrows) in
3293 G.postRedisplay "outline end";
3294 coe {< m_active
= active; m_first
= first >}
3296 | _ -> super#
key key mask
3299 let genhistoutlines () =
3300 Config.gethist
() |>
3302 (fun ((path
, c, _, _, _, _) as hist
) ->
3303 let base = mbtoutf8
@@ Filename.basename path
in
3304 (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
;
3379 let btos b = if b then "@Uradical" else E.s in
3380 let showextended = ref false in
3381 let leave mode
_ = state
.mode
<- mode
in
3384 val mutable m_first_time
= true
3385 val mutable m_l
= []
3386 val mutable m_a
= E.a
3387 val mutable m_prev_uioh
= nouioh
3388 val mutable m_prev_mode
= View
3390 inherit lvsourcebase
3392 method reset prev_mode prev_uioh
=
3393 m_a
<- Array.of_list
(List.rev m_l
);
3395 m_prev_mode
<- prev_mode
;
3396 m_prev_uioh
<- prev_uioh
;
3400 if n >= Array.length m_a
3404 | _, _, _, Action
_ -> m_active
<- n
3405 | _, _, _, Noaction
-> loop (n+1)
3408 m_first_time
<- false;
3411 method int name get
set =
3413 (name
, `
int get
, 1, Action
(
3416 try set (int_of_string
s)
3418 state
.text <- Printf.sprintf
"bad integer `%s': %s"
3422 let te = name ^
": ", E.s, None
, intentry, ondone, true in
3423 state
.mode
<- Textentry
(te, leave m_prev_mode
);
3427 method int_with_suffix name get
set =
3429 (name
, `intws get
, 1, Action
(
3432 try set (int_of_string_with_suffix
s)
3434 state
.text <- Printf.sprintf
"bad integer `%s': %s"
3439 name ^
": ", E.s, None
, intentry_with_suffix, ondone, true
3441 state
.mode
<- Textentry
(te, leave m_prev_mode
);
3445 method bool ?
(offset
=1) ?
(btos=btos) name get
set =
3447 (name
, `
bool (btos, get
), offset
, Action
(
3454 method color name get
set =
3456 (name
, `color get
, 1, Action
(
3458 let invalid = (nan
, nan
, nan
) in
3461 try color_of_string
s
3463 state
.text <- Printf.sprintf
"bad color `%s': %s"
3470 let te = name ^
": ", E.s, None
, textentry, ondone, true in
3471 state
.text <- color_to_string
(get
());
3472 state
.mode
<- Textentry
(te, leave m_prev_mode
);
3476 method string name get
set =
3478 (name
, `
string get
, 1, Action
(
3480 let ondone s = set s in
3481 let te = name ^
": ", E.s, None
, textentry, ondone, true in
3482 state
.mode
<- Textentry
(te, leave m_prev_mode
);
3486 method colorspace name get
set =
3488 (name
, `
string get
, 1, Action
(
3492 inherit lvsourcebase
3495 m_active
<- CSTE.to_int conf
.colorspace
;
3498 method getitemcount
=
3499 Array.length
CSTE.names
3502 method exit ~uioh ~cancel ~
active ~
first ~pan
=
3503 ignore
(uioh
, first, pan
);
3504 if not cancel
then set active;
3506 method hasaction
_ = true
3510 let modehash = findkeyhash conf
"info" in
3511 coe (new listview ~zebra
:false ~helpmode
:false
3512 ~
source ~trusted
:true ~
modehash)
3515 method paxmark name get
set =
3517 (name
, `
string get
, 1, Action
(
3521 inherit lvsourcebase
3524 m_active
<- MTE.to_int conf
.paxmark
;
3527 method getitemcount
= Array.length
MTE.names
3528 method getitem
n = (MTE.names
.(n), 0)
3529 method exit ~uioh ~cancel ~
active ~
first ~pan
=
3530 ignore
(uioh
, first, pan
);
3531 if not cancel
then set active;
3533 method hasaction
_ = true
3537 let modehash = findkeyhash conf
"info" in
3538 coe (new listview ~zebra
:false ~helpmode
:false
3539 ~
source ~trusted
:true ~
modehash)
3542 method fitmodel name get
set =
3544 (name
, `
string get
, 1, Action
(
3548 inherit lvsourcebase
3551 m_active
<- FMTE.to_int conf
.fitmodel
;
3554 method getitemcount
= Array.length
FMTE.names
3555 method getitem
n = (FMTE.names
.(n), 0)
3556 method exit ~uioh ~cancel ~
active ~
first ~pan
=
3557 ignore
(uioh
, first, pan
);
3558 if not cancel
then set active;
3560 method hasaction
_ = true
3564 let modehash = findkeyhash conf
"info" in
3565 coe (new listview ~zebra
:false ~helpmode
:false
3566 ~
source ~trusted
:true ~
modehash)
3569 method caption
s offset
=
3570 m_l
<- (s, `empty
, offset
, Noaction
) :: m_l
3572 method caption2
s f offset
=
3573 m_l
<- (s, `
string f, offset
, Noaction
) :: m_l
3575 method getitemcount
= Array.length m_a
3578 let tostr = function
3579 | `
int f -> string_of_int
(f ())
3580 | `intws
f -> string_with_suffix_of_int
(f ())
3582 | `color
f -> color_to_string
(f ())
3583 | `
bool (btos, f) -> btos (f ())
3586 let name, t
, offset
, _ = m_a
.(n) in
3587 ((let s = tostr t
in
3589 then Printf.sprintf
"%s\t%s" name s
3593 method exit ~uioh ~cancel ~
active ~
first ~pan
=
3598 match m_a
.(active) with
3599 | _, _, _, Action
f -> f uioh
3600 | _, _, _, Noaction
-> uioh
3611 method hasaction
n =
3613 | _, _, _, Action
_ -> true
3614 | _, _, _, Noaction
-> false
3617 let rec fillsrc prevmode prevuioh
=
3618 let sep () = src#caption
E.s 0 in
3619 let colorp name get
set =
3621 (fun () -> color_to_string
(get
()))
3624 let c = color_of_string
v in
3627 state
.text <- Printf.sprintf
"bad color `%s': %s" v @@ exntos exn
3630 let oldmode = state
.mode
in
3631 let birdseye = isbirdseye state
.mode
in
3633 src#caption
(if birdseye then "Setup (Bird's eye)" else "Setup") 0;
3635 src#
bool "presentation mode"
3636 (fun () -> conf
.presentation
)
3637 (fun v -> setpresentationmode v);
3639 src#
bool "ignore case in searches"
3640 (fun () -> conf
.icase
)
3641 (fun v -> conf
.icase
<- v);
3644 (fun () -> conf
.preload)
3645 (fun v -> conf
.preload <- v);
3647 src#
bool "highlight links"
3648 (fun () -> conf
.hlinks
)
3649 (fun v -> conf
.hlinks
<- v);
3651 src#
bool "under info"
3652 (fun () -> conf
.underinfo
)
3653 (fun v -> conf
.underinfo
<- v);
3655 src#
bool "persistent bookmarks"
3656 (fun () -> conf
.savebmarks
)
3657 (fun v -> conf
.savebmarks
<- v);
3659 src#fitmodel
"fit model"
3660 (fun () -> FMTE.to_string conf
.fitmodel
)
3661 (fun v -> reqlayout conf
.angle
(FMTE.of_int
v));
3663 src#
bool "trim margins"
3664 (fun () -> conf
.trimmargins
)
3665 (fun v -> settrim v conf
.trimfuzz
; fillsrc prevmode prevuioh
);
3667 src#
bool "persistent location"
3668 (fun () -> conf
.jumpback
)
3669 (fun v -> conf
.jumpback
<- v);
3672 src#
int "inter-page space"
3673 (fun () -> conf
.interpagespace
)
3675 conf
.interpagespace
<- n;
3676 docolumns conf
.columns
;
3678 match state
.layout with
3683 state
.maxy <- calcheight
();
3684 let y = getpagey
pageno in
3689 (fun () -> conf
.pagebias
)
3690 (fun v -> conf
.pagebias
<- v);
3692 src#
int "scroll step"
3693 (fun () -> conf
.scrollstep
)
3694 (fun n -> conf
.scrollstep
<- n);
3696 src#
int "horizontal scroll step"
3697 (fun () -> conf
.hscrollstep
)
3698 (fun v -> conf
.hscrollstep
<- v);
3700 src#
int "auto scroll step"
3702 match state
.autoscroll
with
3704 | _ -> conf
.autoscrollstep
)
3706 let n = boundastep state
.winh
n in
3707 if state
.autoscroll
<> None
3708 then state
.autoscroll
<- Some
n;
3709 conf
.autoscrollstep
<- n);
3712 (fun () -> truncate
(conf
.zoom *. 100.))
3713 (fun v -> setzoom ((float v) /. 100.));
3716 (fun () -> conf
.angle
)
3717 (fun v -> reqlayout v conf
.fitmodel
);
3719 src#
int "scroll bar width"
3720 (fun () -> conf
.scrollbw
)
3723 reshape state
.winw state
.winh
;
3726 src#
int "scroll handle height"
3727 (fun () -> conf
.scrollh
)
3728 (fun v -> conf
.scrollh
<- v;);
3730 src#
int "thumbnail width"
3731 (fun () -> conf
.thumbw
)
3733 conf
.thumbw
<- min
4096 v;
3736 leavebirdseye beye
false;
3743 let mode = state
.mode in
3744 src#
string "columns"
3746 match conf
.columns
with
3748 | Cmulti
(multi
, _) -> multicolumns_to_string multi
3749 | Csplit
(count
, _) -> "-" ^ string_of_int count
3752 let n, a, b = multicolumns_of_string
v in
3753 setcolumns mode n a b);
3756 src#caption
"Pixmap cache" 0;
3757 src#int_with_suffix
"size (advisory)"
3758 (fun () -> conf
.memlimit
)
3759 (fun v -> conf
.memlimit
<- v);
3762 (fun () -> Printf.sprintf
"%s bytes, %d tiles"
3763 (string_with_suffix_of_int state
.memused
)
3764 (Hashtbl.length state
.tilemap
)) 1;
3767 src#caption
"Layout" 0;
3768 src#caption2
"Dimension"
3770 Printf.sprintf
"%dx%d (virtual %dx%d)"
3771 state
.winw state
.winh
3776 src#caption2
"Position" (fun () ->
3777 Printf.sprintf
"%dx%d" state
.x state
.y
3780 src#caption2
"Position" (fun () -> describe_location ()) 1
3784 src#
bool ~offset
:0 ~
btos:(fun v -> if v then "(on)" else "(off)")
3785 "Save these parameters as global defaults at exit"
3786 (fun () -> conf
.bedefault
)
3787 (fun v -> conf
.bedefault
<- v)
3791 let btos b = if b then "@Ulguillemet" else "@Urguillemet" in
3792 src#
bool ~offset
:0 ~
btos "Extended parameters"
3793 (fun () -> !showextended)
3794 (fun v -> showextended := v; fillsrc prevmode prevuioh
);
3798 (fun () -> conf
.checkers
)
3799 (fun v -> conf
.checkers
<- v; setcheckers v);
3800 src#
bool "update cursor"
3801 (fun () -> conf
.updatecurs
)
3802 (fun v -> conf
.updatecurs
<- v);
3803 src#
bool "scroll-bar on the left"
3804 (fun () -> conf
.leftscroll
)
3805 (fun v -> conf
.leftscroll
<- v);
3807 (fun () -> conf
.verbose
)
3808 (fun v -> conf
.verbose
<- v);
3809 src#
bool "invert colors"
3810 (fun () -> conf
.invert
)
3811 (fun v -> conf
.invert
<- v);
3813 (fun () -> conf
.maxhfit
)
3814 (fun v -> conf
.maxhfit
<- v);
3816 (fun () -> conf
.pax
!= None
)
3819 then conf
.pax
<- Some
(ref (now
(), 0, 0))
3820 else conf
.pax
<- None
);
3821 src#
string "uri launcher"
3822 (fun () -> conf
.urilauncher
)
3823 (fun v -> conf
.urilauncher
<- v);
3824 src#
string "path launcher"
3825 (fun () -> conf
.pathlauncher
)
3826 (fun v -> conf
.pathlauncher
<- v);
3827 src#
string "tile size"
3828 (fun () -> Printf.sprintf
"%dx%d" conf
.tilew conf
.tileh
)
3831 let w, h = Scanf.sscanf
v "%dx%d" (fun w h -> w, h) in
3832 conf
.tilew
<- max
64 w;
3833 conf
.tileh
<- max
64 h;
3836 state
.text <- Printf.sprintf
"bad tile size `%s': %s"
3839 src#
int "texture count"
3840 (fun () -> conf
.texcount
)
3843 then conf
.texcount
<- v
3844 else showtext '
!'
" Failed to set texture count please retry later"
3846 src#
int "slice height"
3847 (fun () -> conf
.sliceheight
)
3849 conf
.sliceheight
<- v;
3850 wcmd "sliceh %d" conf
.sliceheight
;
3852 src#
int "anti-aliasing level"
3853 (fun () -> conf
.aalevel
)
3855 conf
.aalevel
<- bound
v 0 8;
3856 state
.anchor <- getanchor
();
3857 opendoc state
.path state
.password;
3859 src#
string "page scroll scaling factor"
3860 (fun () -> string_of_float conf
.pgscale)
3863 let s = float_of_string
v in
3866 state
.text <- Printf.sprintf
3867 "bad page scroll scaling factor `%s': %s" v @@ exntos exn
3870 src#
int "ui font size"
3871 (fun () -> fstate
.fontsize
)
3872 (fun v -> setfontsize (bound
v 5 100));
3873 src#
int "hint font size"
3874 (fun () -> conf
.hfsize
)
3875 (fun v -> conf
.hfsize
<- bound
v 5 100);
3876 colorp "background color"
3877 (fun () -> conf
.bgcolor
)
3878 (fun v -> conf
.bgcolor
<- v);
3879 src#
bool "crop hack"
3880 (fun () -> conf
.crophack
)
3881 (fun v -> conf
.crophack
<- v);
3882 src#
string "trim fuzz"
3883 (fun () -> irect_to_string conf
.trimfuzz
)
3886 conf
.trimfuzz
<- irect_of_string
v;
3888 then settrim true conf
.trimfuzz
;
3890 state
.text <- Printf.sprintf
"bad irect `%s': %s" v @@ exntos exn
3892 src#
string "throttle"
3894 match conf
.maxwait
with
3895 | None
-> "show place holder if page is not ready"
3898 then "wait for page to fully render"
3900 "wait " ^ string_of_float
time
3901 ^
" seconds before showing placeholder"
3905 let f = float_of_string
v in
3907 then conf
.maxwait
<- None
3908 else conf
.maxwait
<- Some
f
3910 state
.text <- Printf.sprintf
"bad time `%s': %s" v @@ exntos exn
3912 src#
string "ghyll scroll"
3914 match conf
.ghyllscroll
with
3916 | Some nab
-> ghyllscroll_to_string nab
3919 try conf
.ghyllscroll
<- ghyllscroll_of_string
v
3921 state
.text <- Printf.sprintf
"bad ghyll `%s': %s" v @@ exntos exn
3923 src#
string "selection command"
3924 (fun () -> conf
.selcmd
)
3925 (fun v -> conf
.selcmd
<- v);
3926 src#
string "synctex command"
3927 (fun () -> conf
.stcmd
)
3928 (fun v -> conf
.stcmd
<- v);
3929 src#
string "pax command"
3930 (fun () -> conf
.paxcmd
)
3931 (fun v -> conf
.paxcmd
<- v);
3932 src#
string "ask password command"
3933 (fun () -> conf
.passcmd)
3934 (fun v -> conf
.passcmd <- v);
3935 src#
string "save path command"
3936 (fun () -> conf
.savecmd
)
3937 (fun v -> conf
.savecmd
<- v);
3938 src#colorspace
"color space"
3939 (fun () -> CSTE.to_string conf
.colorspace
)
3941 conf
.colorspace
<- CSTE.of_int
v;
3945 src#paxmark
"pax mark method"
3946 (fun () -> MTE.to_string conf
.paxmark
)
3947 (fun v -> conf
.paxmark
<- MTE.of_int
v);
3951 (fun () -> conf
.usepbo
)
3952 (fun v -> conf
.usepbo
<- v);
3953 src#
bool "mouse wheel scrolls pages"
3954 (fun () -> conf
.wheelbypage
)
3955 (fun v -> conf
.wheelbypage
<- v);
3956 src#
bool "open remote links in a new instance"
3957 (fun () -> conf
.riani
)
3958 (fun v -> conf
.riani
<- v);
3959 src#
bool "edit annotations inline"
3960 (fun () -> conf
.annotinline
)
3961 (fun v -> conf
.annotinline
<- v);
3965 src#caption
"Document" 0;
3966 List.iter
(fun (_, s) -> src#caption
s 1) state
.docinfo
;
3967 src#caption2
"Pages"
3968 (fun () -> string_of_int state
.pagecount
) 1;
3969 src#caption2
"Dimensions"
3970 (fun () -> string_of_int
(List.length state
.pdims
)) 1;
3974 src#caption
"Trimmed margins" 0;
3975 src#caption2
"Dimensions"
3976 (fun () -> string_of_int
(List.length state
.pdims
)) 1;
3980 src#caption
"OpenGL" 0;
3981 src#caption
(Printf.sprintf
"Vendor\t%s" (GlMisc.get_string `vendor
)) 1;
3982 src#caption
(Printf.sprintf
"Renderer\t%s" (GlMisc.get_string `renderer
)) 1;
3985 src#caption
"Location" 0;
3986 if nonemptystr state
.origin
3987 then src#caption
("Orign\t" ^ mbtoutf8 state
.origin
) 1;
3988 src#caption
("Path\t" ^ mbtoutf8 state
.path
) 1;
3990 src#reset prevmode prevuioh
;
3995 let prevmode = state
.mode
3996 and prevuioh
= state
.uioh in
3997 fillsrc prevmode prevuioh
;
3998 let source = (src :> lvsource
) in
3999 let modehash = findkeyhash conf
"info" in
4000 state
.uioh <- coe (object (self)
4001 inherit listview ~zebra
:false ~helpmode
:false
4002 ~
source ~trusted
:true ~
modehash as super
4003 val mutable m_prevmemused
= 0
4004 method! infochanged
= function
4006 if m_prevmemused
!= state
.memused
4008 m_prevmemused
<- state
.memused
;
4009 G.postRedisplay "memusedchanged";
4011 | Pdim
-> G.postRedisplay "pdimchanged"
4012 | Docinfo
-> fillsrc prevmode prevuioh
4014 method! key key mask
=
4015 if not
(Wsi.withctrl mask
)
4018 | @left | @kpleft
-> coe (self#updownlevel ~
-1)
4019 | @right
| @kpright
-> coe (self#updownlevel
1)
4020 | _ -> super#
key key mask
4021 else super#
key key mask
4023 G.postRedisplay "info";
4029 inherit lvsourcebase
4030 method getitemcount
= Array.length state
.help
4032 let s, l, _ = state
.help
.(n) in
4035 method exit ~
uioh ~cancel ~
active ~
first ~pan
=
4039 match state
.help
.(active) with
4040 | _, _, Action
f -> Some
(f uioh)
4041 | _, _, Noaction
-> Some
uioh
4050 method hasaction
n =
4051 match state
.help
.(n) with
4052 | _, _, Action
_ -> true
4053 | _, _, Noaction
-> false
4059 let modehash = findkeyhash conf
"help" in
4061 state
.uioh <- coe (new listview
4062 ~zebra
:false ~helpmode
:true
4063 ~
source ~trusted
:true ~
modehash);
4064 G.postRedisplay "help";
4070 inherit lvsourcebase
4071 val mutable m_items
= E.a
4073 method getitemcount
= 1 + Array.length m_items
4078 else m_items
.(n-1), 0
4080 method exit ~
uioh ~cancel ~
active ~
first ~pan
=
4085 then Buffer.clear state
.errmsgs
;
4092 method hasaction
n =
4096 state
.newerrmsgs
<- false;
4097 let l = Str.split newlinere
(Buffer.contents state
.errmsgs
) in
4098 m_items
<- Array.of_list
l
4107 let source = (msgsource :> lvsource
) in
4108 let modehash = findkeyhash conf
"listview" in
4109 state
.uioh <- coe (object
4110 inherit listview ~zebra
:false ~helpmode
:false
4111 ~
source ~trusted
:false ~
modehash as super
4114 then msgsource#reset
;
4117 G.postRedisplay "msgs";
4121 let editor = getenvwithdef
"EDITOR" E.s in
4125 let tmppath = Filename.temp_file
"llpp" "note" in
4128 let oc = open_out
tmppath in
4132 let execstr = editor ^
" " ^
tmppath in
4134 match spawn
execstr [] with
4135 | (exception exn
) ->
4137 Printf.sprintf
"popen(%S) failed: %s" execstr @@ exntos exn
;
4140 match Unix.waitpid
[] pid with
4141 | (exception exn
) ->
4143 Printf.sprintf
"waitpid(%d) failed: %s" pid @@ exntos exn
;
4147 | Unix.WEXITED
0 -> filecontents
tmppath
4150 Printf.sprintf
"editor process(%s) exited abnormally: %d"
4153 | Unix.WSIGNALED
n ->
4155 Printf.sprintf
"editor process(%s) was killed by signal %d"
4158 | Unix.WSTOPPED
n ->
4160 Printf.sprintf
"editor(%s) process was stopped by signal %d"
4164 match Unix.unlink
tmppath with
4165 | (exception exn
) ->
4166 showtext '
!'
@@ Printf.sprintf
"failed to ulink %S: %s"
4167 tmppath @@ exntos exn
;
4172 let enterannotmode opaque slinkindex
=
4175 inherit lvsourcebase
4176 val mutable m_text
= E.s
4177 val mutable m_items
= E.a
4179 method getitemcount
= Array.length m_items
4182 let label, _func
= m_items
.(n) in
4185 method exit ~
uioh ~cancel ~
active ~
first ~pan
=
4186 ignore
(uioh, first, pan
);
4189 let _label, func
= m_items
.(active) in
4194 method hasaction
n = nonemptystr
@@ fst m_items
.(n)
4197 let rec split accu b i
=
4199 if p = String.length
s
4200 then (String.sub
s b (p-b), unit) :: accu
4202 if (i
> 70 && s.[p] = ' '
) || s.[p] = '
\r'
|| s.[p] = '
\n'
4204 let ss = if i
= 0 then E.s else String.sub
s b i
in
4205 split ((ss, unit)::accu) (p+1) 0
4210 wcmd "freepage %s" (~
> opaque);
4212 Hashtbl.fold (fun key opaque'
accu ->
4213 if opaque'
= opaque'
4214 then key :: accu else accu) state
.pagemap
[]
4216 List.iter
(Hashtbl.remove state
.pagemap
) keys;
4221 delannot
opaque slinkindex
;
4224 let edit inline
() =
4229 modannot
opaque slinkindex
s;
4235 let mode = state
.mode in
4238 ("annotation: ", m_text
, None
, textentry, update, true),
4239 fun _ -> state
.mode <- mode);
4243 let s = getusertext m_text
in
4248 ( "[Copy]", fun () -> selstring m_text
)
4249 :: ("[Delete]", dele)
4250 :: ("[Edit]", edit conf
.annotinline
)
4252 :: split [] 0 0 |> List.rev
|> Array.of_list
4259 let s = getannotcontents
opaque slinkindex
in
4262 let source = (msgsource :> lvsource
) in
4263 let modehash = findkeyhash conf
"listview" in
4264 state
.uioh <- coe (object
4265 inherit listview ~zebra
:false ~helpmode
:false
4266 ~
source ~trusted
:false ~
modehash
4268 G.postRedisplay "enterannotmode";
4271 let gotounder under =
4272 let getpath filename
=
4274 if nonemptystr filename
4276 if Filename.is_relative filename
4278 let dir = Filename.dirname state
.path in
4280 if Filename.is_implicit
dir
4281 then Filename.concat
(Sys.getcwd
()) dir
4284 Filename.concat
dir filename
4288 if Sys.file_exists
path
4293 | Ulinkgoto
(pageno, top) ->
4297 gotopage1 pageno top;
4303 | Uremote
(filename
, pageno) ->
4304 let path = getpath filename
in
4309 let command = Printf.sprintf
"%s -page %d %S" !selfexec pageno path in
4310 try addpid
@@ spawn
command []
4311 with exn
-> dolog
"failed to execute `%s': %s" command @@ exntos exn
4313 let anchor = getanchor
() in
4314 let ranchor = state
.path, state
.password, anchor, state
.origin
in
4315 state
.origin
<- E.s;
4316 state
.anchor <- (pageno, 0.0, 0.0);
4317 state
.ranchors
<- ranchor :: state
.ranchors
;
4320 else showtext '
!'
("cannot find " ^ filename
)
4322 | Uremotedest
(filename
, destname
) ->
4323 let path = getpath filename
in
4328 let command = !selfexec ^
" " ^
path ^
" -dest " ^ destname
in
4329 try addpid
@@ spawn
command []
4330 with exn
-> dolog
"failed to execute `%s': %s" command @@ exntos exn
4332 let anchor = getanchor
() in
4333 let ranchor = state
.path, state
.password, anchor, state
.origin
in
4334 state
.origin
<- E.s;
4335 state
.nameddest
<- destname
;
4336 state
.ranchors
<- ranchor :: state
.ranchors
;
4339 else showtext '
!'
("Cannot find " ^ filename
)
4341 | Uunexpected
_ | Ulaunch
_ | Unamed
_ | Utext
_ | Unone
-> ()
4342 | Uannotation
(opaque, slinkindex
) -> enterannotmode opaque slinkindex
4345 let gotooutline (_, _, kind
) =
4349 let (pageno, y, _) = anchor in
4351 (if conf
.presentation
then (pageno, y, 1.0) else anchor)
4355 | Ouri
uri -> gotounder (Ulinkuri
uri)
4356 | Olaunch cmd
-> gotounder (Ulaunch cmd
)
4357 | Oremote remote
-> gotounder (Uremote remote
)
4358 | Ohistory hist
-> gotohist hist
4359 | Oremotedest remotedest
-> gotounder (Uremotedest remotedest
)
4362 let outlinesource sourcetype
=
4364 inherit lvsourcebase
4365 val mutable m_items
= E.a
4366 val mutable m_minfo
= E.a
4367 val mutable m_orig_items
= E.a
4368 val mutable m_orig_minfo
= E.a
4369 val mutable m_narrow_patterns
= []
4370 val mutable m_hadremovals
= false
4371 val mutable m_gen
= -1
4373 method getitemcount
=
4374 Array.length m_items
+ (if m_hadremovals
then 1 else 0)
4377 if n == Array.length m_items
&& m_hadremovals
4379 ("[Confirm removal]", 0)
4381 let s, n, _ = m_items
.(n) in
4384 method exit ~
uioh ~cancel ~
active ~
first ~pan
=
4385 ignore
(uioh, first);
4386 let confrimremoval = m_hadremovals
&& active = Array.length m_items
in
4388 if m_narrow_patterns
= []
4389 then m_orig_items
, m_orig_minfo
4390 else m_items
, m_minfo
4395 if not
confrimremoval
4399 gotooutline m_items
.(active);
4403 state
.bookmarks
<- Array.to_list m_items
;
4404 m_orig_items
<- m_items
;
4405 m_orig_minfo
<- m_minfo
;
4415 method hasaction
_ = true
4418 if Array.length m_items
!= Array.length m_orig_items
4421 match m_narrow_patterns
with
4423 | many
-> String.concat
"@Uellipsis" (List.rev many
)
4425 "Narrowed to " ^
s ^
" (ctrl-u to restore)"
4429 match m_narrow_patterns
with
4432 | head
:: _ -> "@Uellipsis" ^ head
4434 method narrow
pattern =
4435 match Str.regexp_case_fold
pattern with
4438 let rec loop accu minfo n =
4441 m_items
<- Array.of_list
accu;
4442 m_minfo
<- Array.of_list
minfo;
4445 let (s, _, _) as o = m_items
.(n) in
4447 match Str.search_forward
re s 0 with
4448 | exception Not_found
-> accu, minfo
4449 | first -> o :: accu, (first, Str.match_end
()) :: minfo
4451 loop accu minfo (n-1)
4453 loop [] [] (Array.length m_items
- 1)
4455 method! getminfo
= m_minfo
4457 method fetchoutlines
=
4458 match sourcetype
with
4459 | `bookmarks
-> Array.of_list state
.bookmarks
4460 | `outlines
-> state
.outlines
4461 | `history
-> genhistoutlines ()
4464 m_orig_items
<- self#fetchoutlines
;
4465 m_minfo
<- m_orig_minfo
;
4466 m_items
<- m_orig_items
4469 if sourcetype
= `bookmarks
4471 if m >= 0 && m < Array.length m_items
4473 m_hadremovals
<- true;
4474 m_items
<- Array.init
(Array.length m_items
- 1) (fun n ->
4475 let n = if n >= m then n+1 else n in
4483 method add_narrow_pattern
pattern =
4484 m_narrow_patterns
<- pattern :: m_narrow_patterns
4486 method del_narrow_pattern
=
4487 match m_narrow_patterns
with
4488 | _ :: rest
-> m_narrow_patterns
<- rest
4493 match m_narrow_patterns
with
4494 | pattern :: [] -> self#narrow
pattern; pattern
4496 List.fold_left
(fun accu pattern ->
4497 self#narrow
pattern;
4498 pattern ^
"@Uellipsis" ^
accu) E.s list
4500 method calcactive
anchor =
4501 let rely = getanchory anchor in
4502 let rec loop n best bestd
=
4503 if n = Array.length m_items
4506 let _, _, kind
= m_items
.(n) in
4509 let orely = getanchory anchor in
4510 let d = abs
(orely - rely) in
4513 else loop (n+1) best bestd
4514 | Onone
| Oremote
_ | Olaunch
_
4515 | Oremotedest
_ | Ouri
_ | Ohistory
_ ->
4516 loop (n+1) best bestd
4520 method reset
anchor items =
4521 m_hadremovals
<- false;
4522 if state
.gen
!= m_gen
4524 m_orig_items
<- items;
4526 m_narrow_patterns
<- [];
4528 m_orig_minfo
<- E.a;
4532 if items != m_orig_items
4534 m_orig_items
<- items;
4535 if m_narrow_patterns
== []
4536 then m_items
<- items;
4539 let active = self#calcactive
anchor in
4541 m_first
<- firstof m_first
active
4545 let enteroutlinemode, enterbookmarkmode
, enterhistmode
=
4546 let mkselector sourcetype
=
4547 let source = outlinesource sourcetype
in
4549 let outlines = source#fetchoutlines
in
4550 if Array.length
outlines = 0
4552 showtext ' ' errmsg
;
4556 Wsi.setcursor
Wsi.CURSOR_INHERIT
;
4557 let anchor = getanchor
() in
4558 source#reset
anchor outlines;
4559 state
.text <- source#greetmsg
;
4561 coe (new outlinelistview ~zebra
:(sourcetype
=`history
) ~
source);
4562 G.postRedisplay "enter selector";
4565 let mkenter sourcetype errmsg
=
4566 let enter = mkselector sourcetype
in
4567 fun () -> enter errmsg
4569 (**)mkenter `
outlines "Document has no outline"
4570 , mkenter `bookmarks
"Document has no bookmarks (yet)"
4571 , mkenter `history
"History is empty"
4574 let quickbookmark ?title
() =
4575 match state
.layout with
4581 let tm = Unix.localtime
(now
()) in
4583 "Quick (page %d) (bookmarked at %02d/%02d/%d %02d:%02d)"
4587 (tm.Unix.tm_year
+ 1900)
4590 | Some
title -> title
4592 state
.bookmarks
<- (title, 0, Oanchor
(getanchor1
l)) :: state
.bookmarks
4595 let setautoscrollspeed step goingdown
=
4596 let incr = max
1 ((abs step
) / 2) in
4597 let incr = if goingdown
then incr else -incr in
4598 let astep = boundastep state
.winh
(step
+ incr) in
4599 state
.autoscroll
<- Some
astep;
4603 match conf
.columns
with
4605 | Csingle
_ | Cmulti
_ -> state
.x != 0 || conf
.zoom > 1.0
4608 let panbound x = bound
x (-state
.w) (wadjsb () + state
.winw
);;
4610 let existsinrow pageno (columns
, coverA
, coverB
) p =
4611 let last = ((pageno - coverA
) mod columns
) + columns
in
4612 let rec any = function
4615 if l.pageno = coverA
- 1 || l.pageno = state
.pagecount
- coverB
4619 then (if l.pageno = last then false else any rest
)
4627 match state
.layout with
4629 let pageno = page_of_y state
.y in
4630 gotoghyll (getpagey
(pageno+1))
4632 match conf
.columns
with
4634 if conf
.presentation
&& rest
== [] && l.pageh
> l.pagey + l.pagevh
4636 let y = clamp (pgscale state
.winh
) in
4639 let pageno = min
(l.pageno+1) (state
.pagecount
-1) in
4640 gotoghyll (getpagey
pageno)
4641 | Cmulti
((c, _, _) as cl, _) ->
4642 if conf
.presentation
4643 && (existsinrow l.pageno cl
4644 (fun l -> l.pageh
> l.pagey + l.pagevh))
4646 let y = clamp (pgscale state
.winh
) in
4649 let pageno = min
(l.pageno+c) (state
.pagecount
-1) in
4650 gotoghyll (getpagey
pageno)
4652 if l.pageno < state
.pagecount
- 1 || l.pagecol
< n - 1
4654 let pagey, pageh
= getpageyh
l.pageno in
4655 let pagey = pagey + pageh
* l.pagecol
in
4656 let ips = if l.pagecol
= 0 then 0 else conf
.interpagespace
in
4657 gotoghyll (pagey + pageh
+ ips)
4661 match state
.layout with
4663 let pageno = page_of_y state
.y in
4664 gotoghyll (getpagey
(pageno-1))
4666 match conf
.columns
with
4668 if conf
.presentation
&& l.pagey != 0
4670 gotoghyll (clamp (pgscale ~
-(state
.winh
)))
4672 let pageno = max
0 (l.pageno-1) in
4673 gotoghyll (getpagey
pageno)
4674 | Cmulti
((c, _, coverB
) as cl, _) ->
4675 if conf
.presentation
&&
4676 (existsinrow l.pageno cl (fun l -> l.pagey != 0))
4678 gotoghyll (clamp (pgscale ~
-(state
.winh
)))
4681 if l.pageno = state
.pagecount
- coverB
4685 let pageno = max
0 (l.pageno-decr) in
4686 gotoghyll (getpagey
pageno)
4694 let pageno = max
0 (l.pageno-1) in
4695 let pagey, pageh
= getpageyh
pageno in
4698 let pagey, pageh
= getpageyh
l.pageno in
4699 pagey + pageh
* (l.pagecol
-1) - conf
.interpagespace
4705 if emptystr conf
.savecmd
4706 then error
"don't know where to save modified document"
4708 let savecmd = Str.global_replace percentsre state
.path conf
.savecmd in
4711 (fun s -> error
"failed to obtain path to the saved copy: %s" s)
4716 let tmp = path ^
".tmp" in
4718 Unix.rename
tmp path;
4721 let viewkeyboard key mask
=
4723 let mode = state
.mode in
4724 state
.mode <- Textentry
(te, fun _ -> state
.mode <- mode);
4727 G.postRedisplay "view:enttext"
4729 let ctrl = Wsi.withctrl mask
in
4731 if key >= 0xffb0 && key < 0xffb9 then key - 0xffb0 + 48 else key
4737 if hasunsavedchanges
()
4741 if conf
.angle
mod 360 = 0 && not
(isbirdseye state
.mode)
4743 state
.mode <- LinkNav
(Ltgendir
0);
4746 else showtext '
!'
"Keyboard link navigation does not work under rotation"
4749 begin match state
.mstate
with
4752 G.postRedisplay "kill rect";
4755 | Mscrolly
| Mscrollx
4758 begin match state
.mode with
4761 G.postRedisplay "esc leave linknav"
4765 match state
.ranchors
with
4767 | (path, password, anchor, origin
) :: rest
->
4768 state
.ranchors
<- rest
;
4769 state
.anchor <- anchor;
4770 state
.origin
<- origin
;
4771 state
.nameddest
<- E.s;
4772 opendoc path password
4777 gotoghyll (getnav ~
-1)
4788 Hashtbl.iter
(fun _ opaque -> clearmark
opaque) state
.pagemap
;
4789 G.postRedisplay "dehighlight";
4791 | @slash
| @question
->
4792 let ondone isforw
s =
4793 cbput state
.hists
.pat
s;
4794 state
.searchpattern
<- s;
4797 let s = String.make
1 (Char.chr
key) in
4798 enttext (s, E.s, Some
(onhist state
.hists
.pat
),
4799 textentry, ondone (key = @slash
), true)
4801 | @plus
| @kpplus
| @equals
when ctrl ->
4802 let incr = if conf
.zoom +. 0.01 > 0.1 then 0.1 else 0.01 in
4803 setzoom (conf
.zoom +. incr)
4805 | @plus
| @kpplus
->
4808 try int_of_string
s with exc
->
4809 state
.text <- Printf.sprintf
"bad integer `%s': %s" s @@ exntos exc
;
4815 state
.text <- "page bias is now " ^ string_of_int
n;
4818 enttext ("page bias: ", E.s, None
, intentry, ondone, true)
4820 | @minus
| @kpminus
when ctrl ->
4821 let decr = if conf
.zoom -. 0.1 < 0.1 then 0.01 else 0.1 in
4822 setzoom (max
0.01 (conf
.zoom -. decr))
4824 | @minus
| @kpminus
->
4825 let ondone msg
= state
.text <- msg
in
4827 "option [acfhilpstvxACFPRSZTISM]: ", E.s, None
,
4828 optentry state
.mode, ondone, true
4839 | (@1 | @2) when ctrl && conf
.fitmodel
!= FitPage
-> (* ctrl-1/2 *)
4841 match conf
.columns
with
4842 | Csingle
_ | Cmulti
_ -> 1
4843 | Csplit
(n, _) -> n
4845 let h = state
.winh
-
4846 conf
.interpagespace
lsl (if conf
.presentation
then 1 else 0)
4848 let zoom = zoomforh state
.winw
h (vscrollw ()) cols in
4849 if zoom > 0.0 && (key = 50 || zoom < 1.0)
4854 match conf
.fitmodel
with
4855 | FitWidth
-> FitProportional
4856 | FitProportional
-> FitPage
4857 | FitPage
-> FitWidth
4859 state
.text <- "fit model: " ^
FMTE.to_string
fm;
4860 reqlayout conf
.angle
fm
4868 | (48 | 49 | 50 | 51 | 52 | 53 | 54 | 55 | 56 | 57)
4869 when not
ctrl -> (* 0..9 *)
4872 try int_of_string
s with exc
->
4873 state
.text <- Printf.sprintf
"bad integer `%s': %s" s @@ exntos exc
;
4879 cbput state
.hists
.pag
(string_of_int
n);
4880 gotopage1 (n + conf
.pagebias
- 1) 0;
4883 let pageentry text key =
4884 match Char.unsafe_chr
key with
4885 | '
g'
-> TEdone
text
4886 | _ -> intentry text key
4888 let text = String.make
1 (Char.chr
key) in
4889 enttext (":", text, Some
(onhist state
.hists
.pag
),
4890 pageentry, ondone, true)
4893 conf
.scrollb
<- if conf
.scrollb
= 0 then (scrollbvv
lor scrollbhv
) else 0;
4894 reshape state
.winw state
.winh
;
4897 state
.bzoom
<- not state
.bzoom
;
4899 showtext ' '
("block zoom " ^
if state
.bzoom
then "on" else "off")
4902 conf
.hlinks
<- not conf
.hlinks
;
4903 state
.text <- "highlightlinks " ^
if conf
.hlinks
then "on" else "off";
4904 G.postRedisplay "toggle highlightlinks";
4907 state
.glinks
<- true;
4908 let mode = state
.mode in
4909 state
.mode <- Textentry
(
4910 (":", E.s, None
, linknentry, linknact gotounder, false),
4912 state
.glinks
<- false;
4916 G.postRedisplay "view:linkent(F)"
4919 state
.glinks
<- true;
4920 let mode = state
.mode in
4921 state
.mode <- Textentry
(
4923 ":", E.s, None
, linknentry, linknact (fun under ->
4924 selstring (undertext under);
4928 state
.glinks
<- false;
4932 G.postRedisplay "view:linkent"
4935 begin match state
.autoscroll
with
4937 conf
.autoscrollstep
<- step
;
4938 state
.autoscroll
<- None
4940 if conf
.autoscrollstep
= 0
4941 then state
.autoscroll
<- Some
1
4942 else state
.autoscroll
<- Some conf
.autoscrollstep
4949 setpresentationmode (not conf
.presentation
);
4950 showtext ' '
("presentation mode " ^
4951 if conf
.presentation
then "on" else "off");
4954 if List.mem
Wsi.Fullscreen state
.winstate
4955 then Wsi.reshape conf
.cwinw conf
.cwinh
4956 else Wsi.fullscreen
()
4959 search state
.searchpattern
false
4962 search state
.searchpattern
true
4965 begin match state
.layout with
4968 gotoghyll (getpagey
l.pageno)
4974 | @delete
| @kpdelete
-> (* delete *)
4978 showtext ' '
(describe_location ());
4981 begin match state
.layout with
4984 Wsi.reshape (l.pagew
+ vscrollw ()) l.pageh
;
4989 enterbookmarkmode
()
4997 | @e when Buffer.length state
.errmsgs
> 0 ->
5002 match state
.layout with
5007 (s, 0, Oanchor
(getanchor1
l)) :: state
.bookmarks
5010 enttext ("bookmark: ", E.s, None
, textentry, ondone, true)
5014 showtext ' '
"Quick bookmark added";
5017 begin match state
.layout with
5019 let rect = getpdimrect
l.pagedimno
in
5023 (truncate
(1.8 *. (rect.(1) -. rect.(0))),
5024 truncate
(1.2 *. (rect.(3) -. rect.(0))))
5026 (truncate
(rect.(1) -. rect.(0)),
5027 truncate
(rect.(3) -. rect.(0)))
5029 let w = truncate
((float w)*.conf
.zoom)
5030 and h = truncate
((float h)*.conf
.zoom) in
5033 state
.anchor <- getanchor
();
5034 Wsi.reshape (w + vscrollw ()) (h + conf
.interpagespace
)
5036 G.postRedisplay "z";
5041 | @x -> state
.roam
()
5044 reqlayout (conf
.angle
+
5045 (if key = @Gt
then 30 else -30)) conf
.fitmodel
5049 bound
(conf
.colorscale
+. (if key = 93 then 0.1 else -0.1)) 0.0 1.0
5051 G.postRedisplay "brightness";
5053 | @c when state
.mode = View
->
5058 let m = (wadjsb () + state
.winw
- state
.w) / 2 in
5060 gotoy_and_clear_text state
.y
5064 match state
.prevcolumns
with
5065 | None
-> (1, 0, 0), 1.0
5066 | Some
(columns
, z
) ->
5069 | Csplit
(c, _) -> -c, 0, 0
5070 | Cmulti
((c, a, b), _) -> c, a, b
5071 | Csingle
_ -> 1, 0, 0
5075 setcolumns View
c a b;
5078 | @down
| @up
when ctrl && Wsi.withshift mask
->
5079 let zoom, x = state
.prevzoom
in
5083 | @k
| @up
| @kpup
->
5084 begin match state
.autoscroll
with
5086 begin match state
.mode with
5087 | Birdseye beye
-> upbirdseye 1 beye
5092 then gotoy_and_clear_text (clamp ~
-(state
.winh
/2))
5094 if not
(Wsi.withshift mask
) && conf
.presentation
5096 else gotoghyll1 true (clamp (-conf
.scrollstep
))
5100 setautoscrollspeed n false
5103 | @j
| @down
| @kpdown
->
5104 begin match state
.autoscroll
with
5106 begin match state
.mode with
5107 | Birdseye beye
-> downbirdseye 1 beye
5112 then gotoy_and_clear_text (clamp (state
.winh
/2))
5114 if not
(Wsi.withshift mask
) && conf
.presentation
5116 else gotoghyll1 true (clamp (conf
.scrollstep
))
5120 setautoscrollspeed n true
5123 | @left | @right
| @kpleft
| @kpright
when not
(Wsi.withalt mask
) ->
5129 else conf
.hscrollstep
5131 let dx = if key = @left || key = @kpleft
then dx else -dx in
5132 state
.x <- panbound (state
.x + dx);
5133 gotoy_and_clear_text state
.y
5136 G.postRedisplay "left/right"
5139 | @prior
| @kpprior
->
5143 match state
.layout with
5145 | l :: _ -> state
.y - l.pagey
5147 clamp (pgscale (-state
.winh
))
5151 | @next | @kpnext
->
5155 match List.rev state
.layout with
5157 | l :: _ -> getpagey
l.pageno
5159 clamp (pgscale state
.winh
)
5163 | @g | @home
| @kphome
->
5166 | @G
| @jend
| @kpend
->
5168 gotoghyll (clamp state
.maxy)
5170 | @right
| @kpright
when Wsi.withalt mask
->
5171 gotoghyll (getnav 1)
5172 | @left | @kpleft
when Wsi.withalt mask
->
5173 gotoghyll (getnav ~
-1)
5178 | @v when conf
.debug
->
5181 match getopaque l.pageno with
5184 let x0, y0, x1, y1 = pagebbox
opaque in
5185 let a,b = float x0, float y0 in
5186 let c,d = float x1, float y0 in
5187 let e,f = float x1, float y1 in
5188 let h,j
= float x0, float y1 in
5189 let rect = (a,b,c,d,e,f,h,j
) in
5191 state
.rects
<- (l.pageno, l.pageno mod 3, rect) :: state
.rects
;
5193 G.postRedisplay "v";
5196 let mode = state
.mode in
5197 let cmd = ref E.s in
5198 let onleave = function
5199 | Cancel
-> state
.mode <- mode
5202 match getopaque l.pageno with
5203 | Some
opaque -> pipesel opaque !cmd
5204 | None
-> ()) state
.layout;
5208 cbput state
.hists
.sel
s;
5212 "| ", !cmd, Some
(onhist state
.hists
.sel
), textentry, ondone, true
5214 G.postRedisplay "|";
5215 state
.mode <- Textentry
(te, onleave);
5218 vlog "huh? %s" (Wsi.keyname
key)
5221 let linknavkeyboard key mask
linknav =
5222 let getpage pageno =
5223 let rec loop = function
5225 | l :: _ when l.pageno = pageno -> Some
l
5226 | _ :: rest
-> loop rest
5227 in loop state
.layout
5229 let doexact (pageno, n) =
5230 match getopaque pageno, getpage pageno with
5231 | Some
opaque, Some
l ->
5232 if key = @enter || key = @kpenter
5234 let under = getlink
opaque n in
5235 G.postRedisplay "link gotounder";
5242 Some
(findlink
opaque LDfirst
), -1
5245 Some
(findlink
opaque LDlast
), 1
5248 Some
(findlink
opaque (LDleft
n)), -1
5251 Some
(findlink
opaque (LDright
n)), 1
5254 Some
(findlink
opaque (LDup
n)), -1
5257 Some
(findlink
opaque (LDdown
n)), 1
5262 begin match findpwl
l.pageno dir with
5266 state
.mode <- LinkNav
(Ltgendir
dir);
5267 let y, h = getpageyh
pageno in
5270 then y + h - state
.winh
5275 begin match getopaque pageno, getpage pageno with
5276 | Some
opaque, Some
_ ->
5278 let ld = if dir > 0 then LDfirst
else LDlast
in
5281 begin match link with
5283 showlinktype (getlink
opaque m);
5284 state
.mode <- LinkNav
(Ltexact
(pageno, m));
5285 G.postRedisplay "linknav jpage";
5286 | Lnotfound
-> notfound dir
5292 begin match opt with
5293 | Some Lnotfound
-> pwl l dir;
5294 | Some
(Lfound
m) ->
5298 let _, y0, _, y1 = getlinkrect
opaque m in
5300 then gotopage1 l.pageno y0
5302 let d = fstate
.fontsize
+ 1 in
5303 if y1 - l.pagey > l.pagevh - d
5304 then gotopage1 l.pageno (y1 - state
.winh
- hscrollh () + d)
5305 else G.postRedisplay "linknav";
5307 showlinktype (getlink
opaque m);
5308 state
.mode <- LinkNav
(Ltexact
(l.pageno, m));
5311 | None
-> viewkeyboard key mask
5313 | _ -> viewkeyboard key mask
5318 G.postRedisplay "leave linknav"
5322 | Ltgendir
_ | Ltnotready
_ -> viewkeyboard key mask
5323 | Ltexact exact
-> doexact exact
5326 let keyboard key mask
=
5327 if (key = @g && Wsi.withctrl mask
) && not
(istextentry state
.mode)
5328 then wcmd "interrupt"
5329 else state
.uioh <- state
.uioh#
key key mask
5332 let birdseyekeyboard key mask
5333 ((oconf
, leftx
, pageno, hooverpageno
, anchor) as beye
) =
5335 match conf
.columns
with
5337 | Cmulti
((c, _, _), _) -> c
5338 | Csplit
_ -> failwith
"bird's eye split mode"
5340 let pgh layout = List.fold_left
5341 (fun m l -> max
l.pageh
m) state
.winh
layout in
5343 | @l when Wsi.withctrl mask
->
5344 let y, h = getpageyh
pageno in
5345 let top = (state
.winh
- h) / 2 in
5346 gotoy (max
0 (y - top))
5347 | @enter | @kpenter
-> leavebirdseye beye
false
5348 | @escape
-> leavebirdseye beye
true
5349 | @up
-> upbirdseye incr beye
5350 | @down
-> downbirdseye incr beye
5351 | @left -> upbirdseye 1 beye
5352 | @right
-> downbirdseye 1 beye
5355 begin match state
.layout with
5359 state
.mode <- Birdseye
(
5360 oconf
, leftx
, l.pageno, hooverpageno
, anchor
5362 gotopage1 l.pageno 0;
5365 let layout = layout (state
.y-state
.winh
) (pgh state
.layout) in
5367 | [] -> gotoy (clamp (-state
.winh
))
5369 state
.mode <- Birdseye
(
5370 oconf
, leftx
, l.pageno, hooverpageno
, anchor
5372 gotopage1 l.pageno 0
5375 | [] -> gotoy (clamp (-state
.winh
))
5379 begin match List.rev state
.layout with
5381 let layout = layout (state
.y + (pgh state
.layout)) state
.winh
in
5382 begin match layout with
5384 let incr = l.pageh
- l.pagevh in
5389 oconf
, leftx
, state
.pagecount
- 1, hooverpageno
, anchor
5391 G.postRedisplay "birdseye pagedown";
5393 else gotoy (clamp (incr + conf
.interpagespace
*2));
5397 Birdseye
(oconf
, leftx
, l.pageno, hooverpageno
, anchor);
5398 gotopage1 l.pageno 0;
5401 | [] -> gotoy (clamp state
.winh
)
5405 state
.mode <- Birdseye
(oconf
, leftx
, 0, hooverpageno
, anchor);
5409 let pageno = state
.pagecount
- 1 in
5410 state
.mode <- Birdseye
(oconf
, leftx
, pageno, hooverpageno
, anchor);
5411 if not
(pagevisible state
.layout pageno)
5414 match List.rev state
.pdims
with
5416 | (_, _, h, _) :: _ -> h
5418 gotoy (max
0 (getpagey
pageno - (state
.winh
- h - conf
.interpagespace
)))
5419 else G.postRedisplay "birdseye end";
5421 | _ -> viewkeyboard key mask
5426 match state
.mode with
5427 | Textentry
_ -> scalecolor 0.4
5429 | View
-> scalecolor 1.0
5430 | Birdseye
(_, _, pageno, hooverpageno
, _) ->
5431 if l.pageno = hooverpageno
5434 if l.pageno = pageno
5436 let c = scalecolor 1.0 in
5438 GlDraw.line_width
3.0;
5439 let dispx = xadjsb () + l.pagedispx in
5441 (float (dispx-1)) (float (l.pagedispy-1))
5442 (float (dispx+l.pagevw+1))
5443 (float (l.pagedispy+l.pagevh+1))
5445 GlDraw.line_width
1.0;
5454 let postdrawpage l linkindexbase
=
5455 match getopaque l.pageno with
5457 if tileready l l.pagex
l.pagey
5459 let x = l.pagedispx - l.pagex
+ xadjsb ()
5460 and y = l.pagedispy - l.pagey in
5462 match conf
.columns
with
5463 | Csingle
_ | Cmulti
_ ->
5464 (if conf
.hlinks
then 1 else 0)
5466 && not
(isbirdseye state
.mode) then 2 else 0)
5470 match state
.mode with
5471 | Textentry
((_, s, _, _, _, _), _) when state
.glinks
-> s
5477 postprocess
opaque hlmask x y (linkindexbase
, s, conf
.hfsize
);
5482 let scrollindicator () =
5483 let sbw, ph
, sh = state
.uioh#
scrollph in
5484 let sbh, pw, sw = state
.uioh#scrollpw
in
5489 else ((state
.winw
- sbw), state
.winw
, 0)
5492 GlDraw.color (0.64, 0.64, 0.64);
5493 filledrect (float x0) 0. (float x1) (float state
.winh
);
5495 (float hx0
) (float (state
.winh
- sbh))
5496 (float (hx0
+ wadjsb () + state
.winw
)) (float state
.winh
)
5498 GlDraw.color (0.0, 0.0, 0.0);
5500 filledrect (float x0) ph
(float x1) (ph
+. sh);
5501 let pw = pw +. float hx0
in
5502 filledrect pw (float (state
.winh
- sbh)) (pw +. sw) (float state
.winh
);
5506 match state
.mstate
with
5507 | Mnone
| Mscrolly
| Mscrollx
| Mpan
_ | Mzoom
_ | Mzoomrect
_ ->
5510 | Msel
((x0, y0), (x1, y1)) ->
5511 let identify opaque l px py = Some
(opaque, l.pageno, px, py) in
5512 let o0,n0
,px0
,py0
= onppundermouse identify x0 y0 (~
< E.s, -1, 0, 0) in
5513 let _o1,n1
,px1
,py1
= onppundermouse identify x1 y1 (~
< E.s, -1, 0, 0) in
5514 if n0
!= -1 && n0
= n1
then seltext
o0 (px0
, py0
, px1
, py1
);
5517 let showrects = function [] -> () | rects
->
5519 GlDraw.color (0.0, 0.0, 1.0) ~
alpha:0.5;
5520 GlFunc.blend_func ~
src:`src_alpha ~dst
:`one_minus_src_alpha
;
5522 (fun (pageno, c, (x0, y0, x1, y1, x2
, y2
, x3
, y3
)) ->
5524 if l.pageno = pageno
5526 let dx = float (l.pagedispx - l.pagex
) in
5527 let dy = float (l.pagedispy - l.pagey) in
5528 GlDraw.color (0.0, 0.0, 1.0 /. float c) ~
alpha:0.5;
5529 Raw.sets_float state
.vraw ~
pos:0
5534 GlArray.vertex `two state
.vraw
;
5535 GlArray.draw_arrays `triangle_strip ~
first:0 ~count
:4;
5544 GlClear.color (scalecolor2 conf
.bgcolor
);
5545 GlClear.clear
[`
color];
5546 List.iter
drawpage state
.layout;
5548 match state
.mode with
5549 | LinkNav
(Ltexact
(pageno, linkno
)) ->
5550 begin match getopaque pageno with
5552 let dx = xadjsb () in
5553 let x0, y0, x1, y1 = getlinkrect
opaque linkno
in
5554 let x0 = x0 + dx and x1 = x1 + dx in
5561 | None
-> state
.rects
5563 | LinkNav
(Ltgendir
_) | LinkNav
(Ltnotready
_)
5566 | View
-> state
.rects
5569 let rec postloop linkindexbase
= function
5571 let linkindexbase = linkindexbase + postdrawpage l linkindexbase in
5572 postloop linkindexbase rest
5576 postloop 0 state
.layout;
5578 begin match state
.mstate
with
5579 | Mzoomrect
((x0, y0), (x1, y1)) ->
5581 GlDraw.color (0.3, 0.3, 0.3) ~
alpha:0.5;
5582 GlFunc.blend_func ~
src:`src_alpha ~dst
:`one_minus_src_alpha
;
5583 filledrect (float x0) (float y0) (float x1) (float y1);
5587 | Mscrolly
| Mscrollx
5596 let zoomrect x y x1 y1 =
5599 and y0 = min
y y1 in
5600 gotoy (state
.y + y0);
5601 state
.anchor <- getanchor
();
5602 let zoom = (float state
.w) /. float (x1 - x0) in
5605 let adjw = wadjsb () + state
.winw
in
5607 then (adjw - state
.w) / 2
5610 match conf
.fitmodel
with
5611 | FitWidth
| FitProportional
-> simple ()
5613 match conf
.columns
with
5615 onppundermouse (fun _ l _ _ -> Some
l.pagedispx) x0 y0 x0
5616 | Cmulti
_ | Csingle
_ -> simple ()
5618 state
.x <- (state
.x + margin) - x0;
5623 let annot inline
x y =
5624 match unproject x y with
5625 | Some
(opaque, n, ux
, uy
) ->
5627 addannot
opaque ux uy
text;
5628 wcmd "freepage %s" (~
> opaque);
5629 Hashtbl.remove state
.pagemap
(n, state
.gen
);
5635 let ondone s = add s in
5636 let mode = state
.mode in
5637 state
.mode <- Textentry
(
5638 ("annotation: ", E.s, None
, textentry, ondone, true),
5639 fun _ -> state
.mode <- mode);
5642 G.postRedisplay "annot"
5644 add @@ getusertext E.s
5649 let g opaque l px py =
5650 match rectofblock
opaque px py with
5652 let x0 = a.(0) -. 20. in
5653 let x1 = a.(1) +. 20. in
5654 let y0 = a.(2) -. 20. in
5655 let zoom = (float state
.w) /. (x1 -. x0) in
5656 let pagey = getpagey
l.pageno in
5657 gotoy_and_clear_text (pagey + truncate
y0);
5658 state
.anchor <- getanchor
();
5659 let margin = (state
.w - l.pagew
)/2 in
5660 state
.x <- -truncate
x0 - margin;
5665 match conf
.columns
with
5667 showtext '
!'
"block zooming does not work properly in split columns mode"
5668 | Cmulti
_ | Csingle
_ -> onppundermouse g x y ()
5672 let winw = wadjsb () + state
.winw - 1 in
5673 let s = float x /. float winw in
5674 let destx = truncate
(float (state
.w + winw) *. s) in
5675 state
.x <- winw - destx;
5676 gotoy_and_clear_text state
.y;
5677 state
.mstate
<- Mscrollx
;
5681 let s = float y /. float state
.winh
in
5682 let desty = truncate
(float (state
.maxy - state
.winh
) *. s) in
5683 gotoy_and_clear_text desty;
5684 state
.mstate
<- Mscrolly
;
5687 let viewmulticlick clicks
x y mask
=
5688 let g opaque l px py =
5696 if markunder
opaque px py mark
5700 match getopaque l.pageno with
5702 | Some
opaque -> pipesel opaque cmd
5704 state
.roam
<- (fun () -> dopipe conf
.paxcmd
);
5705 if not
(Wsi.withctrl mask
) then dopipe conf
.selcmd
;
5710 G.postRedisplay "viewmulticlick";
5711 onppundermouse g x y (fun () -> showtext '
!'
"Nothing to select") ();
5715 match conf
.columns
with
5717 | Csingle
_ | Cmulti
_ -> conf
.angle
mod 360 = 0
5720 let viewmouse button down
x y mask
=
5722 | n when (n == 4 || n == 5) && not down
->
5723 if Wsi.withctrl mask
5725 match state
.mstate
with
5726 | Mzoom
(oldn
, i
) ->
5734 if conf
.zoom +. 0.01 > 0.1 then 0.1 else 0.01
5736 if conf
.zoom -. 0.1 < 0.1 then -0.01 else -0.1
5738 let zoom = conf
.zoom -. incr in
5740 state
.mstate
<- Mzoom
(n, 0);
5742 state
.mstate
<- Mzoom
(n, i
+1);
5744 else state
.mstate
<- Mzoom
(n, 0)
5748 | Mscrolly
| Mscrollx
5750 | Mnone
-> state
.mstate
<- Mzoom
(n, 0)
5753 match state
.autoscroll
with
5754 | Some step
-> setautoscrollspeed step
(n=4)
5756 if conf
.wheelbypage
|| conf
.presentation
5765 then -conf
.scrollstep
5766 else conf
.scrollstep
5768 let incr = incr * 2 in
5769 let y = clamp incr in
5770 gotoy_and_clear_text y
5773 | n when (n = 6 || n = 7) && not down
&& canpan () ->
5775 panbound (state
.x + (if n = 7 then -2 else 2) * conf
.hscrollstep
);
5776 gotoy_and_clear_text state
.y
5778 | 1 when Wsi.withshift mask
->
5779 state
.mstate
<- Mnone
;
5782 match unproject x y with
5783 | Some
(_, pageno, ux
, uy
) ->
5784 let cmd = Printf.sprintf
5786 conf
.stcmd state
.path pageno ux uy
5788 addpid
@@ spawn
cmd []
5792 | 1 when Wsi.withctrl mask
->
5795 Wsi.setcursor
Wsi.CURSOR_FLEUR
;
5796 state
.mstate
<- Mpan
(x, y)
5799 state
.mstate
<- Mnone
5804 if Wsi.withshift mask
5806 annot conf
.annotinline
x y;
5807 G.postRedisplay "addannot"
5811 Wsi.setcursor
Wsi.CURSOR_CYCLE
;
5812 state
.mstate
<- Mzoomrect
(p, p)
5815 match state
.mstate
with
5816 | Mzoomrect
((x0, y0), _) ->
5817 if abs
(x-x0) > 10 && abs
(y - y0) > 10
5818 then zoomrect x0 y0 x y
5821 G.postRedisplay "kill accidental zoom rect";
5825 | Mscrolly
| Mscrollx
5831 | 1 when x > state
.winw - vscrollw () ->
5834 let _, position, sh = state
.uioh#
scrollph in
5835 if y > truncate
position && y < truncate
(position +. sh)
5836 then state
.mstate
<- Mscrolly
5839 state
.mstate
<- Mnone
5841 | 1 when y > state
.winh
- hscrollh () ->
5844 let _, position, sw = state
.uioh#scrollpw
in
5845 if x > truncate
position && x < truncate
(position +. sw)
5846 then state
.mstate
<- Mscrollx
5849 state
.mstate
<- Mnone
5851 | 1 when state
.bzoom
-> if not down
then zoomblock x y
5854 let dest = if down
then getunder x y else Unone
in
5855 begin match dest with
5858 | Uremote
_ | Uremotedest
_
5859 | Uunexpected
_ | Ulaunch
_ | Unamed
_ ->
5862 | Unone
when down
->
5863 Wsi.setcursor
Wsi.CURSOR_FLEUR
;
5864 state
.mstate
<- Mpan
(x, y);
5866 | Uannotation
(opaque, slinkindex
) -> enterannotmode opaque slinkindex
5868 | Unone
| Utext
_ ->
5873 state
.mstate
<- Msel
((x, y), (x, y));
5874 G.postRedisplay "mouse select";
5878 match state
.mstate
with
5881 | Mzoom
_ | Mscrollx
| Mscrolly
->
5882 state
.mstate
<- Mnone
5884 | Mzoomrect
((x0, y0), _) ->
5888 Wsi.setcursor
Wsi.CURSOR_INHERIT
;
5889 state
.mstate
<- Mnone
5891 | Msel
((x0, y0), (x1, y1)) ->
5892 let rec loop = function
5896 let a0 = l.pagedispy in
5897 let a1 = a0 + l.pagevh in
5898 let b0 = l.pagedispx in
5899 let b1 = b0 + l.pagevw in
5900 ((y0 >= a0 && y0 <= a1) || (y1 >= a0 && y1 <= a1))
5901 && ((x0 >= b0 && x0 <= b1) || (x1 >= b0 && x1 <= b1))
5905 match getopaque l.pageno with
5908 match Unix.pipe
() with
5912 "cannot create sel pipe: %s"
5916 Ne.clo fd
(fun msg
->
5917 dolog
"%s close failed: %s" what msg
)
5920 try spawn
cmd [r
, 0; w, -1]
5922 dolog
"cannot execute %S: %s"
5929 G.postRedisplay "copysel";
5931 else clo "Msel pipe/w" w;
5932 clo "Msel pipe/r" r
;
5934 dosel conf
.selcmd
();
5935 state
.roam
<- dosel conf
.paxcmd
;
5947 let birdseyemouse button down
x y mask
5948 (conf
, leftx
, _, hooverpageno
, anchor) =
5951 let rec loop = function
5954 if y > l.pagedispy && y < l.pagedispy + l.pagevh
5955 && x > l.pagedispx && x < l.pagedispx + l.pagevw
5957 leavebirdseye (conf
, leftx
, l.pageno, hooverpageno
, anchor) false;
5963 | _ -> viewmouse button down
x y mask
5969 method key key mask
=
5970 begin match state
.mode with
5971 | Textentry
textentry -> textentrykeyboard key mask
textentry
5972 | Birdseye
birdseye -> birdseyekeyboard key mask
birdseye
5973 | View
-> viewkeyboard key mask
5974 | LinkNav
linknav -> linknavkeyboard key mask
linknav
5978 method button button bstate
x y mask
=
5979 begin match state
.mode with
5981 | View
-> viewmouse button bstate
x y mask
5982 | Birdseye beye
-> birdseyemouse button bstate
x y mask beye
5987 method multiclick clicks
x y mask
=
5988 begin match state
.mode with
5990 | View
-> viewmulticlick clicks
x y mask
5997 begin match state
.mode with
5999 | View
| Birdseye
_ | LinkNav
_ ->
6000 match state
.mstate
with
6001 | Mzoom
_ | Mnone
-> ()
6006 state
.mstate
<- Mpan
(x, y);
6008 then state
.x <- panbound (state
.x + dx);
6010 gotoy_and_clear_text y
6013 state
.mstate
<- Msel
(a, (x, y));
6014 G.postRedisplay "motion select";
6017 let y = min state
.winh
(max
0 y) in
6021 let x = min state
.winw (max
0 x) in
6024 | Mzoomrect
(p0
, _) ->
6025 state
.mstate
<- Mzoomrect
(p0
, (x, y));
6026 G.postRedisplay "motion zoomrect";
6030 method pmotion
x y =
6031 begin match state
.mode with
6032 | Birdseye
(conf
, leftx
, pageno, hooverpageno
, anchor) ->
6033 let rec loop = function
6035 if hooverpageno
!= -1
6037 state
.mode <- Birdseye
(conf
, leftx
, pageno, -1, anchor);
6038 G.postRedisplay "pmotion birdseye no hoover";
6041 if y > l.pagedispy && y < l.pagedispy + l.pagevh
6042 && x > l.pagedispx && x < l.pagedispx + l.pagevw
6044 state
.mode <- Birdseye
(conf
, leftx
, pageno, l.pageno, anchor);
6045 G.postRedisplay "pmotion birdseye hoover";
6055 match state
.mstate
with
6056 | Mpan
_ | Msel
_ | Mzoom
_ | Mscrolly
| Mscrollx
| Mzoomrect
_ -> ()
6064 let past, _, _ = !r
in
6066 let delta = now -. past in
6069 else r
:= (now, x, y)
6073 method infochanged
_ = ()
6076 let maxy = state
.maxy - (if conf
.maxhfit
then state
.winh
else 0) in
6079 then 0.0, float state
.winh
6080 else scrollph state
.y maxy
6085 let winw = wadjsb () + state
.winw in
6086 let fwinw = float winw in
6088 let sw = fwinw /. float state
.w in
6089 let sw = fwinw *. sw in
6090 max
sw (float conf
.scrollh
)
6093 let maxx = state
.w + winw in
6094 let x = winw - state
.x in
6095 let percent = float x /. float maxx in
6096 (fwinw -. sw) *. percent
6098 hscrollh (), position, sw
6102 match state
.mode with
6103 | LinkNav
_ -> "links"
6104 | Textentry
_ -> "textentry"
6105 | Birdseye
_ -> "birdseye"
6108 findkeyhash conf
modename
6110 method eformsgs
= true
6111 method alwaysscrolly
= false
6114 let adderrmsg src msg
=
6115 Buffer.add_string state
.errmsgs msg
;
6116 state
.newerrmsgs
<- true;
6120 let adderrfmt src fmt
=
6121 Format.ksprintf
(fun s -> adderrmsg src s) fmt
;
6125 let cl = splitatspace cmds
in
6127 try Scanf.sscanf
s fmt
f
6129 adderrfmt "remote exec"
6130 "error processing '%S': %s\n" cmds
@@ exntos exn
6133 | "reload" :: [] -> reload ()
6134 | "goto" :: args
:: [] ->
6135 scan args
"%u %f %f"
6137 let cmd, _ = state
.geomcmds
in
6139 then gotopagexy pageno x y
6142 gotopagexy pageno x y;
6145 state
.reprf
<- f state
.reprf
6147 | "goto1" :: args
:: [] -> scan args
"%u %f" gotopage
6148 | "gotor" :: args
:: [] ->
6150 (fun filename
pageno -> gotounder (Uremote
(filename
, pageno)))
6151 | "gotord" :: args
:: [] ->
6153 (fun filename
dest -> gotounder (Uremotedest
(filename
, dest)))
6154 | "rect" :: args
:: [] ->
6155 scan args
"%u %u %f %f %f %f"
6156 (fun pageno color x0 y0 x1 y1 ->
6157 onpagerect pageno (fun w h ->
6158 let _,w1,h1
,_ = getpagedim
pageno in
6159 let sw = float w1 /. float w
6160 and sh = float h1
/. float h in
6164 and y1s
= y1 *. sh in
6165 let rect = (x0s,y0s
,x1s
,y0s
,x1s
,y1s
,x0s,y1s
) in
6167 state
.rects <- (pageno, color, rect) :: state
.rects;
6168 G.postRedisplay "rect";
6171 | "activatewin" :: [] -> Wsi.activatewin
()
6172 | "quit" :: [] -> raise Quit
6174 adderrfmt "remote command"
6175 "error processing remote command: %S\n" cmds
;
6179 let scratch = Bytes.create
80 in
6180 let buf = Buffer.create
80 in
6182 match tempfailureretry
(Unix.read fd
scratch 0) 80 with
6183 | exception Unix.Unix_error
(Unix.EAGAIN
, _, _) -> None
6186 if Buffer.length
buf > 0
6188 let s = Buffer.contents
buf in
6196 match Bytes.index_from
scratch ppos '
\n'
with
6197 | pos -> if pos >= n then -1 else pos
6198 | exception Not_found
-> -1
6202 Buffer.add_subbytes
buf scratch ppos
(nlpos-ppos
);
6203 let s = Buffer.contents
buf in
6209 Buffer.add_subbytes
buf scratch ppos
(n-ppos
);
6215 let remoteopen path =
6216 try Some
(Unix.openfile
path [Unix.O_NONBLOCK
; Unix.O_RDONLY
] 0o0)
6218 adderrfmt "remoteopen" "error opening %S: %s" path @@ exntos exn
;
6223 let gcconfig = ref E.s in
6224 let trimcachepath = ref E.s in
6225 let rcmdpath = ref E.s in
6226 let pageno = ref None
in
6227 let rootwid = ref 0 in
6228 let openlast = ref false in
6229 let nofc = ref false in
6230 let doreap = ref false in
6231 selfexec := Sys.executable_name
;
6234 [("-p", Arg.String
(fun s -> state
.password <- s),
6235 "<password> Set password");
6239 Config.fontpath
:= s;
6240 selfexec := !selfexec ^
" -f " ^
Filename.quote
s;
6242 "<path> Set path to the user interface font");
6246 selfexec := !selfexec ^
" -c " ^
Filename.quote
s;
6247 Config.confpath
:= s),
6248 "<path> Set path to the configuration file");
6250 ("-last", Arg.Set
openlast, " Open last document");
6252 ("-page", Arg.Int
(fun pageno1
-> pageno := Some
(pageno1
-1)),
6253 "<page-number> Jump to page");
6255 ("-tcf", Arg.String
(fun s -> trimcachepath := s),
6256 "<path> Set path to the trim cache file");
6258 ("-dest", Arg.String
(fun s -> state
.nameddest
<- s),
6259 "<named-destination> Set named destination");
6261 ("-wtmode", Arg.Set
wtmode, " Operate in wt mode");
6262 ("-cxack", Arg.Set
cxack, " Cut corners");
6264 ("-remote", Arg.String
(fun s -> rcmdpath := s),
6265 "<path> Set path to the remote commands source");
6267 ("-origin", Arg.String
(fun s -> state
.origin
<- s),
6268 "<original-path> Set original path");
6270 ("-gc", Arg.Set_string
gcconfig,
6271 "<script-path> Collect garbage with the help of a script");
6273 ("-nofc", Arg.Set
nofc, " Do not use fontconfig");
6275 ("-v", Arg.Unit
(fun () ->
6277 "%s\nconfiguration path: %s\n"
6281 exit
0), " Print version and exit");
6283 ("-embed", Arg.Set_int
rootwid,
6284 "<window-id> Embed into window")
6287 (fun s -> state
.path <- s)
6288 ("Usage: " ^
Sys.argv
.(0) ^
" [options] some.pdf\nOptions:")
6291 then selfexec := !selfexec ^
" -wtmode";
6293 let histmode = emptystr state
.path && not
!openlast in
6295 if not
(Config.load !openlast)
6296 then dolog
"failed to load configuration";
6297 begin match !pageno with
6298 | Some
pageno -> state
.anchor <- (pageno, 0.0, 0.0)
6302 if nonemptystr
!gcconfig
6305 match Unix.socketpair
Unix.PF_UNIX
Unix.SOCK_STREAM
0 with
6306 | exception exn
-> error
"socketpair for gc failed: %s" @@ exntos exn
6309 match addpid
@@ spawn
!gcconfig [(c, 0); (c, 1); (s, -1)] with
6310 | exception exn
-> error
"failed to execute gc script: %s" @@ exntos exn
6312 Ne.clo c @@ (fun s -> error
"failed to close gc fd %s" s);
6317 let wsfd, winw, winh
= Wsi.init
(object (self)
6318 val mutable m_clicks
= 0
6319 val mutable m_click_x
= 0
6320 val mutable m_click_y
= 0
6321 val mutable m_lastclicktime
= infinity
6323 method private cleanup =
6324 state
.roam
<- noroam
;
6325 Hashtbl.iter
(fun _ opaque -> clearmark
opaque) state
.pagemap
6326 method expose
= G.postRedisplay"expose"
6330 | Wsi.Unobscured
-> "unobscured"
6331 | Wsi.PartiallyObscured
-> "partiallyobscured"
6332 | Wsi.FullyObscured
-> "fullyobscured"
6334 vlog "visibility change %s" name
6335 method display = display ()
6336 method map mapped
= vlog "mappped %b" mapped
6337 method reshape w h =
6340 method mouse
b d x y m =
6341 if d && canselect ()
6343 (* http://blogs.msdn.com/b/oldnewthing/archive/2004/10/18/243925.aspx *)
6349 if abs
x - m_click_x
> 10
6350 || abs
y - m_click_y
> 10
6351 || abs_float
(t -. m_lastclicktime
) > 0.3
6353 m_clicks
<- m_clicks
+ 1;
6354 m_lastclicktime
<- t;
6358 G.postRedisplay "cleanup";
6359 state
.uioh <- state
.uioh#button
b d x y m;
6361 else state
.uioh <- state
.uioh#multiclick m_clicks
x y m
6366 m_lastclicktime
<- infinity
;
6367 state
.uioh <- state
.uioh#button
b d x y m
6371 state
.uioh <- state
.uioh#button
b d x y m
6374 state
.mpos
<- (x, y);
6375 state
.uioh <- state
.uioh#motion
x y
6376 method pmotion
x y =
6377 state
.mpos
<- (x, y);
6378 state
.uioh <- state
.uioh#pmotion
x y
6380 let mascm = m land (
6381 Wsi.altmask
+ Wsi.shiftmask
+ Wsi.ctrlmask
+ Wsi.metamask
6384 let x = state
.x and y = state
.y in
6386 if x != state
.x || y != state
.y then self#
cleanup
6388 match state
.keystate
with
6390 let km = k
, mascm in
6393 let modehash = state
.uioh#
modehash in
6394 try Hashtbl.find modehash km
6396 try Hashtbl.find (findkeyhash conf
"global") km
6397 with Not_found
-> KMinsrt
(k
, m)
6399 | KMinsrt
(k
, m) -> keyboard k
m
6400 | KMinsrl
l -> List.iter
(fun (k
, m) -> keyboard k
m) l
6401 | KMmulti
(l, r
) -> state
.keystate
<- KSinto
(l, r
)
6403 | KSinto
((k'
, m'
) :: [], insrt
) when k'
=k
&& m'
land mascm = m'
->
6404 List.iter
(fun (k
, m) -> keyboard k
m) insrt
;
6405 state
.keystate
<- KSnone
6406 | KSinto
((k'
, m'
) :: keys, insrt
) when k'
=k
&& m'
land mascm = m'
->
6407 state
.keystate
<- KSinto
(keys, insrt
)
6408 | KSinto
_ -> state
.keystate
<- KSnone
6411 state
.mpos
<- (x, y);
6412 state
.uioh <- state
.uioh#pmotion
x y
6413 method leave = state
.mpos
<- (-1, -1)
6414 method winstate wsl
= state
.winstate
<- wsl
6415 method quit
= raise Quit
6416 end) !rootwid conf
.cwinw conf
.cwinh platform
in
6421 List.exists
GlMisc.check_extension
6422 [ "GL_ARB_texture_rectangle"
6423 ; "GL_EXT_texture_recangle"
6424 ; "GL_NV_texture_rectangle" ]
6426 then (dolog
"OpenGL does not suppport rectangular textures"; exit
1);
6429 let r = GlMisc.get_string `renderer
in
6430 let p = "Mesa DRI Intel(" in
6431 let l = String.length
p in
6432 String.length
r > l && String.sub
r 0 l = p
6435 defconf
.sliceheight
<- 1024;
6436 defconf
.texcount
<- 32;
6437 defconf
.usepbo
<- true;
6441 match Unix.socketpair
Unix.PF_UNIX
Unix.SOCK_STREAM
0 with
6443 dolog
"socketpair failed: %s" @@ exntos exn
;
6451 setcheckers conf
.checkers
;
6454 conf
.angle
, conf
.fitmodel
, (conf
.trimmargins
, conf
.trimfuzz
),
6455 conf
.texcount
, conf
.sliceheight
, conf
.mustoresize
, conf
.colorspace
,
6456 !Config.fontpath
, !trimcachepath,
6457 GlMisc.check_extension
"GL_ARB_pixel_buffer_object",
6460 List.iter
GlArray.enable
[`texture_coord
; `vertex
];
6462 reshape ~firsttime
:true winw winh
;
6466 Wsi.settitle
"llpp (history)";
6470 state
.text <- "Opening " ^
(mbtoutf8 state
.path);
6471 opendoc state
.path state
.password;
6475 Wsi.setcursor
Wsi.CURSOR_INHERIT
;
6476 Sys.set_signal
Sys.sighup
(Sys.Signal_handle
(fun _ -> reload ()));
6479 match Unix.waitpid
[Unix.WNOHANG
] ~
-1 with
6480 | (exception (Unix.Unix_error
(Unix.ECHILD
, _, _))) -> ()
6481 | (exception exn
) -> dolog
"Unix.waitpid: %s" @@ exntos exn
6483 | _pid
, _status
-> reap ()
6485 Sys.set_signal
Sys.sigchld
(Sys.Signal_handle
(fun _ -> doreap := true));
6489 if nonemptystr
!rcmdpath
6490 then remoteopen !rcmdpath
6495 let rec loop deadline
=
6501 let r = [state
.ss; state
.wsfd] in
6505 | Some fd
-> fd
:: r
6509 state
.redisplay
<- false;
6516 if deadline
= infinity
6518 else max
0.0 (deadline
-. now)
6523 try Unix.select
r [] [] timeout
6524 with Unix.Unix_error
(Unix.EINTR
, _, _) -> [], [], []
6530 if state
.ghyll
== noghyll
6532 match state
.autoscroll
with
6533 | Some step
when step
!= 0 ->
6534 let y = state
.y + step
in
6538 else if y >= state
.maxy then 0 else y
6541 if state
.mode = View
6542 then state
.text <- E.s;
6545 else deadline
+. 0.01
6550 let rec checkfds = function
6552 | fd
:: rest
when fd
= state
.ss ->
6553 let cmd = readcmd state
.ss in
6557 | fd
:: rest
when fd
= state
.wsfd ->
6561 | fd
:: rest
when Some fd
= !optrfd ->
6562 begin match remote fd
with
6563 | None
-> optrfd := remoteopen !rcmdpath;
6564 | opt -> optrfd := opt
6569 dolog
"select returned unknown descriptor";
6575 if deadline
= infinity
6579 match state
.autoscroll
with
6580 | Some step
when step
!= 0 -> deadline1
6581 | _ -> if state
.ghyll
== noghyll
then infinity
else deadline1
6589 Config.save leavebirdseye;
6590 if hasunsavedchanges
()