main.ml (10857B)
1 (* Unison file synchronizer: src/main.ml *) 2 (* Copyright 1999-2020, Benjamin C. Pierce 3 4 This program is free software: you can redistribute it and/or modify 5 it under the terms of the GNU General Public License as published by 6 the Free Software Foundation, either version 3 of the License, or 7 (at your option) any later version. 8 9 This program is distributed in the hope that it will be useful, 10 but WITHOUT ANY WARRANTY; without even the implied warranty of 11 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 12 GNU General Public License for more details. 13 14 You should have received a copy of the GNU General Public License 15 along with this program. If not, see <http://www.gnu.org/licenses/>. 16 *) 17 18 19 (* ---------------------------------------------------------------------- *) 20 21 (* This is the main program -- the thing that gets executed first when 22 unison is run. 23 24 The Main module is actually a functor that takes the user interface 25 (e.g., Uitext or Uigtk) as a parameter. This allows us to build with 26 just one user interface at a time, which avoids having to always link 27 in all the libraries needed by all the user interfaces. 28 29 A non-functor interface is provided to allow the Mac GUI to reuse the 30 startup code for non-GUI options. 31 *) 32 33 (* ---------------------------------------------------------------------- *) 34 35 (* Some command-line arguments are handled specially during startup, e.g., 36 -doc 37 -help 38 -version 39 -server 40 -socket 41 -ui 42 They are expected to appear on the command-line only, not in a 43 profile. In particular, -version and -doc will print to the 44 standard output, so they only make sense if invoked from the 45 command-line (and not a click-launched gui that has no standard 46 output). 47 48 Furthermore, the actions associated with these command-line 49 arguments are executed without loading a profile or doing the usual 50 command-line parsing. This is because we want to run the actions 51 without loading a profile; and then we can't do command-line 52 parsing because it is intertwined with profile loading. 53 54 NB: the Mac GUI handles these options itself and needs to change 55 if any more are added. 56 *) 57 58 let versionPrefName = "version" 59 let printVersionAndExit = 60 Prefs.createBool versionPrefName false 61 ~category:(`Basic `General) 62 ~cli_only:true 63 "print version and exit" 64 ("Print the current version number and exit. " 65 ^ "(This option only makes sense on the command line.)") 66 67 let docsPrefName = "doc" 68 let docs = 69 Prefs.createString docsPrefName "" 70 ~category:(`Basic `General) 71 ~cli_only:true 72 "show documentation ('-doc topics' lists topics)" 73 ( "The command-line argument \\texttt{-doc \\ARG{secname}} causes unison to " 74 ^ "display section \\ARG{secname} of the manual on the standard output " 75 ^ "and then exit. Use \\verb|-doc all| to display the whole manual, " 76 ^ "which includes exactly the same information as the printed and HTML " 77 ^ "manuals, modulo " 78 ^ "formatting. Use \\verb|-doc topics| to obtain a list of the " 79 ^ "names of the various sections that can be printed.") 80 81 let prefsdocsPrefName = "prefsdocs" 82 let prefsdocs = 83 Prefs.createBool prefsdocsPrefName false 84 ~category:(`Internal `Devel) 85 ~cli_only:true 86 "*show full documentation for all preferences (and then exit)" 87 "" 88 89 let prefsmanPrefName = "prefsman" 90 let prefsman = 91 Prefs.createString prefsmanPrefName "" 92 ~category:(`Internal `Devel) 93 ~cli_only:true 94 "*show manpage documentation for all preferences (and then exit)" 95 "" 96 97 let serverPrefName = "server" 98 let server = 99 Prefs.createBool serverPrefName false 100 ~category:(`Internal `Other) 101 ~cli_only:true 102 "*normal or server mode" "" 103 104 let socketPrefName = "socket" 105 let socket = 106 Prefs.createString socketPrefName "" 107 ~category:(`Advanced `Remote) 108 ~cli_only:true 109 "act as a server on a socket" 110 ("Start " ^ Uutil.myName ^ " as a server listening on a TCP socket " 111 ^ "(with TCP port number as argument) or a local socket (aka Unix " 112 ^ "domain socket) (with socket path as argument).") 113 114 let serverHostNameAlias = "host" 115 let serverHostName = "listen" 116 let serverHost = 117 Prefs.createString serverHostName "" 118 ~category:(`Advanced `Remote) 119 ~cli_only:true 120 "listen on this name or addr in server socket mode (can repeat)" 121 ("When acting as a server on a TCP socket, Unison will by default listen " 122 ^ "on \"any\" address (0.0.0.0 and [::]). This command-line argument " 123 ^ "allows to specify a different listening address and can be repeated " 124 ^ "to listen on multiple addresses. Listening address can be specified " 125 ^ "as a host name or an IP address.") 126 let () = Prefs.alias serverHost serverHostNameAlias 127 128 (* User preference for which UI to use if there is a choice *) 129 let uiPrefName = "ui" 130 let interface = 131 Prefs.create uiPrefName Uicommon.Graphic 132 ~category:(`Advanced `General) 133 ~cli_only:true 134 "select UI ('text' or 'graphic'); command-line only" 135 ("This preference selects either the graphical or the textual user " 136 ^ "interface. Legal values are \\verb|graphic| or \\verb|text|. " 137 ^ "\n\nBecause this option is processed specially during Unison's " 138 ^ "start-up sequence, it can {\\em only} be used on the command line. " 139 ^ "In preference files it has no effect." 140 ^ "\n\nIf " 141 ^ "the Unison executable was compiled with only a textual interface, " 142 ^ "this option has " 143 ^ "no effect. (The pre-compiled binaries are all compiled with both " 144 ^ "interfaces available.)") 145 (fun _ -> function 146 "text" -> Uicommon.Text 147 | "graphic" -> Uicommon.Graphic 148 | other -> 149 raise (Prefs.IllegalValue ("option ui :\n\ 150 text -> textual user interface\n\ 151 graphic -> graphic user interface\n" 152 ^other^ " is not a legal value"))) 153 (function Uicommon.Text -> ["text"] 154 | Uicommon.Graphic -> ["graphic"]) 155 Uicommon.minterface 156 157 let catch_all f = 158 try 159 try 160 (* Util.msg "Starting catch_all...\n"; *) 161 f (); 162 (* Util.msg "Done catch_all...\n"; *) 163 with Prefs.IllegalValue str -> raise (Util.Fatal str) 164 with e -> 165 Util.msg "Unison server failed: %s\n" (Uicommon.exn2string e); 166 (* A final desperate attempt to print out some debug information. 167 If we are really-really out of memory then this may fail but 168 then it's unlikely we reach this point anyway. *) 169 if e = Out_of_memory then Gc.print_stat stderr; 170 exit 1 171 172 let gui_safe_printf fmt = 173 Printf.ksprintf (fun s -> 174 if System.has_stdout ~info:s then Printf.printf "%s" s) fmt 175 176 let verify_stdout () = 177 if not (System.has_stdout ~info:"") then exit 37 178 179 let init () = begin 180 ignore (Gc.set {(Gc.get ()) with Gc.max_overhead = 150}); 181 (* Make sure exception descriptions include backtraces *) 182 Printexc.record_backtrace true; 183 184 let argv = Prefs.scanCmdLine Uicommon.usageMsg in 185 186 (* Print version if requested *) 187 if Util.StringMap.mem versionPrefName argv then begin 188 gui_safe_printf "%s version %s\n" Uutil.myName Uutil.myVersion; 189 exit 0 190 end; 191 192 (* Print docs for all preferences if requested (this is used when building 193 the manual) *) 194 if Util.StringMap.mem prefsdocsPrefName argv then begin 195 Prefs.printFullDocs `TeX; 196 exit 0 197 end; 198 199 if Util.StringMap.mem prefsmanPrefName argv then begin 200 begin match Util.StringMap.find prefsmanPrefName argv with 201 | "short" :: _ -> Prefs.printUsageForMan () 202 | "full" :: _ -> Prefs.printFullDocs `man 203 | _ -> () 204 end; 205 exit 0 206 end; 207 208 (* Display documentation if requested *) 209 begin try 210 let docv = Util.StringMap.find docsPrefName argv in 211 verify_stdout (); 212 begin match docv with 213 [] -> 214 assert false 215 | "topics"::_ -> 216 Printf.printf "Documentation topics:\n"; 217 Safelist.iter 218 (fun (sn,(n,doc)) -> 219 if sn<>"" then Printf.printf " %12s %s\n" sn n) 220 Strings.docs; 221 Printf.printf 222 "\nType \"%s -doc <topic>\" for detailed information about <topic>\n" 223 Uutil.myName; 224 Printf.printf 225 "or \"%s -doc all\" for the whole manual\n\n" 226 Uutil.myName 227 | "all"::_ -> 228 Printf.printf "\n"; 229 Safelist.iter 230 (fun (sn,(n,doc)) -> if n<>"Junk" then Printf.printf "%s\n" doc) 231 Strings.docs 232 | topic::_ -> 233 (try 234 let (_,d) = Safelist.assoc topic Strings.docs in 235 Printf.printf "\n%s\n" d 236 with 237 Not_found -> 238 Printf.printf "Documentation topic %s not recognized:" 239 topic; 240 Printf.printf "\nType \"%s -doc topics\" for a list\n" 241 Uutil.myName) 242 end; 243 exit 0 244 with 245 | Not_found -> () 246 | Sys_error _ (* Broken pipe *) -> 247 (* A broken pipe (when stdout is piped to pager, for example) will cause 248 all output functions, including flush, to raise an exception. Catching 249 the exception here is not sufficient because stdout is implicitly 250 flushed on exit, which will again raise a broken pipe exception. The 251 only way to avoid [exit] raising a broken pipe exception is to close 252 [stdout] beforehand. *) 253 close_out_noerr stdout; 254 exit 0 255 end; 256 257 (* Start a server if requested *) 258 if Util.StringMap.mem serverPrefName argv then begin 259 catch_all (fun () -> 260 Os.createUnisonDir(); 261 Remote.beAServer(); 262 exit 0) 263 end; 264 265 (* Start a socket server if requested *) 266 begin try 267 let i = List.hd (Util.StringMap.find socketPrefName argv) in 268 catch_all (fun () -> 269 Os.createUnisonDir(); 270 Remote.waitOnPort 271 ((try Util.StringMap.find serverHostName argv with Not_found -> []) @ 272 (try Util.StringMap.find serverHostNameAlias argv with Not_found -> [])) 273 i); 274 exit 0 275 with Not_found -> () end; 276 argv 277 end 278 279 (* non-GUI startup for Mac GUI version *) 280 let nonGuiStartup () = begin 281 let argv = init() in (* might not return *) 282 (* if it returns start a UI *) 283 (try 284 (match Util.StringMap.find uiPrefName argv with 285 "text"::_ -> (Uitext.Body.start Uicommon.Text; exit 0) 286 | "graphic"::_ -> () (* fallthru *) 287 | _ -> Prefs.printUsage Uicommon.usageMsg; exit 1) 288 with Not_found -> ()); 289 () 290 end 291 292 module Body = functor (Ui : Uicommon.UI) -> struct 293 let argv = init() in (* might not return *) 294 (* if it returns start a UI *) 295 Ui.start 296 (try 297 (match Util.StringMap.find uiPrefName argv with 298 | "text"::_ -> verify_stdout (); Uicommon.Text 299 | "graphic"::_ -> Uicommon.Graphic 300 | _ -> verify_stdout (); Prefs.printUsage Uicommon.usageMsg; exit 1) 301 with Not_found -> Ui.defaultUi) 302 end