New Upstream Release - unison-2.51+4.13.1
Ready changes
Summary
Merged new upstream version: 2.53.3 (was: 2.51.5).
Diff
diff --git a/.depend b/.depend
deleted file mode 100644
index fb248ed..0000000
--- a/.depend
+++ /dev/null
@@ -1,209 +0,0 @@
-doc/docs.cmo :
-doc/docs.cmx :
-icons/svg_to_data.cmo :
-icons/svg_to_data.cmx :
-src/abort.cmo : src/abort.cmi
-src/abort.cmx : src/abort.cmi
-src/bytearray.cmo : src/bytearray.cmi
-src/bytearray.cmx : src/bytearray.cmi
-src/case.cmo : src/case.cmi
-src/case.cmx : src/case.cmi
-src/checksum.cmo : src/checksum.cmi
-src/checksum.cmx : src/checksum.cmi
-src/clroot.cmo : src/clroot.cmi
-src/clroot.cmx : src/clroot.cmi
-src/common.cmo : src/common.cmi
-src/common.cmx : src/common.cmi
-src/copy.cmo : src/copy.cmi
-src/copy.cmx : src/copy.cmi
-src/external.cmo : src/external.cmi
-src/external.cmx : src/external.cmi
-src/fileinfo.cmo : src/fileinfo.cmi
-src/fileinfo.cmx : src/fileinfo.cmi
-src/files.cmo : src/files.cmi
-src/files.cmx : src/files.cmi
-src/fileutil.cmo : src/fileutil.cmi
-src/fileutil.cmx : src/fileutil.cmi
-src/fingerprint.cmo : src/fingerprint.cmi
-src/fingerprint.cmx : src/fingerprint.cmi
-src/fpcache.cmo : src/fpcache.cmi
-src/fpcache.cmx : src/fpcache.cmi
-src/fs.cmo : src/fs.cmi
-src/fs.cmx : src/fs.cmi
-src/fspath.cmo : src/fspath.cmi
-src/fspath.cmx : src/fspath.cmi
-src/fswatch.cmo : src/fswatch.cmi
-src/fswatch.cmx : src/fswatch.cmi
-src/fswatchold.cmo : src/fswatchold.cmi
-src/fswatchold.cmx : src/fswatchold.cmi
-src/globals.cmo : src/globals.cmi
-src/globals.cmx : src/globals.cmi
-src/linkgtk.cmo :
-src/linkgtk.cmx :
-src/linkgtk2.cmo :
-src/linkgtk2.cmx :
-src/linktext.cmo :
-src/linktext.cmx :
-src/lock.cmo : src/lock.cmi
-src/lock.cmx : src/lock.cmi
-src/main.cmo :
-src/main.cmx :
-src/mkProjectInfo.cmo :
-src/mkProjectInfo.cmx :
-src/name.cmo : src/name.cmi
-src/name.cmx : src/name.cmi
-src/os.cmo : src/os.cmi
-src/os.cmx : src/os.cmi
-src/osx.cmo : src/osx.cmi
-src/osx.cmx : src/osx.cmi
-src/path.cmo : src/path.cmi
-src/path.cmx : src/path.cmi
-src/pixmaps.cmo :
-src/pixmaps.cmx :
-src/pred.cmo : src/pred.cmi
-src/pred.cmx : src/pred.cmi
-src/props.cmo : src/props.cmi
-src/props.cmx : src/props.cmi
-src/recon.cmo : src/recon.cmi
-src/recon.cmx : src/recon.cmi
-src/remote.cmo : src/remote.cmi
-src/remote.cmx : src/remote.cmi
-src/sortri.cmo : src/sortri.cmi
-src/sortri.cmx : src/sortri.cmi
-src/stasher.cmo : src/stasher.cmi
-src/stasher.cmx : src/stasher.cmi
-src/strings.cmo : src/strings.cmi
-src/strings.cmx : src/strings.cmi
-src/system.cmo : src/system.cmi
-src/system.cmx : src/system.cmi
-src/terminal.cmo : src/terminal.cmi
-src/terminal.cmx : src/terminal.cmi
-src/test.cmo : src/test.cmi
-src/test.cmx : src/test.cmi
-src/transfer.cmo : src/transfer.cmi
-src/transfer.cmx : src/transfer.cmi
-src/transport.cmo : src/transport.cmi
-src/transport.cmx : src/transport.cmi
-src/tree.cmo : src/tree.cmi
-src/tree.cmx : src/tree.cmi
-src/uicommon.cmo : src/uicommon.cmi
-src/uicommon.cmx : src/uicommon.cmi
-src/uigtk2.cmo : src/uigtk2.cmi
-src/uigtk2.cmx : src/uigtk2.cmi
-src/uimacbridge.cmo :
-src/uimacbridge.cmx :
-src/uimacbridgenew.cmo :
-src/uimacbridgenew.cmx :
-src/uitext.cmo : src/uitext.cmi
-src/uitext.cmx : src/uitext.cmi
-src/unicode.cmo : src/unicode.cmi
-src/unicode.cmx : src/unicode.cmi
-src/unicode_tables.cmo :
-src/unicode_tables.cmx :
-src/update.cmo : src/update.cmi
-src/update.cmx : src/update.cmi
-src/uutil.cmo : src/uutil.cmi
-src/uutil.cmx : src/uutil.cmi
-src/xferhint.cmo : src/xferhint.cmi
-src/xferhint.cmx : src/xferhint.cmi
-tools/ask.cmo :
-tools/ask.cmx :
-tools/asktk.cmo :
-tools/asktk.cmx :
-unicode_utils/reorder.cmo :
-unicode_utils/reorder.cmx :
-unicode_utils/unicode.cmo :
-unicode_utils/unicode.cmx :
-unicode_utils/unicode_build.cmo :
-unicode_utils/unicode_build.cmx :
-unicode_utils/unicode_test.cmo :
-unicode_utils/unicode_test.cmx :
-src/abort.cmi :
-src/bytearray.cmi :
-src/case.cmi :
-src/checksum.cmi :
-src/clroot.cmi :
-src/common.cmi :
-src/copy.cmi :
-src/external.cmi :
-src/fileinfo.cmi :
-src/files.cmi :
-src/fileutil.cmi :
-src/fingerprint.cmi :
-src/fpcache.cmi :
-src/fs.cmi :
-src/fspath.cmi :
-src/fswatch.cmi :
-src/fswatchold.cmi :
-src/globals.cmi :
-src/lock.cmi :
-src/name.cmi :
-src/os.cmi :
-src/osx.cmi :
-src/path.cmi :
-src/pred.cmi :
-src/props.cmi :
-src/recon.cmi :
-src/remote.cmi :
-src/sortri.cmi :
-src/stasher.cmi :
-src/strings.cmi :
-src/system.cmi :
-src/terminal.cmi :
-src/test.cmi :
-src/transfer.cmi :
-src/transport.cmi :
-src/tree.cmi :
-src/ui.cmi :
-src/uicommon.cmi :
-src/uigtk2.cmi :
-src/uitext.cmi :
-src/unicode.cmi :
-src/update.cmi :
-src/uutil.cmi :
-src/xferhint.cmi :
-src/fsmonitor/watchercommon.cmo : src/fsmonitor/watchercommon.cmi
-src/fsmonitor/watchercommon.cmx : src/fsmonitor/watchercommon.cmi
-src/lwt/lwt.cmo : src/lwt/lwt.cmi
-src/lwt/lwt.cmx : src/lwt/lwt.cmi
-src/lwt/lwt_unix.cmo : src/lwt/lwt_unix.cmi
-src/lwt/lwt_unix.cmx : src/lwt/lwt_unix.cmi
-src/lwt/lwt_util.cmo : src/lwt/lwt_util.cmi
-src/lwt/lwt_util.cmx : src/lwt/lwt_util.cmi
-src/lwt/pqueue.cmo : src/lwt/pqueue.cmi
-src/lwt/pqueue.cmx : src/lwt/pqueue.cmi
-src/system/system_generic.cmo :
-src/system/system_generic.cmx :
-src/system/system_intf.cmo :
-src/system/system_intf.cmx :
-src/system/system_win.cmo :
-src/system/system_win.cmx :
-src/ubase/myMap.cmo : src/ubase/myMap.cmi
-src/ubase/myMap.cmx : src/ubase/myMap.cmi
-src/ubase/prefs.cmo : src/ubase/prefs.cmi
-src/ubase/prefs.cmx : src/ubase/prefs.cmi
-src/ubase/proplist.cmo : src/ubase/proplist.cmi
-src/ubase/proplist.cmx : src/ubase/proplist.cmi
-src/ubase/rx.cmo : src/ubase/rx.cmi
-src/ubase/rx.cmx : src/ubase/rx.cmi
-src/ubase/safelist.cmo : src/ubase/safelist.cmi
-src/ubase/safelist.cmx : src/ubase/safelist.cmi
-src/ubase/trace.cmo : src/ubase/trace.cmi
-src/ubase/trace.cmx : src/ubase/trace.cmi
-src/ubase/uarg.cmo : src/ubase/uarg.cmi
-src/ubase/uarg.cmx : src/ubase/uarg.cmi
-src/ubase/util.cmo : src/ubase/util.cmi
-src/ubase/util.cmx : src/ubase/util.cmi
-src/fsmonitor/watchercommon.cmi :
-src/lwt/lwt.cmi :
-src/lwt/lwt_unix.cmi :
-src/lwt/lwt_util.cmi :
-src/lwt/pqueue.cmi :
-src/ubase/myMap.cmi :
-src/ubase/prefs.cmi :
-src/ubase/proplist.cmi :
-src/ubase/rx.cmi :
-src/ubase/safelist.cmi :
-src/ubase/trace.cmi :
-src/ubase/uarg.cmi :
-src/ubase/util.cmi :
diff --git a/.github/workflows/CI.yml b/.github/workflows/CI.yml
new file mode 100644
index 0000000..6db1c59
--- /dev/null
+++ b/.github/workflows/CI.yml
@@ -0,0 +1,1220 @@
+name: CI
+
+env:
+ PROJECT_NAME: unison
+ PROJECT_DESC: "`unison` file synchronizer"
+ PROJECT_EXES: "unison unison-fsmonitor"
+
+on:
+ - pull_request
+ - push
+
+jobs:
+ docs:
+ runs-on: ubuntu-20.04
+
+ steps:
+ - run: sudo apt-get update
+
+ - name: Checkout code
+ uses: actions/checkout@v3
+
+ - name: Use OCaml
+ uses: ocaml/setup-ocaml@v2
+ with:
+ ocaml-compiler: 4.14.x
+ opam-depext: false
+
+ - run: sudo apt-get install hevea lynx texlive-latex-base
+
+ - run: opam exec -- make docs
+
+ - name: Store user manual for the build jobs
+ uses: actions/upload-artifact@v3
+ with:
+ name: unison-docs
+ path: |
+ doc/unison-manual.txt
+ doc/unison-manual.html
+ doc/unison-manual.pdf
+
+ build:
+ if: ${{ !cancelled() }} # Don't fail if 'docs' failed
+ needs: docs
+
+ strategy:
+ fail-fast: false
+ matrix:
+ job:
+ - { os: macos-12 , ocaml-version: 5.0.0 }
+ - { os: macos-12 , ocaml-version: 4.14.1 }
+ - { os: macos-10.15 , ocaml-version: 4.14.1 , publish: true , fnsuffix: -macos-x86_64 }
+ - { os: ubuntu-22.04 , ocaml-version: 5.0.0 }
+ - { os: ubuntu-22.04 , ocaml-version: 4.14.1 }
+ - { os: ubuntu-20.04 , ocaml-version: 4.14.1 }
+ - { os: windows-2022 , ocaml-version: 4.14.0+mingw64c , publish: true , fnsuffix: -windows-x86_64 }
+ - { os: windows-2019 , ocaml-version: 4.14.0+mingw32c , publish: true , fnsuffix: -windows-i386 }
+
+ runs-on: ${{ matrix.job.os }}
+
+ steps:
+ - if: contains(matrix.job.os, 'ubuntu')
+ run: sudo apt-get update
+
+ - if: runner.os == 'Windows'
+ name: "Windows: Stash away the default MSYS installation"
+ continue-on-error: true
+ shell: cmd
+ # This conflicts with Cygwin installed by setup-ocaml
+ # Adjusting PATH alone does not seem to work
+ run: rename C:\msys64 dmsys64
+
+ - name: Checkout code
+ uses: actions/checkout@v3
+
+ - name: Initialize workflow variables
+ id: vars
+ shell: bash
+ run: |
+ outputs() { for var in "$@" ; do echo steps.vars.outputs.${var}="${!var}"; echo "${var}=${!var}" >> $GITHUB_OUTPUT ; done; }
+ # normalize to pre-compiled ocaml compiler variants for windows/Cygwin (decreases OCaml install time by 50%)
+ case '${{ matrix.job.ocaml-version }}' in
+ *+*) OCAML_COMPILER='ocaml-variants.${{ matrix.job.ocaml-version }}' ;;
+ *) OCAML_COMPILER='ocaml-base-compiler.${{ matrix.job.ocaml-version }}' ;;
+ esac
+ OCAML_VARIANT='${{ matrix.job.ocaml-version }}'
+ OCAML_VARIANT="${OCAML_VARIANT/+options/}"
+ outputs OCAML_VARIANT OCAML_COMPILER
+ # architecture/platform vars
+ EXE_suffix='' ; case '${{ matrix.job.os }}' in windows-*) EXE_suffix=".exe" ;; esac
+ MinGW_ARCH='x86_64' ; case '${{ matrix.job.ocaml-version }}' in *+mingw32*) MinGW_ARCH='i686' ;; *+mingw64*) MinGW_ARCH='x86_64' ;; esac
+ MSVC_ARCH='' ; case '${{ matrix.job.ocaml-version }}' in *+msvc32*) MSVC_ARCH='x86' ;; *+msvc64*) MSVC_ARCH='x64' ;; esac
+ STATIC='false' ; case '${{ matrix.job.ocaml-version }}' in *-musl*) STATIC='true' ;; esac
+ outputs EXE_suffix MinGW_ARCH MSVC_ARCH STATIC
+ case '${{ matrix.job.os }}','${{ matrix.job.ocaml-version }}' in
+ macos-*,4*) MACOSX_DEPLOYMENT_TARGET=10.6 ;; macos-*,5*) MACOSX_DEPLOYMENT_TARGET=10.7 ;;
+ esac
+ case '${{ matrix.job.os }}' in
+ macos-*) echo "MACOSX_DEPLOYMENT_TARGET=${MACOSX_DEPLOYMENT_TARGET}" >> $GITHUB_ENV ;
+ echo "XCODEFLAGS=-arch $(uname -m) -mmacosx-version-min=${MACOSX_DEPLOYMENT_TARGET} MACOSX_DEPLOYMENT_TARGET=${MACOSX_DEPLOYMENT_TARGET}" >> $GITHUB_ENV ;
+ echo "CFLAGS=${CFLAGS} -mmacosx-version-min=${MACOSX_DEPLOYMENT_TARGET}" >> $GITHUB_ENV ;;
+ esac
+ # staging environment
+ STAGING_DIR='_staging'
+ outputs STAGING_DIR
+ # parse commit reference info
+ echo GITHUB_REF=${GITHUB_REF}
+ echo GITHUB_SHA=${GITHUB_SHA}
+ REF_NAME="${GITHUB_REF#refs/*/}"
+ unset REF_BRANCH ; case "${GITHUB_REF}" in refs/heads/*) REF_BRANCH="${GITHUB_REF#refs/heads/}" ;; esac;
+ unset REF_TAG ; case "${GITHUB_REF}" in refs/tags/*) REF_TAG="${GITHUB_REF#refs/tags/}" ;; esac;
+ REF_SHAS="${GITHUB_SHA:0:8}"
+ outputs REF_BRANCH REF_NAME REF_SHAS REF_TAG
+ # deployable tag? (ie, leading "vM" or "M"; M == version number)
+ unset DEPLOY ; if [[ $REF_TAG =~ ^[vV]?[0-9].* ]]; then DEPLOY='true' ; fi
+ outputs DEPLOY
+ # package name
+ PKG_suffix='.tar.gz' ; case '${{ matrix.job.os }}' in windows-*) PKG_suffix='.zip' ;; esac;
+ PKG_VER="${REF_TAG:-git_$REF_SHAS}"
+ PKG_VER="${PKG_VER#v}"
+ PKG_BASENAME="${PROJECT_NAME}-${PKG_VER}${{ matrix.job.fnsuffix }}"
+ PKG_NAME="${PKG_BASENAME}${PKG_suffix}"
+ PKG_DIR="${STAGING_DIR}/${PKG_BASENAME}"
+ outputs PKG_VER PKG_BASENAME PKG_DIR PKG_NAME PKG_suffix
+ COMPRESS_CMD='tar czf'; case '${{ matrix.job.os }}' in windows-*) COMPRESS_CMD='7z -y a' ;; esac;
+ outputs COMPRESS_CMD
+
+ - name: Create/configure any needed build/workspace
+ shell: bash
+ run: |
+ # create build/work space
+ mkdir -p '${{ steps.vars.outputs.STAGING_DIR }}'
+ mkdir -p '${{ steps.vars.outputs.PKG_DIR }}'
+ mkdir -p '${{ steps.vars.outputs.PKG_DIR }}'/bin
+
+ - name: Enable/config MSVC environment (if/when needed)
+ uses: ilammy/msvc-dev-cmd@v1
+ with:
+ arch: "${{ steps.vars.outputs.MSVC_ARCH }}"
+ if: contains(matrix.job.ocaml-version, '+msvc')
+
+ - name: Use OCaml ${{ matrix.job.ocaml-version }}
+ uses: ocaml/setup-ocaml@v2
+ with:
+ ocaml-compiler: "${{ steps.vars.outputs.OCAML_COMPILER }}"
+ opam-pin: false
+ opam-depext: false
+ # setup-ocaml can prepare the build environment from unison.opam
+ # We're not relying on that capability here, to make sure the builds
+ # also work without using unison.opam
+
+ ## note: at this point, after OCaml installation, windows platforms will use Cygwin bash as the default
+ ## ... Cygwin bash cannot handle shell scripts containing CRLF EOLs (which are what is generated by GHA on windows platforms)
+ ## ... so, "igncr" must be added to SHELLOPTS
+
+ - name: Prepare Cygwin environment (Windows)
+ if: runner.os == 'Windows'
+ shell: cmd
+ run: |
+ echo %CYGWIN_ROOT_BIN%>> %GITHUB_PATH%
+ echo %CYGWIN_ROOT_WRAPPERBIN%>> %GITHUB_PATH%
+ echo "/usr/${{ steps.vars.outputs.MinGW_ARCH }}-w64-mingw32/sys-root/mingw/bin">> %GITHUB_PATH%
+ echo SHELLOPTS=igncr>> %GITHUB_ENV%
+
+ - shell: bash
+ run: |
+ opam exec -- make src OSTYPE=$OSTYPE UISTYLE=text STATIC=${{ steps.vars.outputs.STATIC }}
+ # stage
+ # * notes: darwin/macos doesn't build `unison-fsmonitor`
+ for file in ${PROJECT_EXES} ; do
+ if [ -f "src/${file}${{ steps.vars.outputs.EXE_suffix }}" ]; then
+ cp "src/${file}${{ steps.vars.outputs.EXE_suffix }}" '${{ steps.vars.outputs.PKG_DIR }}/bin'
+ echo "'src/${file}${{ steps.vars.outputs.EXE_suffix }}' copied to '${{ steps.vars.outputs.PKG_DIR }}/bin'"
+ fi
+ done
+
+ - run: opam exec -- make test
+
+ ## There is still code to run tests with old ocaml on Windows.
+ ## That remains intentionally so that someone could turn it on if
+ ## desired.
+ - name: Run self-tests over RPC
+ if: runner.os == 'Windows' && !contains(matrix.job.ocaml-version, '4.14')
+ shell: bash
+ run: |
+ # Separate backup dir must be set for server instance so that the central
+ # backup location of both instances doesn't overlap
+ UNISONBACKUPDIR=./src/testbak2 ./src/unison -socket 55443 &
+ sleep 1 # Wait for the server to be fully started
+ ./src/unison -ui text -selftest testr1 socket://127.0.0.1:55443/testr2 -killserver
+
+ - name: Run self-tests over local socket
+ # Recent Windows versions do support Unix domain sockets
+ # but at least OCaml 4.14 is required to use that support
+ if: runner.os != 'Windows' || contains(matrix.job.ocaml-version, '4.14')
+ shell: bash
+ run: |
+ mkdir localsocket
+ chmod 700 localsocket
+ # Separate backup dir must be set for server instance so that the central
+ # backup location of both instances doesn't overlap
+ UNISONBACKUPDIR=./src/testbak4 ./src/unison -socket ./localsocket/test.sock &
+ sleep 1 # Wait for the server to be fully started
+ ${{ runner.os == 'Windows' }} || test -S ./localsocket/test.sock
+ ./src/unison -ui text -selftest testr3 socket://{./localsocket/test.sock}/testr4 -killserver
+
+ - name: Prepare lablgtk install (Windows)
+ if: ${{ runner.os == 'Windows' && contains(matrix.job.ocaml-version, '+mingw') }}
+ shell: bash
+ run: |
+ opam install opam-depext depext-cygwinports
+ setup-x86_64.exe --quiet-mode --root "${CYGWIN_ROOT}" --site http://cygwin.mirror.constant.com --symlink-type=sys --packages hicolor-icon-theme,adwaita-icon-theme
+ # [2022-11] This terrible (terrible) hack is here to forcibly skip
+ # building the fontconfig cache because it can take 30-45 minutes
+ # on GHA runners and is never needed anyway.
+ setup-x86_64.exe --quiet-mode --root "${CYGWIN_ROOT}" --site http://cygwin.mirror.constant.com --symlink-type=sys --local-package-dir D:/a --download --packages mingw64-${{ steps.vars.outputs.MinGW_ARCH }}-fontconfig
+ cd 'D:/a/https%3a%2f%2fcygwin.mirror.constant.com%2f/noarch/release/'mingw64-${{ steps.vars.outputs.MinGW_ARCH }}-fontconfig
+ CNAMEXZ=$(ls mingw64-${{ steps.vars.outputs.MinGW_ARCH }}-fontconfig*.tar.xz)
+ CNAME=${CNAMEXZ%.xz}
+ unxz ${CNAMEXZ}
+ tar --delete --file ${CNAME} etc/postinstall/zp_mingw64-${{ steps.vars.outputs.MinGW_ARCH }}-fontconfig_cache.sh
+ xz ${CNAME}
+ sha512sum > sha512.sum
+ CSZ=$(stat -c %s ${CNAMEXZ})
+ SHASUM=$(sha512sum ${CNAMEXZ})
+ cd 'D:/a/https%3a%2f%2fcygwin.mirror.constant.com%2f/x86_64'
+ mv setup.ini tsetup.ini
+ rm -f setup*
+ sed -E -e "\|install: noarch/release/mingw64-${{ steps.vars.outputs.MinGW_ARCH }}-fontconfig/${CNAMEXZ}|s/xz .+/xz ${CSZ} ${SHASUM%% *}/" tsetup.ini > setup.ini
+ rm tsetup.ini
+ sha512sum > sha512.sum
+ setup-x86_64.exe --quiet-mode --root "${CYGWIN_ROOT}" --symlink-type=sys --local-install --local-package-dir 'D:/a/https%3a%2f%2fcygwin.mirror.constant.com%2f' --mirror-mode --no-verify --packages mingw64-${{ steps.vars.outputs.MinGW_ARCH }}-fontconfig
+
+ - name: lablgtk install
+ ## [2020-09] non-working/unavailable for MSVC or musl OCaml variants ; also, non-working for 32bit OCaml variant (see [GH:garrigue/lablgtk#64](https://github.com/garrigue/lablgtk/issues/64))
+ if: ${{ ! ( contains(matrix.job.ocaml-version, '+msvc') || contains(matrix.job.ocaml-version, '-musl') || contains(matrix.job.ocaml-version, '-32bit') ) }}
+ run: opam depext --install --verbose --yes lablgtk3 && opam install ocamlfind
+
+ - if: steps.vars.outputs.STATIC != 'true' ## unable to build static gtk/gui
+ shell: bash
+ run: |
+ opam exec -- make src OSTYPE=$OSTYPE UISTYLE=gtk3 STATIC=${{ steps.vars.outputs.STATIC }}
+ # stage
+ # * copy only main/first project binary
+ project_exe_stem=${PROJECT_EXES%% *}
+ cp "src/${project_exe_stem}${{ steps.vars.outputs.EXE_suffix }}" "${{ steps.vars.outputs.PKG_DIR }}/bin/${project_exe_stem}-gui${{ steps.vars.outputs.EXE_suffix }}"
+
+ - name: "Build WinOS text+gui hybrid"
+ if: runner.os == 'Windows' && steps.vars.outputs.STATIC != 'true' ## WinOS, non-static (unable to build static gtk/gui)
+ shell: bash
+ run: |
+ # create and stage text+gui hybrid for Windows
+ # * copy only main/first project binary
+ project_exe_stem=${PROJECT_EXES%% *}
+ # * clean/remove build artifact(s)
+ rm "src/${project_exe_stem}${{ steps.vars.outputs.EXE_suffix }}" ##.or.# opam exec -- make -C src clean #.or.# opam exec -- make clean
+ # * re-create (with hybrid text+gui UI)
+ opam exec -- make src OSTYPE=$OSTYPE UISTYLE=gtk3 UI_WINOS=hybrid STATIC=${{ steps.vars.outputs.STATIC }}
+ cp "src/${project_exe_stem}${{ steps.vars.outputs.EXE_suffix }}" "${{ steps.vars.outputs.PKG_DIR }}/bin/${project_exe_stem}-text+gui${{ steps.vars.outputs.EXE_suffix }}"
+
+ - uses: actions/upload-artifact@v3
+ with:
+ name: unison-${{ steps.vars.outputs.REF_SHAS }}.ocaml-${{ matrix.job.ocaml-version }}.${{ matrix.job.os }}
+ path: ${{ steps.vars.outputs.PKG_DIR }}/bin/*
+
+ - name: Copy user manual
+ continue-on-error: ${{ !(steps.vars.outputs.DEPLOY && matrix.job.publish) }}
+ uses: actions/download-artifact@v3
+ with:
+ name: unison-docs
+ path: '${{ steps.vars.outputs.PKG_DIR }}'
+
+ - name: Prepare package
+ # if: steps.vars.outputs.DEPLOY
+ shell: bash
+ run: |
+ ## package artifact(s)
+ PKG_DIR='${{ steps.vars.outputs.PKG_DIR }}'
+ # `strip` binaries
+ strip "${PKG_DIR}/bin"/*'${{ steps.vars.outputs.EXE_suffix }}'
+ # README and LICENSE
+ (shopt -s nullglob; for f in [R]'EADME'{,.*}; do cp $f "${PKG_DIR}"/ ; done)
+ (shopt -s nullglob; for f in [L]'ICENSE'{-*,}{,.*}; do cp $f "${PKG_DIR}"/ ; done)
+
+ - if: runner.os == 'Windows'
+ name: "Windows: Package gtk"
+ shell: bash
+ run: |
+ # [2023-03] Setting this PATH here (and it has to be right here) is
+ # a workaround for an unknown issue (most likely something with GHA)
+ # causing MinGW binutils not to be found (while other binutils
+ # pre-installed in the GHA images may be found instead), which in turn
+ # causes the DLL extracting functions to silently fail.
+ export PATH="/usr/${{ steps.vars.outputs.MinGW_ARCH }}-w64-mingw32/bin":${PATH}
+ ## package artifact(s)
+ PKG_DIR='${{ steps.vars.outputs.PKG_DIR }}'
+ # collect any needed dlls/libraries
+ # dlls
+ dll_refs() { eval "$(opam env)" ; eval "$(ocaml-env cygwin)" ; objdump -x "$@" | grep -Po "\S+[.]dll$" | xargs -I{} 2>/dev/null which "{}" | sort -u ; }
+ filtered_dll_refs() { list="$(dll_refs "$@" | grep -vF "$(cygpath ${WINDIR})" | perl -lape '$_ = qq/@{[sort @F]}/')" ; echo "$list" ; }
+ recursive_filtered_dll_refs() { list="$(filtered_dll_refs "$@")" ; n=0 ; while [ $n -lt $(echo "$list" | wc -l) ]; do n=$(echo "$list" | wc -l) ; list="$(filtered_dll_refs $list)" ; done ; echo "$list" ; }
+ IFS=$'\n' DLL_list=( "$(recursive_filtered_dll_refs "${PKG_DIR}"/bin/*)" )
+ for dll in ${DLL_list[@]} ; do cp "${dll}" "${PKG_DIR}"/bin ; done
+ TARGET_ARCH_ID='x86_64'; case '${{ matrix.job.ocaml-version }}' in *+mingw32*|*+msvc32*) TARGET_ARCH_ID='i686' ;; esac
+ # required gdk support files
+ mkdir "${PKG_DIR}"/lib
+ cp -r /usr/${TARGET_ARCH_ID}-w64-mingw32/sys-root/mingw/lib/gdk-pixbuf-2.0 "${PKG_DIR}"/lib/
+ # update loader.cache to point to local relative installation
+ mv "${PKG_DIR}"/lib/gdk-pixbuf-2.0/2.10.0/loaders.cache "${PKG_DIR}"/lib/gdk-pixbuf-2.0/2.10.0/loaders.cache.original
+ cat "${PKG_DIR}"/lib/gdk-pixbuf-2.0/2.10.0/loaders.cache.original | sed -E 's#([^"]*)(lib/gdk-pixbuf-2.0/2.10.0/loaders/[^"]*[.]dll)#../\2#' > "${PKG_DIR}"/lib/gdk-pixbuf-2.0/2.10.0/loaders.cache
+ rm "${PKG_DIR}"/lib/gdk-pixbuf-2.0/2.10.0/loaders.cache.original
+ # required icons
+ mkdir "${PKG_DIR}"/share
+ cp -rL /usr/share/icons "${PKG_DIR}"/share
+ # compile glib settings schema
+ mkdir -p "${PKG_DIR}"/share/glib-2.0
+ cp -r /usr/${TARGET_ARCH_ID}-w64-mingw32/sys-root/mingw/share/glib-2.0/schemas "${PKG_DIR}"/share/glib-2.0
+ glib-compile-schemas "${PKG_DIR}"/share/glib-2.0/schemas
+ # add gtk configuration
+ mkdir -p "${PKG_DIR}"/etc/gtk-3.0
+ printf "[Settings]\ngtk-button-images=true\ngtk-font-name=Segoe UI 9\n" > "${PKG_DIR}"/etc/gtk-3.0/settings.ini
+
+ - name: Package
+ shell: bash
+ run: cd '${{ steps.vars.outputs.PKG_DIR }}/' && ${{ steps.vars.outputs.COMPRESS_CMD }} '../${{ steps.vars.outputs.PKG_NAME }}' *
+
+ - uses: actions/upload-artifact@v3
+ if: matrix.job.publish
+ with:
+ name: unison-${{ steps.vars.outputs.REF_SHAS }}.ocaml-${{ matrix.job.ocaml-version }}.${{ matrix.job.os }}-publish
+ path: ${{ steps.vars.outputs.STAGING_DIR }}/${{ steps.vars.outputs.PKG_NAME }}
+
+ - name: Publish
+ if: steps.vars.outputs.DEPLOY && matrix.job.publish
+ uses: softprops/action-gh-release@v1
+ with:
+ files: |
+ ${{ steps.vars.outputs.STAGING_DIR }}/${{ steps.vars.outputs.PKG_NAME }}
+ env:
+ GITHUB_TOKEN: ${{ secrets.GITHUB_TOKEN }}
+
+ - if: runner.os == 'macOS'
+ name: "macOS: Build and package Unison.app"
+ id: macapp
+ run: |
+ opam exec -- make src UISTYLE=mac
+
+ # package
+ APP_NAME=Unison-${{ steps.vars.outputs.PKG_VER }}-macos.app.tar.gz
+ echo APP_NAME=${APP_NAME} >> $GITHUB_OUTPUT
+
+ tar czf ${APP_NAME} -C src/uimac/build/Default Unison.app
+
+ - if: runner.os == 'macOS'
+ name: "macOS: Upload Unison.app artifact"
+ uses: actions/upload-artifact@v3
+ with:
+ name: Unison-${{ steps.vars.outputs.REF_SHAS }}.ocaml-${{ matrix.job.ocaml-version }}.${{ matrix.job.os }}.app
+ path: ${{ steps.macapp.outputs.APP_NAME }}
+
+ - if: runner.os == 'macOS' && steps.vars.outputs.DEPLOY && matrix.job.publish
+ name: "macOS: Publish Unison.app"
+ uses: softprops/action-gh-release@v1
+ with:
+ files: ${{ steps.macapp.outputs.APP_NAME }}
+ env:
+ GITHUB_TOKEN: ${{ secrets.GITHUB_TOKEN }}
+
+
+ rpc_abicheck:
+ needs: build
+
+ strategy:
+ fail-fast: false
+ matrix:
+ # This list is intended to balance good enough coverage and
+ # limited resource usage.
+ job:
+ - { os: ubuntu-22.04 , ocaml-version: 5.0.x , ref: v2.53.0 }
+ - { os: ubuntu-22.04 , ocaml-version: 4.14.x , ref: v2.53.0 }
+ - { os: ubuntu-22.04 , ocaml-version: 4.14.x , ref: v2.52.1 }
+ - { os: ubuntu-22.04 , ocaml-version: 4.14.x , ref: v2.51.5 }
+ - { os: ubuntu-22.04 , ocaml-version: 4.08.x , ref: v2.51.5 }
+ - { os: ubuntu-22.04 , ocaml-version: 4.08.x , ref: v2.51.2 }
+ - { os: ubuntu-22.04 , ocaml-version: 4.08.x , ref: 2.48.4 }
+ - { os: windows-2019 , ocaml-version: ocaml-variants.4.14.0+mingw64c , ref: v2.53.0 }
+ - { os: windows-2019 , ocaml-version: ocaml-variants.4.14.0+mingw64c , ref: v2.52.1 }
+ - { os: windows-2019 , ocaml-version: ocaml-variants.4.08.1+mingw32c , ref: v2.51.5 }
+ - { os: windows-2019 , ocaml-version: ocaml-variants.4.08.1+mingw64c , ref: v2.51.2 }
+ - { os: windows-2019 , ocaml-version: ocaml-variants.4.08.1+mingw64c , ref: 2.48.4 }
+ - { os: macos-12 , ocaml-version: 4.14.x , ref: v2.53.0 }
+ - { os: macos-12 , ocaml-version: 4.14.x , ref: v2.52.1 }
+ - { os: macos-12 , ocaml-version: 4.08.x , ref: v2.51.5 }
+ - { os: macos-12 , ocaml-version: 4.08.x , ref: v2.51.2 }
+ - { os: macos-12 , ocaml-version: 4.08.x , ref: 2.48.4 }
+
+ runs-on: ${{ matrix.job.os }}
+
+ steps:
+ - if: contains(matrix.job.os, 'ubuntu')
+ run: sudo apt-get update
+
+ - name: Use OCaml ${{ matrix.job.ocaml-version }}
+ uses: ocaml/setup-ocaml@v2
+ with:
+ ocaml-compiler: "${{ matrix.job.ocaml-version }}"
+ opam-pin: false
+ opam-depext: false
+ # setup-ocaml can prepare the build environment from unison.opam
+ # We're not relying on that capability here, to make sure the builds
+ # also work without using unison.opam
+
+ - name: Prepare Cygwin environment (Windows)
+ if: runner.os == 'Windows'
+ shell: cmd
+ run: |
+ echo %CYGWIN_ROOT_BIN%>> %GITHUB_PATH%
+ echo %CYGWIN_ROOT_WRAPPERBIN%>> %GITHUB_PATH%
+ echo SHELLOPTS=igncr>> %GITHUB_ENV%
+
+ - name: Checkout HEAD to _new
+ uses: actions/checkout@v3
+ with:
+ path: _new
+
+ - name: "2.48: Patch tests in _new"
+ if: contains(matrix.job.ref, '2.48')
+ shell: bash
+ run: |
+ # 'atomic' was introduced in 2.51.0
+ cd _new && git apply - <<"EOF"
+ diff --git a/src/test.ml b/src/test.ml
+ index 60ccd05..45395e5 100644
+ --- a/src/test.ml
+ +++ b/src/test.ml
+ @@ -351,43 +351,6 @@ let test() =
+ )
+ done;
+
+ - (* Test that .git is treated atomically. *)
+ - runtest "Atomicity of certain directories 1" ["atomic = Name .git";
+ - "force = newer"] (fun() ->
+ - let orig = (Dir ["foo", Dir [".git", Dir ["a", File "foo";
+ - "b", File "bar";
+ - "c", File "baz"]]]) in
+ - put R1 orig;
+ - Unix.sleep 2; (* in case time granularity is coarse on this FS *)
+ - put R2 orig; sync();
+ - let expected = (Dir ["foo", Dir [".git", Dir ["a", File "modified on R1";
+ - "b", File "bar";
+ - "c", File "modified on R1"]]]) in
+ - put R2 (Dir ["foo", Dir [".git",
+ - Dir ["a", File "foo";
+ - "b", File "modified on R2";
+ - "c", File "modified on R2"]]]);
+ - Unix.sleep 2;
+ - put R1 expected;
+ - sync ();
+ - check "1" R2 expected;
+ - check "2" R1 expected
+ - );
+ -
+ - runtest "Atomicity of certain directories 2" ["atomic = Name .git"] (fun() ->
+ - let a = (Dir ["foo", Dir [".git", Dir ["a", File "foo";
+ - "b", File "bar";
+ - "c", File "baz";
+ - "d", File "quux"]]]) in
+ - let b = (Dir ["foo", Dir [".git", Dir ["a", File "foo";
+ - "b", File "bar";
+ - "c", File "baz";
+ - "e", File "quux"]]]) in
+ - put R1 a; put R2 b; sync();
+ - check "1" R1 a;
+ - check "2" R2 b
+ - );
+ -
+ (* Check for the bug reported by Ralf Lehmann *)
+ if not bothRootsLocal then
+ runtest "backups 1 (remote)" ["backup = Name *"] (fun() ->
+ EOF
+
+ - run: cd _new && opam exec -- make src UISTYLE=text OSTYPE=$OSTYPE
+ shell: bash
+
+ - name: Checkout ${{ matrix.job.ref }} to _prev
+ uses: actions/checkout@v3
+ with:
+ ref: "${{ matrix.job.ref }}"
+ path: _prev
+
+ - name: "2.48: Patch tests in _prev"
+ if: contains(matrix.job.ref, '2.48')
+ shell: bash
+ run: |
+ cd _prev && git apply - <<"EOF"
+ diff --git a/src/test.ml b/src/test.ml
+ index 6e8f943c..6c0bbded 100644
+ --- a/src/test.ml
+ +++ b/src/test.ml
+ @@ -324,7 +324,7 @@ let test() =
+
+ (* Check for the bug reported by Ralf Lehmann *)
+ if not bothRootsLocal then
+ - runtest "backups 1 (remote)" ["backup = Name *"] (fun() ->
+ + runtest "backups 1 (remote)" ["backup = Name *"; "fastcheck = false"] (fun() ->
+ put R1 (Dir []); put R2 (Dir []); sync();
+ debug (fun () -> Util.msg "First check\n");
+ checkmissing "1" BACKUP1;
+ @@ -370,7 +370,6 @@ let test() =
+ check "4" R2 (Dir ["x", File "foo"]);
+ );
+
+ - (raise (Util.Fatal "Skipping some tests -- remove me!\n") : unit);
+
+ if bothRootsLocal then
+ runtest "backups 1 (local)" ["backup = Name *"] (fun() ->
+ @@ -397,12 +397,12 @@ let test() =
+ check "1" R2 (Dir [(".bak.0.x", File "foo"); (".bak.0.d", Dir [("a", File "barr")])]);
+ );
+
+ - runtest "backups 2a" ["backup = Name *"; "backuplocation = local"] (fun() ->
+ + runtest "backups 2a" ["backup = Name *"; "backuplocation = local"; "fastcheck = false"] (fun() ->
+ put R1 (Dir []); put R2 (Dir []); sync();
+ (* Create a file and a directory *)
+ put R1 (Dir ["foo", File "1"]); sync();
+ check "1" R1 (Dir [("foo", File "1")]);
+ - check "2" R1 (Dir [("foo", File "1")]);
+ + check "2" R2 (Dir [("foo", File "1")]);
+ put R1 (Dir ["foo", File "2"]); sync();
+ check "3" R1 (Dir [("foo", File "2")]);
+ check "4" R2 (Dir [("foo", File "2"); (".bak.0.foo", File "1")]);
+ @@ -487,6 +486,77 @@ let test() =
+ );
+ end;
+
+ + if not bothRootsLocal then
+ + begin
+ + let localR, remoteR, localRaw =
+ + match r1 with
+ + | Common.Local, _ -> R1, R2, r1
+ + | _ -> R2, R1, r2
+ + in
+ +
+ + (* Test RPC function "fingerprintSubfile" *)
+ + runtest "RPC: transfer append" [] (fun () ->
+ + let prefixLen = 1024 * 1024 + 1 in
+ + let len = prefixLen + 31 in
+ + let contents = String.make len '.' in
+ + let fileName = "bigfile" in
+ + let prefixPath = Path.fromString fileName in
+ + let (workingDir, _) = Fspath.findWorkingDir (snd localRaw) prefixPath in
+ + let prefixName = Path.toString (Os.tempPath ~fresh:false workingDir prefixPath) in
+ + put remoteR (Dir [(fileName, File contents)]);
+ + put localR (Dir [(prefixName, File (String.sub contents 0 prefixLen))]);
+ + sync ();
+ + check "1" localR (Dir [(fileName, File contents)]);
+ + );
+ +
+ + (* Test RPC function "updateProps" *)
+ + runtest "RPC: update props" ["times = true"] (fun () ->
+ + let state = [("a", File "x")] in
+ + put remoteR (Dir state);
+ + put localR (Dir []);
+ + sync ();
+ + (* Having to sleep here is an unfortunate side-effect of the current
+ + Windows limitations-inspired time comparison algorithm which is
+ + designed to work on FAT filesystems (2-second granularity). *)
+ + Unix.sleep 2;
+ + put remoteR (Dir state);
+ + sync ();
+ + check "1" localR (Dir state);
+ + );
+ +
+ + (* Test RPC function "replaceArchive" *)
+ + runtest "RPC: replaceArchive" [] (fun () ->
+ + put localR (Dir [("n", File "to delete")]);
+ + put remoteR (Dir []);
+ + sync ();
+ + put remoteR (Dir []);
+ + sync ();
+ + check "1" localR (Dir []);
+ + );
+ +
+ + (* Test RPC functions "mkdir" and "setDirProp" *)
+ + runtest "RPC: mkdir, setDirProp" [] (fun () ->
+ + let state = [("subd", Dir [])] in
+ + put localR (Dir state);
+ + put remoteR (Dir []);
+ + sync ();
+ + check "1" remoteR (Dir state);
+ + );
+ +
+ + (* Test RPC function "setupTargetPaths" *)
+ + runtest "RPC: merge" ["merge = Name ma -> echo x> NEW"; "backupcurr = Name ma"; "fastcheck = false"] (fun () ->
+ + let result = match Sys.os_type with
+ + | "Win32" -> ("ma", File "x\r\n")
+ + | _ -> ("ma", File "x\n")
+ + in
+ + put localR (Dir [("ma", File "a")]);
+ + put remoteR (Dir [("ma", File "b")]);
+ + sync ();
+ + check "1" localR (Dir [result]);
+ + check "2" remoteR (Dir [result]);
+ + );
+ + end;
+ +
+ if !failures = 0 then
+ Util.msg "Success :-)\n"
+ else
+ EOF
+
+ - name: "2.48: Patch bugs in _prev"
+ if: contains(matrix.job.ref, '2.48')
+ shell: bash
+ run: |
+ cd _prev && git apply - <<"EOF"
+ diff --git a/src/bytearray_stubs.c b/src/bytearray_stubs.c
+ index 1ec18aef..664e3d96 100644
+ --- a/src/bytearray_stubs.c
+ +++ b/src/bytearray_stubs.c
+ @@ -9,7 +9,7 @@
+ CAMLprim value ml_marshal_to_bigarray(value v, value flags)
+ {
+ char *buf;
+ - long len;
+ + intnat len;
+ output_value_to_malloc(v, flags, &buf, &len);
+ return alloc_bigarray(BIGARRAY_UINT8 | BIGARRAY_C_LAYOUT | BIGARRAY_MANAGED,
+ 1, buf, &len);
+ EOF
+
+ - name: "2.48: Patch _prev for mingw compilers"
+ if: contains(matrix.job.ref, '2.48')
+ shell: bash
+ run: |
+ cd _prev && git apply --ignore-whitespace - <<"EOF"
+ diff --git a/src/Makefile.OCaml b/src/Makefile.OCaml
+ index 21610ce6..4d605bbd 100644
+ --- a/src/Makefile.OCaml
+ +++ b/src/Makefile.OCaml
+ @@ -104,8 +104,8 @@ CAMLFLAGS+=-I system/$(SYSTEM) -I lwt/$(SYSTEM)
+ ifeq ($(OSARCH),win32)
+ # Win32 system
+ EXEC_EXT=.exe
+ - OBJ_EXT=.obj
+ - OUTPUT_SEL=/Fo
+ + OBJ_EXT=.o
+ + OUTPUT_SEL=-o
+ CWD=.
+ # Fix suggested by Karl M, Jan 2009:
+ # "The new flexlink wrapper that OCaml 3.11 uses was gagging on the res
+ @@ -117,8 +117,6 @@ ifeq ($(OSARCH),win32)
+ COBJS+=system/system_win_stubs$(OBJ_EXT) lwt/lwt_unix_stubs$(OBJ_EXT)
+ WINOBJS=system/system_win.cmo
+ SYSTEM=win
+ - CLIBS+=-cclib "-link win32rc/unison.res" shell32.lib
+ - STATICLIBS+=-cclib "-link win32rc/unison.res" shell32.lib
+ buildexecutable::
+ @echo Building for Windows
+ else
+ diff --git a/src/lwt/lwt_unix_stubs.c b/src/lwt/lwt_unix_stubs.c
+ index aa85e5bb..3717ddc2 100644
+ --- a/src/lwt/lwt_unix_stubs.c
+ +++ b/src/lwt/lwt_unix_stubs.c
+ @@ -79,6 +79,7 @@ static value completionCallback;
+
+ static void invoke_completion_callback
+ (long id, long len, long errCode, long action) {
+ + CAMLparam0();
+ CAMLlocal2 (err, name);
+ value args[4];
+ err = Val_long(0);
+ EOF
+
+ - name: "2.48: Patch _prev for newer compilers/OS"
+ if: contains(matrix.job.ref, '2.48') && matrix.job.ocaml-version >= '4.03'
+ shell: bash
+ run: |
+ cd _prev && git apply - <<"EOF"
+ diff --git a/src/Makefile.OCaml b/src/Makefile.OCaml
+ index 21610ce6..75499079 100644
+ --- a/src/Makefile.OCaml
+ +++ b/src/Makefile.OCaml
+ @@ -95,7 +95,7 @@ buildexecutable::
+ ### Default parameters
+
+ # Generate backtrace information for exceptions
+ -CAMLFLAGS+=-g
+ +CAMLFLAGS+=-g -unsafe-string
+
+ INCLFLAGS=-I lwt -I ubase -I system
+ CAMLFLAGS+=$(INCLFLAGS)
+ @@ -187,7 +187,7 @@ endif
+ endif
+ endif
+
+ -MINOSXVERSION=10.5
+ +MINOSXVERSION=10.7
+ # XCODEFLAGS=-sdk macosx$(MINOSXVERSION)
+ ifeq ($(OSARCH),osx)
+ CAMLFLAGS+=-ccopt -mmacosx-version-min=$(MINOSXVERSION)
+ diff --git a/src/files.ml b/src/files.ml
+ index ba42ad57..5babf21e 100644
+ --- a/src/files.ml
+ +++ b/src/files.ml
+ @@ -722,7 +722,7 @@ let get_files_in_directory dir =
+ with End_of_file ->
+ dirh.System.closedir ()
+ end;
+ - Sort.list (<) !files
+ + List.sort String.compare !files
+
+ let ls dir pattern =
+ Util.convertUnixErrorsToTransient
+ diff --git a/src/recon.ml b/src/recon.ml
+ index 5ed358d7..0df2cfe4 100644
+ --- a/src/recon.ml
+ +++ b/src/recon.ml
+ @@ -651,8 +651,8 @@ let rec reconcile
+
+ (* Sorts the paths so that they will be displayed in order *)
+ let sortPaths pathUpdatesList =
+ - Sort.list
+ - (fun (p1, _) (p2, _) -> Path.compare p1 p2 <= 0)
+ + List.sort
+ + Path.compare
+ pathUpdatesList
+
+ let rec enterPath p1 p2 t =
+ diff --git a/src/system/system_generic.ml b/src/system/system_generic.ml
+ index 9230cdc1..140bd849 100755
+ --- a/src/system/system_generic.ml
+ +++ b/src/system/system_generic.ml
+ @@ -47,7 +47,7 @@ let open_out_gen = open_out_gen
+ let chmod = Unix.chmod
+ let chown = Unix.chown
+ let utimes = Unix.utimes
+ -let link = Unix.link
+ +let link x y = Unix.link x y
+ let openfile = Unix.openfile
+ let opendir f =
+ let h = Unix.opendir f in
+ EOF
+
+ - name: "2.51.0: Patch connection header in _prev"
+ if: contains(matrix.job.ref, '2.51.0')
+ shell: bash
+ run: |
+ # Connection header string was broken in 2.51.0
+ cd _prev && git apply - <<"EOF"
+ diff --git a/src/remote.ml b/src/remote.ml
+ index ddca0d77..7f819eab 100644
+ --- a/src/remote.ml
+ +++ b/src/remote.ml
+ @@ -920,7 +920,7 @@ let connectionHeader =
+ Scanf.sscanf Sys.ocaml_version "%d.%d.%d" (fun x y z -> (x,y,z)) in
+ let compiler =
+ if major < 4
+ - || major = 4 && minor <= 2
+ + || major = 4 && minor < 2
+ || major = 4 && minor = 2 && patchlevel <= 1
+ then "<= 4.01.1"
+ else ">= 4.01.2"
+ EOF
+
+ - name: "2.51.{2,3}: Patch bugs in _prev"
+ if: contains(matrix.job.ref, '2.51.2') || contains(matrix.job.ref, '2.51.3')
+ shell: bash
+ run: |
+ cd _prev && git apply - <<"EOF"
+ diff --git a/src/bytearray_stubs.c b/src/bytearray_stubs.c
+ index 2b29421a..2850f2d8 100644
+ --- a/src/bytearray_stubs.c
+ +++ b/src/bytearray_stubs.c
+ @@ -10,7 +10,7 @@
+ CAMLprim value ml_marshal_to_bigarray(value v, value flags)
+ {
+ char *buf;
+ - long len;
+ + intnat len;
+ output_value_to_malloc(v, flags, &buf, &len);
+ return alloc_bigarray(BIGARRAY_UINT8 | BIGARRAY_C_LAYOUT | BIGARRAY_MANAGED,
+ 1, buf, &len);
+ diff --git a/src/uicommon.ml b/src/uicommon.ml
+ index 9fa94cf5..65fc37a5 100644
+ --- a/src/uicommon.ml
+ +++ b/src/uicommon.ml
+ @@ -494,10 +494,11 @@ let promptForRoots getFirstRoot getSecondRoot =
+ (* ---- *)
+
+ let makeTempDir pattern =
+ - let ic = Unix.open_process_in (Printf.sprintf "(mktemp --tmpdir -d %s.XXXXXX || mktemp -d -t %s) 2>/dev/null" pattern pattern) in
+ - let path = input_line ic in
+ - ignore (Unix.close_process_in ic);
+ - path
+ + let path = Filename.temp_file pattern "" in
+ + let fspath = System.fspathFromString path in
+ + System.unlink fspath; (* Remove file created by [temp_file]... *)
+ + System.mkdir fspath 0o755; (* ... and create a dir instead. *)
+ + path ^ Filename.dir_sep
+
+ (* The first time we load preferences, we also read the command line
+ arguments; if we re-load prefs (because the user selected a new profile)
+ EOF
+
+ - name: "2.51.2: Patch _prev for mingw compilers"
+ if: contains(matrix.job.ref, '2.51.2')
+ shell: bash
+ run: |
+ cd _prev && git apply - <<"EOF"
+ diff --git a/src/Makefile.OCaml b/src/Makefile.OCaml
+ index 7cefa2ec..95b1bec4 100644
+ --- a/src/Makefile.OCaml
+ +++ b/src/Makefile.OCaml
+ @@ -107,8 +107,8 @@ CAMLFLAGS+=-I system/$(SYSTEM) -I lwt/$(SYSTEM)
+ ifeq ($(OSARCH),win32)
+ # Win32 system
+ EXEC_EXT=.exe
+ - OBJ_EXT=.obj
+ - OUTPUT_SEL=/Fo
+ + OBJ_EXT=.o
+ + OUTPUT_SEL=-o
+ CWD=.
+ # Fix suggested by Karl M, Jan 2009:
+ # "The new flexlink wrapper that OCaml 3.11 uses was gagging on the res
+ @@ -120,8 +120,6 @@ ifeq ($(OSARCH),win32)
+ COBJS+=system/system_win_stubs$(OBJ_EXT) lwt/lwt_unix_stubs$(OBJ_EXT)
+ WINOBJS=system/system_win.cmo
+ SYSTEM=win
+ - CLIBS+=-cclib "-link win32rc/unison.res" shell32.lib
+ - STATICLIBS+=-cclib "-link win32rc/unison.res" shell32.lib
+ buildexecutable::
+ @echo Building for Windows
+ else
+ EOF
+
+ - name: "2.51.2: Patch _prev for newer compilers/OS"
+ if: contains(matrix.job.ref, '2.51.2')
+ shell: bash
+ run: |
+ cd _prev && git apply - <<"EOF"
+ diff --git a/src/Makefile.OCaml b/src/Makefile.OCaml
+ index 7cefa2ec..ffc3ab9e 100644
+ --- a/src/Makefile.OCaml
+ +++ b/src/Makefile.OCaml
+ @@ -180,7 +180,7 @@ else
+ buildexecutable:: $(NAME)$(EXEC_EXT)
+ endif
+
+ -MINOSXVERSION=10.5
+ +MINOSXVERSION=10.7
+ # XCODEFLAGS=-sdk macosx$(MINOSXVERSION)
+ ifeq ($(OSARCH),osx)
+ CAMLFLAGS+=-ccopt -mmacosx-version-min=$(MINOSXVERSION)
+ diff --git a/src/files.ml b/src/files.ml
+ index 5ff18810..1d1fbcc6 100644
+ --- a/src/files.ml
+ +++ b/src/files.ml
+ @@ -734,7 +734,7 @@ let get_files_in_directory dir =
+ with End_of_file ->
+ dirh.System.closedir ()
+ end;
+ - Sort.list (<) !files
+ + List.sort String.compare !files
+
+ let ls dir pattern =
+ Util.convertUnixErrorsToTransient
+ diff --git a/src/recon.ml b/src/recon.ml
+ index 2c619bb8..2412c18e 100644
+ --- a/src/recon.ml
+ +++ b/src/recon.ml
+ @@ -661,8 +661,8 @@ let rec reconcile
+
+ (* Sorts the paths so that they will be displayed in order *)
+ let sortPaths pathUpdatesList =
+ - Sort.list
+ - (fun (p1, _) (p2, _) -> Path.compare p1 p2 <= 0)
+ + List.sort
+ + Path.compare
+ pathUpdatesList
+
+ let rec enterPath p1 p2 t =
+ diff --git a/src/system/system_generic.ml b/src/system/system_generic.ml
+ index 453027d0..290851e1 100755
+ --- a/src/system/system_generic.ml
+ +++ b/src/system/system_generic.ml
+ @@ -47,7 +47,7 @@ let open_out_gen = open_out_gen
+ let chmod = Unix.chmod
+ let chown = Unix.chown
+ let utimes = Unix.utimes
+ -let link = Unix.link
+ +let link x y = Unix.link x y
+ let openfile = Unix.openfile
+ let opendir f =
+ let h = Unix.opendir f in
+ EOF
+
+ - name: "2.51.0 - 2.52.1: Patch tests in _prev"
+ if: contains(matrix.job.ref, '2.51') || matrix.job.ref == 'v2.52.0' || matrix.job.ref == 'v2.52.1'
+ shell: bash
+ run: |
+ cd _prev && git apply - <<"EOF"
+ diff --git a/src/test.ml b/src/test.ml
+ index 3d480409..60ed014d 100644
+ --- a/src/test.ml
+ +++ b/src/test.ml
+ @@ -542,6 +542,77 @@ let test() =
+ *)
+ end;
+
+ + if not bothRootsLocal then
+ + begin
+ + let localR, remoteR, localRaw =
+ + match r1 with
+ + | Common.Local, _ -> R1, R2, r1
+ + | _ -> R2, R1, r2
+ + in
+ +
+ + (* Test RPC function "fingerprintSubfile" *)
+ + runtest "RPC: transfer append" [] (fun () ->
+ + let prefixLen = 1024 * 1024 + 1 in
+ + let len = prefixLen + 31 in
+ + let contents = String.make len '.' in
+ + let fileName = "bigfile" in
+ + let prefixPath = Path.fromString fileName in
+ + let (workingDir, _) = Fspath.findWorkingDir (snd localRaw) prefixPath in
+ + let prefixName = Path.toString (Os.tempPath ~fresh:false workingDir prefixPath) in
+ + put remoteR (Dir [(fileName, File contents)]);
+ + put localR (Dir [(prefixName, File (String.sub contents 0 prefixLen))]);
+ + sync ();
+ + check "1" localR (Dir [(fileName, File contents)]);
+ + );
+ +
+ + (* Test RPC function "updateProps" *)
+ + runtest "RPC: update props" ["times = true"] (fun () ->
+ + let state = [("a", File "x")] in
+ + put remoteR (Dir state);
+ + put localR (Dir []);
+ + sync ();
+ + (* Having to sleep here is an unfortunate side-effect of the current
+ + Windows limitations-inspired time comparison algorithm which is
+ + designed to work on FAT filesystems (2-second granularity). *)
+ + Unix.sleep 2;
+ + put remoteR (Dir state);
+ + sync ();
+ + check "1" localR (Dir state);
+ + );
+ +
+ + (* Test RPC function "replaceArchive" *)
+ + runtest "RPC: replaceArchive" [] (fun () ->
+ + put localR (Dir [("n", File "to delete")]);
+ + put remoteR (Dir []);
+ + sync ();
+ + put remoteR (Dir []);
+ + sync ();
+ + check "1" localR (Dir []);
+ + );
+ +
+ + (* Test RPC functions "mkdir" and "setDirProp" *)
+ + runtest "RPC: mkdir, setDirProp" [] (fun () ->
+ + let state = [("subd", Dir [])] in
+ + put localR (Dir state);
+ + put remoteR (Dir []);
+ + sync ();
+ + check "1" remoteR (Dir state);
+ + );
+ +
+ + (* Test RPC function "setupTargetPaths" *)
+ + runtest "RPC: merge" ["merge = Name ma -> echo x> NEW"; "backupcurr = Name ma"] (fun () ->
+ + let result = match Sys.os_type with
+ + | "Win32" -> ("ma", File "x\r\n")
+ + | _ -> ("ma", File "x\n")
+ + in
+ + put localR (Dir [("ma", File "a")]);
+ + put remoteR (Dir [("ma", File "b")]);
+ + sync ();
+ + check "1" localR (Dir [result]);
+ + check "2" remoteR (Dir [result]);
+ + );
+ + end;
+ +
+ if !failures = 0 then
+ Util.msg "Success :-)\n"
+ else
+ EOF
+
+ - name: "2.52.0: Patch _prev for newer compilers"
+ if: contains(matrix.job.ref, '2.52.0')
+ shell: bash
+ run: |
+ cd _prev && git apply - <<"EOF"
+ diff --git a/src/system/system_win_stubs.c b/src/system/system_win_stubs.c
+ index 50ea663f..57940d98 100644
+ --- a/src/system/system_win_stubs.c
+ +++ b/src/system/system_win_stubs.c
+ @@ -373,7 +373,7 @@ typedef enum _FILE_INFORMATION_CLASS {
+ #include <caml/version.h> /* Available since OCaml 4.02 */
+ #endif
+
+ -#if !defined(OCAML_VERSION) || OCAML_VERSION < 40300
+ +#if !defined(OCAML_VERSION) || OCAML_VERSION < 40300 || OCAML_VERSION >= 41400
+
+ typedef struct _REPARSE_DATA_BUFFER {
+ ULONG ReparseTag;
+ EOF
+
+ - run: cd _prev && opam exec -- make src UISTYLE=text OSTYPE=$OSTYPE
+ shell: bash
+
+ # IMPORTANT! These tests do not exercise the entire RPC API. Yet, they
+ # should work fine as a smoke test.
+
+ - name: Run self-tests over RPC - new client to prev server
+ env:
+ UNISON: test1
+ shell: bash
+ run: |
+ # Separate backup dir must be set for server instance so that the central
+ # backup location of both instances doesn't overlap
+ UNISONBACKUPDIR=./_prev/src/testbak_s _prev/src/unison -socket 55443 &
+ sleep 1 # Wait for the server to be fully started
+ _new/src/unison -ui text -selftest testr_c socket://127.0.0.1:55443/testr_s -killserver
+
+ - name: "2.48: Run self-tests over RPC - prev client to new server"
+ if: contains(matrix.job.ref, '2.48')
+ env:
+ UNISON: test2
+ shell: bash
+ run: |
+ cp _new/src/unison _new/src/unison-2.48
+ # Separate backup dir must be set for server instance so that the central
+ # backup location of both instances doesn't overlap
+ UNISONBACKUPDIR=./_new/src/testbak_s _new/src/unison-2.48 -socket 55443 &
+ sleep 1 # Wait for the server to be fully started
+ _prev/src/unison -ui text -selftest testr_c socket://127.0.0.1:55443/testr_s -killserver
+
+ - name: Run self-tests over RPC - prev client to new server
+ if: ${{ !contains(matrix.job.ref, '2.48') }}
+ env:
+ UNISON: test2
+ shell: bash
+ run: |
+ # Separate backup dir must be set for server instance so that the central
+ # backup location of both instances doesn't overlap
+ UNISONBACKUPDIR=./_new/src/testbak_s _new/src/unison -socket 55443 &
+ sleep 1 # Wait for the server to be fully started
+ _prev/src/unison -ui text -selftest testr_c socket://127.0.0.1:55443/testr_s -killserver
+
+
+ ## We know the code is ok with various ocaml versions, so this is
+ ## just checking the dune build process. Therefore build each OS
+ ## family just once. Pick a different ocaml version because that's
+ ## better coverage without adding a build.
+ opam_dune_build:
+ strategy:
+ fail-fast: false
+ matrix:
+ job:
+ - { os: ubuntu-22.04 , ocaml-compiler: 4.12.x }
+ - { os: macos-11 , ocaml-compiler: 4.11.x }
+
+ runs-on: ${{ matrix.job.os }}
+
+ steps:
+ - if: contains(matrix.job.os, 'ubuntu')
+ run: sudo apt-get update
+
+ - name: Checkout code
+ uses: actions/checkout@v3
+
+ - name: Use OCaml ${{ matrix.job.ocaml-compiler }}
+ uses: ocaml/setup-ocaml@v2
+ with:
+ ocaml-compiler: "${{ matrix.job.ocaml-compiler }}"
+
+ - run: opam install . --deps-only
+
+ - run: opam exec -- dune build && cp -L ./_build/install/default/bin/unison* ./src/
+
+# - run: opam exec -- make test
+
+ bytecode_build:
+ strategy:
+ fail-fast: false
+ matrix:
+ job:
+ - { os: ubuntu-22.04 , ocaml-compiler: 4.14.x }
+
+ runs-on: ${{ matrix.job.os }}
+
+ steps:
+ - if: contains(matrix.job.os, 'ubuntu')
+ run: sudo apt-get update
+
+ - name: Checkout code
+ uses: actions/checkout@v3
+
+ - name: Use OCaml ${{ matrix.job.ocaml-compiler }}
+ uses: ocaml/setup-ocaml@v2
+ with:
+ ocaml-compiler: "${{ matrix.job.ocaml-compiler }}"
+ opam-pin: false
+ opam-depext: false
+
+ - run: opam exec -- make src UISTYLE=text NATIVE=false
+
+ - run: opam exec -- make test
+
+
+ build_compat:
+ if: ${{ !cancelled() }} # Don't fail if 'docs' failed
+ needs: docs
+
+ strategy:
+ fail-fast: false
+ matrix:
+ job:
+ - { ocaml-version: 4.14.x, publish: true, fnsuffix: -ubuntu-x86_64 }
+ - { ocaml-version: "ocaml-variants.4.14.1+options,ocaml-option-musl,ocaml-option-static,ocaml-option-flambda", publish: true, fnsuffix: -ubuntu-x86_64-static }
+ - { ocaml-version: 4.13.x }
+ - { ocaml-version: 4.12.x }
+ - { ocaml-version: 4.11.x }
+ - { ocaml-version: 4.10.x }
+ - { ocaml-version: 4.09.x }
+ - { ocaml-version: 4.08.x, publish: true, fnsuffix: +ocaml4.08-ubuntu-x86_64 }
+
+ runs-on: ubuntu-latest
+ container: ubuntu:16.04
+
+ steps:
+ - name: Set up the OS
+ run: |
+ apt-get update
+ apt-get install --assume-yes git make gcc patch wget bzip2 unzip musl-tools
+
+ - name: Checkout code
+ uses: actions/checkout@v3
+
+ - name: Use OCaml ${{ matrix.job.ocaml-version }}
+ uses: ocaml/setup-ocaml@v2
+ with:
+ ocaml-compiler: ${{ matrix.job.ocaml-version }}
+ opam-disable-sandboxing: true
+ opam-pin: false
+ opam-depext: false
+
+ - name: Build text UI
+ run: |
+ opam exec -- make src UISTYLE=text STATIC=${{ contains(matrix.job.ocaml-version, '-musl') }}
+ mkdir -p pkg/bin
+ cp src/unison pkg/bin/
+ cp src/unison-fsmonitor pkg/bin/
+
+ - name: Run local tests
+ run: opam exec -- make test
+
+ - name: Run remote tests
+ run: |
+ mkdir localsocket
+ chmod 700 localsocket
+ # Separate backup dir must be set for server instance so that the central
+ # backup location of both instances doesn't overlap
+ UNISONBACKUPDIR=./src/testbak4 ./src/unison -socket ./localsocket/test.sock &
+ sleep 1 # Wait for the server to be fully started
+ test -S ./localsocket/test.sock
+ ./src/unison -ui text -selftest testr3 socket://{./localsocket/test.sock}/testr4 -killserver
+
+ - name: Build GUI
+ if: ${{ !contains(matrix.job.ocaml-version, '-musl') }}
+ run: |
+ opam depext --install --verbose --yes lablgtk3 && opam install ocamlfind
+ opam exec -- make src UISTYLE=gtk3
+ cp src/unison pkg/bin/unison-gui
+
+ - name: Initialize packaging variables
+ id: vars
+ run: |
+ REF_SHAS=$(echo '${{ github.sha }}' | awk '{ print substr($0, 1, 8) }')
+ unset REF_TAG ; case "${GITHUB_REF}" in refs/tags/*) REF_TAG="${GITHUB_REF#refs/tags/}" ;; esac;
+ PKG_VER="${REF_TAG:-git_$REF_SHAS}"
+ PKG_VER="${PKG_VER#v}"
+ echo PKG_NAME="${PROJECT_NAME}-${PKG_VER}${{ matrix.job.fnsuffix }}.tar.gz" >> $GITHUB_OUTPUT
+ echo REF_SHAS=${REF_SHAS} >> $GITHUB_OUTPUT
+
+ - uses: actions/upload-artifact@v3
+ with:
+ name: unison-${{ steps.vars.outputs.REF_SHAS }}.ocaml-${{ matrix.job.ocaml-version }}.ubuntu.x86_64
+ path: pkg/bin/*
+
+ - name: Copy user manual
+ if: matrix.job.publish
+ continue-on-error: ${{ !(github.ref_type == 'tag' && startsWith(github.ref_name, 'v') && matrix.job.publish) }}
+ uses: actions/download-artifact@v3
+ with:
+ name: unison-docs
+ path: pkg
+
+ - name: Prepare package
+ if: matrix.job.publish
+ run: |
+ strip pkg/bin/*
+ cp README* pkg/
+ cp LICENSE* pkg/
+
+ - name: Package
+ if: matrix.job.publish
+ run: cd pkg && tar czf '${{ steps.vars.outputs.PKG_NAME }}' *
+
+ - uses: actions/upload-artifact@v3
+ if: matrix.job.publish
+ with:
+ name: ${{ steps.vars.outputs.PKG_NAME }}.ocaml-${{ matrix.job.ocaml-version }}.ubuntu_compat-publish
+ path: pkg/${{ steps.vars.outputs.PKG_NAME }}
+
+ - name: Publish
+ if: github.ref_type == 'tag' && startsWith(github.ref_name, 'v') && matrix.job.publish
+ uses: softprops/action-gh-release@v1
+ with:
+ files: pkg/${{ steps.vars.outputs.PKG_NAME }}
+ env:
+ GITHUB_TOKEN: ${{ secrets.GITHUB_TOKEN }}
diff --git a/.github/workflows/CICD.yml b/.github/workflows/CICD.yml
deleted file mode 100644
index f79fe1c..0000000
--- a/.github/workflows/CICD.yml
+++ /dev/null
@@ -1,281 +0,0 @@
-name: CICD
-
-env:
- PROJECT_NAME: unison
- PROJECT_DESC: "`unison` file synchronizer"
- PROJECT_EXES: "unison unison-fsmonitor"
-
-on:
- - pull_request
- - push
-
-jobs:
- build:
- strategy:
- fail-fast: false
- matrix:
- job:
- - { os: macos-10.15 , ocaml-version: 4.12.0 }
- - { os: macos-10.15 , ocaml-version: 4.11.2 }
- - { os: macos-10.15 , ocaml-version: 4.10.2 }
- - { os: macos-10.15 , ocaml-version: 4.09.1 }
- - { os: macos-10.15 , ocaml-version: 4.08.1 }
- - { os: macos-10.15 , ocaml-version: 4.07.1 }
- - { os: macos-10.15 , ocaml-version: 4.06.1 }
- - { os: macos-10.15 , ocaml-version: 4.05.0 }
- - { os: macos-10.15 , ocaml-version: 4.04.2 }
- - { os: macos-10.15 , ocaml-version: 4.03.0 }
- - { os: macos-10.15 , ocaml-version: 4.02.3 }
- - { os: macos-10.15 , ocaml-version: 4.01.0 }
- - { os: ubuntu-18.04 , ocaml-version: 4.12.0 }
- - { os: ubuntu-18.04 , ocaml-version: 4.11.2 }
- - { os: ubuntu-18.04 , ocaml-version: 4.10.2 }
- - { os: ubuntu-18.04 , ocaml-version: 4.10.0+musl+static+flambda }
- - { os: ubuntu-18.04 , ocaml-version: 4.09.1 }
- - { os: ubuntu-18.04 , ocaml-version: 4.08.1 }
- - { os: ubuntu-18.04 , ocaml-version: 4.07.1 }
- - { os: ubuntu-18.04 , ocaml-version: 4.06.1 }
- - { os: ubuntu-18.04 , ocaml-version: 4.05.0 }
- - { os: ubuntu-18.04 , ocaml-version: 4.04.2 }
- - { os: ubuntu-18.04 , ocaml-version: 4.03.0 }
- - { os: ubuntu-18.04 , ocaml-version: 4.02.3 }
- - { os: ubuntu-18.04 , ocaml-version: 4.01.0 }
- - { os: windows-latest , ocaml-version: 4.12.0+mingw64c }
- - { os: windows-latest , ocaml-version: 4.11.2+mingw64c }
- - { os: windows-latest , ocaml-version: 4.10.2+mingw64c }
- - { os: windows-latest , ocaml-version: 4.10.2+mingw32c }
- - { os: windows-latest , ocaml-version: 4.09.1+mingw64c }
- - { os: windows-latest , ocaml-version: 4.08.1+mingw64c }
- - { os: windows-latest , ocaml-version: 4.07.1+mingw64c }
- - { os: windows-latest , ocaml-version: 4.06.1+mingw64c }
- - { os: windows-latest , ocaml-version: 4.06.1+mingw32c }
- - { os: windows-latest , ocaml-version: 4.05.0+mingw64c }
- - { os: windows-latest , ocaml-version: 4.04.2+mingw32c }
- - { os: windows-latest , ocaml-version: 4.03.0+mingw32c }
- - { os: windows-latest , ocaml-version: 4.02.3+mingw64c }
- - { os: windows-latest , ocaml-version: 4.02.3+mingw32c }
- - { os: windows-latest , ocaml-version: 4.01.0+mingw32c }
-
- runs-on: ${{ matrix.job.os }}
-
- steps:
- - name: Checkout code
- uses: actions/checkout@v2
-
- - name: Initialize workflow variables
- id: vars
- shell: bash
- run: |
- outputs() { for var in "$@" ; do echo steps.vars.outputs.${var}="${!var}"; echo ::set-output name=${var}::${!var}; done; }
- # normalize to pre-compiled ocaml compiler variants for windows/Cygwin (decreases OCaml install time by 50%)
- case '${{ matrix.job.ocaml-version }}' in
- *+*) OCAML_COMPILER='ocaml-variants.${{ matrix.job.ocaml-version }}' ;;
- *) OCAML_COMPILER='ocaml-base-compiler.${{ matrix.job.ocaml-version }}' ;;
- esac
- OCAML_VARIANT='${{ matrix.job.ocaml-version }}'
- outputs OCAML_VARIANT OCAML_COMPILER
- # architecture/platform vars
- EXE_suffix='' ; case '${{ matrix.job.os }}' in windows-*) EXE_suffix=".exe" ;; esac
- MinGW_ARCH='x86_64' ; case '${{ matrix.job.ocaml-version }}' in *+mingw32*) MinGW_ARCH='i686' ;; *+mingw64*) MinGW_ARCH='x86_64' ;; esac
- MSVC_ARCH='' ; case '${{ matrix.job.ocaml-version }}' in *+msvc32*) MSVC_ARCH='x86' ;; *+msvc64*) MSVC_ARCH='x64' ;; esac
- STATIC='false' ; case '${{ matrix.job.ocaml-version }}' in *+musl*) STATIC='true' ;; esac
- outputs EXE_suffix MinGW_ARCH MSVC_ARCH STATIC
- case '${{ matrix.job.os }}' in macos-*) echo "MACOSX_DEPLOYMENT_TARGET=10.6" >> $GITHUB_ENV ;; esac
- # staging environment
- STAGING_DIR='_staging'
- outputs STAGING_DIR
- # parse commit reference info
- echo GITHUB_REF=${GITHUB_REF}
- echo GITHUB_SHA=${GITHUB_SHA}
- REF_NAME="${GITHUB_REF#refs/*/}"
- unset REF_BRANCH ; case "${GITHUB_REF}" in refs/heads/*) REF_BRANCH="${GITHUB_REF#refs/heads/}" ;; esac;
- unset REF_TAG ; case "${GITHUB_REF}" in refs/tags/*) REF_TAG="${GITHUB_REF#refs/tags/}" ;; esac;
- REF_SHAS="${GITHUB_SHA:0:8}"
- outputs REF_BRANCH REF_NAME REF_SHAS REF_TAG
- # deployable tag? (ie, leading "vM" or "M"; M == version number)
- unset DEPLOY ; if [[ $REF_TAG =~ ^[vV]?[0-9].* ]]; then DEPLOY='true' ; fi
- outputs DEPLOY
- # package name
- PKG_suffix='.tar.gz' ; case '${{ matrix.job.os }}' in windows-*) PKG_suffix='.zip' ;; esac;
- PKG_OS='linux' ; case '${{ matrix.job.os }}' in macos-*) PKG_OS='${{ matrix.job.os }}' ;; windows-*) PKG_OS='windows' ;; esac;
- PKG_STATIC='' ; case '${{ matrix.job.ocaml-version }}' in *+static*) PKG_STATIC='.static' ;; esac;
- PKG_ARCH='x86_64' ; case '${{ matrix.job.ocaml-version }}' in *+32bit* | *+mingw32*) PKG_ARCH='i386' ;; esac;
- PKG_VER="${REF_TAG:-$REF_SHAS}"
- PKG_BASENAME="${PROJECT_NAME}-${PKG_VER}+ocaml-${OCAML_VARIANT/%+*/}+${PKG_ARCH}.${PKG_OS}${PKG_STATIC}"
- PKG_NAME="${PKG_BASENAME}${PKG_suffix}"
- PKG_DIR="${STAGING_DIR}/${PKG_BASENAME}"
- outputs PKG_VER PKG_BASENAME PKG_DIR PKG_NAME PKG_OS PKG_suffix
-
- - name: Create/configure any needed build/workspace
- shell: bash
- run: |
- # create build/work space
- mkdir -p '${{ steps.vars.outputs.STAGING_DIR }}'
- mkdir -p '${{ steps.vars.outputs.PKG_DIR }}'
- mkdir -p '${{ steps.vars.outputs.PKG_DIR }}'/bin
-
- - name: Select Xcode version 11.7 for OCaml 4.05 (macOS)
- if: runner.os == 'macOS' && matrix.job.ocaml-version == '4.05.0'
- ## Xcode >= 12 breaks building lablgtk with OCaml 4.05 (a bug fixed in OCaml >= 4.06)
- run: |
- sudo xcode-select -s "/Applications/Xcode_11.7.app"
-
- - name: Enable/config MSVC environment (if/when needed)
- uses: ilammy/msvc-dev-cmd@v1
- with:
- arch: "${{ steps.vars.outputs.MSVC_ARCH }}"
- if: contains(matrix.job.ocaml-version, '+msvc')
-
- - name: Use OCaml ${{ matrix.job.ocaml-version }}
- uses: ocaml/setup-ocaml@v2
- with:
- ocaml-compiler: "${{ steps.vars.outputs.OCAML_COMPILER }}"
- opam-pin: false
- opam-depext: false
- # setup-ocaml can prepare the build environment from unison.opam
- # We're not relying on that capability here, to make sure the builds
- # also work without using unison.opam
-
- ## note: at this point, after OCaml installation, windows platforms will use Cygwin bash as the default
- ## ... Cygwin bash cannot handle shell scripts containing CRLF EOLs (which are what is generated by GHA on windows platforms)
- ## ... so, "igncr" must be added to SHELLOPTS
-
- - name: Prepare Cygwin environment (Windows)
- if: runner.os == 'Windows'
- shell: cmd
- run: |
- echo %CYGWIN_ROOT_BIN%>> %GITHUB_PATH%
- echo %CYGWIN_ROOT_WRAPPERBIN%>> %GITHUB_PATH%
- echo SHELLOPTS=igncr>> %GITHUB_ENV%
-
- - name: lablgtk install
- ## [2020-09] non-working/unavailable for MSVC or musl OCaml variants ; also, non-working for 32bit OCaml variant (see [GH:garrigue/lablgtk#64](https://github.com/garrigue/lablgtk/issues/64))
- if: ${{ ! ( contains(matrix.job.ocaml-version, '+msvc') || contains(matrix.job.ocaml-version, '+musl') || contains(matrix.job.ocaml-version, '+32bit') ) }}
- run: opam depext --install --verbose --yes lablgtk
-
- - shell: bash
- run: |
- opam exec -- make src OSTYPE=$OSTYPE UISTYLE=text STATIC=${{ steps.vars.outputs.STATIC }}
- # stage
- # * notes: darwin/macos doesn't build `unison-fsmonitor`
- for file in ${PROJECT_EXES} ; do
- if [ -f "src/${file}${{ steps.vars.outputs.EXE_suffix }}" ]; then
- cp "src/${file}${{ steps.vars.outputs.EXE_suffix }}" '${{ steps.vars.outputs.PKG_DIR }}/bin'
- echo "'src/${file}${{ steps.vars.outputs.EXE_suffix }}' copied to '${{ steps.vars.outputs.PKG_DIR }}/bin'"
- fi
- done
-
- - run: opam exec -- make test
-
- - if: steps.vars.outputs.STATIC != 'true' ## unable to build static gtk for linux or windows/Cygwin MinGW platforms
- shell: bash
- run: |
- opam exec -- make src OSTYPE=$OSTYPE UISTYLE=gtk2 STATIC=${{ steps.vars.outputs.STATIC }}
- # stage
- # * copy only main/first project binary
- project_exe_stem=${PROJECT_EXES%% *}
- cp "src/${project_exe_stem}${{ steps.vars.outputs.EXE_suffix }}" "${{ steps.vars.outputs.PKG_DIR }}/bin/${project_exe_stem}-gtk2${{ steps.vars.outputs.EXE_suffix }}"
-
- - uses: actions/upload-artifact@v2
- with:
- name: unison-${{ steps.vars.outputs.REF_SHAS }}.ocaml-${{ matrix.job.ocaml-version }}.${{ matrix.job.os }}
- path: ${{ steps.vars.outputs.PKG_DIR }}/bin/*
-
- - name: Package
- # if: steps.vars.outputs.DEPLOY
- shell: bash
- run: |
- ## package artifact(s)
- PKG_DIR='${{ steps.vars.outputs.PKG_DIR }}'
- # `strip` binaries
- strip "${PKG_DIR}/bin"/*'${{ steps.vars.outputs.EXE_suffix }}'
- # README and LICENSE
- (shopt -s nullglob; for f in [R]'EADME'{,.*}; do cp $f "${PKG_DIR}"/ ; done)
- (shopt -s nullglob; for f in [L]'ICENSE'{-*,}{,.*}; do cp $f "${PKG_DIR}"/ ; done)
- # collect any needed dlls/libraries
- case '${{ matrix.job.os }}' in
- windows-*)
- # dlls
- dll_refs() { eval "$(opam env)" ; eval "$(ocaml-env cygwin)" ; objdump -x "$@" | grep -Po "\S+[.]dll$" | xargs -I{} 2>/dev/null which "{}" | sort -u ; }
- filtered_dll_refs() { list="$(dll_refs "$@" | grep -vF "$(cygpath ${WINDIR})" | perl -lape '$_ = qq/@{[sort @F]}/')" ; echo "$list" ; }
- recursive_filtered_dll_refs() { list="$(filtered_dll_refs "$@")" ; n=0 ; while [ $n -lt $(echo "$list" | wc -l) ]; do n=$(echo "$list" | wc -l) ; list="$(filtered_dll_refs $list)" ; done ; echo "$list" ; }
- IFS=$'\n' DLL_list=( "$(recursive_filtered_dll_refs "${PKG_DIR}"/bin/*)" )
- for dll in ${DLL_list[@]} ; do cp "${dll}" "${PKG_DIR}"/bin ; done
- TARGET_ARCH_ID='x86_64'; case '${{ matrix.job.ocaml-version }}' in *+mingw32*|*+msvc32*) TARGET_ARCH_ID='i686' ;; esac
- # required gdk support files
- mkdir "${PKG_DIR}"/lib
- cp -r /usr/${TARGET_ARCH_ID}-w64-mingw32/sys-root/mingw/lib/gdk-pixbuf-2.0 "${PKG_DIR}"/lib/
- # update loader.cache to point to local relative installation
- mv "${PKG_DIR}"/lib/gdk-pixbuf-2.0/2.10.0/loaders.cache "${PKG_DIR}"/lib/gdk-pixbuf-2.0/2.10.0/loaders.cache.original
- cat "${PKG_DIR}"/lib/gdk-pixbuf-2.0/2.10.0/loaders.cache.original | sed -E 's#([^"]*)(lib/gdk-pixbuf-2.0/2.10.0/loaders/[^"]*[.]dll)#../\2#' > "${PKG_DIR}"/lib/gdk-pixbuf-2.0/2.10.0/loaders.cache
- rm "${PKG_DIR}"/lib/gdk-pixbuf-2.0/2.10.0/loaders.cache.original
- ;;
- esac
- # create compressed package
- pushd "${PKG_DIR}"/ >/dev/null
- case '${{ matrix.job.os }}' in
- windows-*) 7z -y a '../${{ steps.vars.outputs.PKG_NAME }}' * | tail -2 ;;
- *) tar czf '../${{ steps.vars.outputs.PKG_NAME }}' * ;;
- esac
- popd >/dev/null
-
- - name: Publish
- if: steps.vars.outputs.DEPLOY
- uses: softprops/action-gh-release@v1
- with:
- files: |
- ${{ steps.vars.outputs.STAGING_DIR }}/${{ steps.vars.outputs.PKG_NAME }}
- env:
- GITHUB_TOKEN: ${{ secrets.GITHUB_TOKEN }}
-
- - if: runner.os == 'macOS'
- name: "macOS: Build and package Unison.app"
- id: macapp
- run: |
- opam exec -- make src UISTYLE=mac
-
- # package
- APP_NAME=Unison-${{ steps.vars.outputs.PKG_VER }}.ocaml-${{ matrix.job.ocaml-version }}.${{ matrix.job.os }}.app.tar.gz
- echo ::set-output name=APP_NAME::${APP_NAME}
-
- tar czf ${APP_NAME} -C src/uimac/build/Default Unison.app
-
- - if: runner.os == 'macOS'
- name: "macOS: Upload Unison.app artifact"
- uses: actions/upload-artifact@v2
- with:
- name: Unison-${{ steps.vars.outputs.REF_SHAS }}.ocaml-${{ matrix.job.ocaml-version }}.${{ matrix.job.os }}.app
- path: ${{ steps.macapp.outputs.APP_NAME }}
-
- - if: runner.os == 'macOS' && steps.vars.outputs.DEPLOY
- name: "macOS: Publish Unison.app"
- uses: softprops/action-gh-release@v1
- with:
- files: ${{ steps.macapp.outputs.APP_NAME }}
- env:
- GITHUB_TOKEN: ${{ secrets.GITHUB_TOKEN }}
-
- opam_dune_build:
- strategy:
- fail-fast: false
- matrix:
- job:
- - { os: ubuntu-latest , ocaml-compiler: 4.12.x }
- - { os: macos-latest , ocaml-compiler: 4.12.x }
-
- runs-on: ${{ matrix.job.os }}
-
- steps:
- - name: Checkout code
- uses: actions/checkout@v2
-
- - name: Use OCaml ${{ matrix.job.ocaml-compiler }}
- uses: ocaml/setup-ocaml@v2
- with:
- ocaml-compiler: "${{ matrix.job.ocaml-compiler }}"
-
- - run: opam install . --deps-only
-
- - run: opam exec -- dune build && cp -L ./_build/install/default/bin/unison* ./src/
-
-# - run: opam exec -- make test
diff --git a/.gitignore b/.gitignore
index 7bcb4e2..fdc9a9c 100644
--- a/.gitignore
+++ b/.gitignore
@@ -31,7 +31,6 @@
/src/ubase/projectInfo.ml
/src/unison
/src/unison-fsmonitor
-/src/ubase/depend
TAGS
build
logmsg
@@ -40,13 +39,23 @@ doc/docs
doc/junk.ps
doc/postproc
doc/postproc.ml
+doc/prefs.tmp
+doc/prefsdocs.tmp
+doc/temp.dvi
+doc/temp.html
+doc/texdirectives.tex
doc/unison-manual.dtxt
doc/unison-manual.dvi
doc/unison-manual.html
doc/unison-manual.htoc
doc/unison-manual.pdf
doc/unison-manual.ps
+doc/unison-manual.txt
doc/unisonversion.tex
+man/*.tmp
+man/unison.1
+src/.depend.dot.tmp
+src/DEPENDENCIES.ps
_build
.merlin
diff --git a/.travis.yml b/.travis.yml
deleted file mode 100644
index 65b1168..0000000
--- a/.travis.yml
+++ /dev/null
@@ -1,25 +0,0 @@
-language: c
-sudo: required
-before_install:
- - curl -L https://raw.githubusercontent.com/ocaml/ocaml-ci-scripts/master/.travis-ocaml.sh | sh
- - eval $(opam config env)
-install:
- make
-script:
- make test
-
-cache:
- directories:
- - $HOME/.opam
- - /usr/local
-
-env:
- # - OCAML_VERSION=4.01
- - OCAML_VERSION=4.08
-
-os:
- - linux
-# - osx
-
-# BCP and brabalan, 1/19: We took away the OSX build because it is
-# horribly slow and 98% redundant...
\ No newline at end of file
diff --git a/Dockerfile b/Dockerfile
deleted file mode 100644
index 202d195..0000000
--- a/Dockerfile
+++ /dev/null
@@ -1,17 +0,0 @@
-FROM debian:stable-slim as builder
-
-RUN set -ex; \
- apt-get -y update; \
- apt-get -y install curl build-essential opam
-
-COPY . /usr/src/unison
-
-RUN set -ex; \
- cd /usr/src/unison; \
- make
-
-FROM debian:stable-slim
-COPY --from=builder /usr/src/unison/src/unison* /usr/local/bin/
-
-ENTRYPOINT ["unison"]
-CMD ["-doc", "about"]
diff --git a/INSTALL.md b/INSTALL.md
new file mode 100644
index 0000000..0bda622
--- /dev/null
+++ b/INSTALL.md
@@ -0,0 +1,139 @@
+# Installing Unison
+
+## Pre-built binaries
+
+The easiest and quickest way is to install pre-built binaries available at many
+package repositories. The caveat: some repositories are slow to update and
+often include a very old version of Unison.
+
+Alternatively, some pre-built binaries are made available at
+https://github.com/bcpierce00/unison/releases for macOS, Linux and Windows.
+
+
+## Building from source
+
+### Package repositories
+
+Many package repositories, including source-based repositories like `pkgsrc`,
+make it easy to build from source by handling all the dependencies for you.
+Please refer to instructions provided by the repository.
+
+
+### Unix-like OS (GNU/Linux, BSDs, macOS, illumos-based OS, Solaris, ...)
+
+#### Build prerequisites
+
+- A recent version of OCaml compiler (version 4.08 at minimum) together with a
+ C99 compiler (such as gcc, clang) -- see https://ocaml.org/
+- GNU make
+- Basic POSIX tools: sh, sed (optional, for manuals)
+
+##### Optional, for the GUI only
+
+- lablgtk3 and its prerequisites (ocamlfind, GTK 3 and its dependencies)
+
+##### Optional, for building the user manual
+
+- LaTeX
+- dvips
+- ps2pdf (included with Ghostscript, for example)
+- HEVEA (https://hevea.inria.fr/) (optional, for HTML and text formats)
+- Lynx (optional, for text format)
+- (for developers only) HEVEA and Lynx are required to re-build the manual
+ included in the Unison binary
+
+#### Building
+
+Building from source is as simple as executing:
+```
+make
+```
+
+Use `gmake` in environments where GNU make is not the default. If you are
+using OPAM then `opam exec -- make` may work for you, as opam needs to set up
+a specific environment.
+
+Presence of lablgtk3 is detected automatically. If you want to force building
+the GUI (or not), type `make UISTYLE=gtk3` or `make UISTYLE=text`.
+
+There is currently no installation provided by the makefile. You can just copy
+the built binaries to where you need them. The following files are produced:
+```
+src/unison (the main executable)
+src/unison-fsmonitor (optional, on some build platforms)
+src/fsmonitor.py (optional, if unison-fsmonitor is not built)
+man/unison.1 (optional, manual page)
+doc/unison-manual.* (optional, user manual in different formats)
+```
+
+#### Building all from scratch
+
+It is very easy to build both the OCaml compiler and Unison from source without
+using a package repository. Building OCaml has very few prerequisites. If your
+system has a supported C compiler installed then the following may work out of
+the box:
+
+```
+# Build OCaml compiler
+## In a dir with extracted OCaml source
+./configure
+make
+make install # you may need elevated privileges
+
+# Build unison
+## In a dir with extracted Unison source
+make
+```
+
+Building the GTK GUI this way is difficult as both GTK 3 and lablgtk3 must be
+built and installed.
+
+
+### macOS
+
+#### Build prerequisites
+
+- Xcode Command Line Tools (optional, for the native GUI)
+
+#### Building
+
+For the text user interface and GTK GUI, follow the Unix instructions above.
+
+To build the macOS native GUI, execute:
+```
+make UISTYLE=mac
+```
+
+The built application will be located at `src/uimac/build/Default/Unison.app`.
+
+
+### Windows
+
+Building on Windows is currently somewhat complicated. All methods require
+Cygwin as a POSIX-like layer for Windows. Cygwin is required for the build
+process only; the build can produce fully native Windows binaries that don't
+require Cygwin to run.
+
+Builds are possible with MS Visual C++ (MSVC) (currently untested and likely
+not working), MinGW-w64 (currently the best option) and Cygwin GNU C (untested;
+produced binaries require Cygwin to run).
+
+Tradeoff?
+
+- MSVC and MinGW can produce statically linked Unison executable.
+- The Cygwin GNU C option requires only free software.
+
+You have to add `OSTYPE=$OSTYPE` as argument to `make`: `make OSTYPE=$OSTYPE`
+(OSTYPE is preset to 'cygwin' by Cygwin).
+
+
+### Build options
+
+There are some additional options that control the build process:
+
+- NATIVE: If you can't compile a native binary for your platform then add
+ `NATIVE=false` as argument to `make`. This will produce a single native
+ executable with OCaml runtime and Unison bytecode embedded.
+- STATIC: Adding `STATIC=true` as argument to `make` will produce a (mostly)
+ statically linked executable. This may not work on all platforms or with all
+ build methods.
diff --git a/Makefile b/Makefile
index d5f38f5..1f962d4 100644
--- a/Makefile
+++ b/Makefile
@@ -1,230 +1,50 @@
-.PHONY: all src
+# Unison file synchronizer: Makefile
+# See LICENSE for terms.
-default: text
-
-text:
- $(MAKE) -C src UISTYLE=text
-
-test:
- ./src/unison -ui text -selftest
-
-all: src
+.PHONY: all
+all: src manpage
+.PHONY: src
src:
$(MAKE) -C src
--include src/Makefile.ProjectInfo
-
+# It's a wart that docs need "unison" built (vs some docs utility).
+# Having docs build src/unison points out that UISTYLE is a bug; either
+# docs might build the GUI (not wanted as too heavy for docs use), or
+# whatever is built might not be rebuilt later.
+.PHONY: docs
docs:
$(MAKE) -C src UISTYLE=text
$(MAKE) -C doc
+ $(MAKE) -C man
-include src/Makefile.OCaml
-
-######################################################################
-# Export
-
-ifeq ($(OSARCH),win32)
- BCPHOME=/cygdrive/s
- # BCPHOME=/home/exporting
- EXPORTNATIVE=true
- EXPORTSTATIC=true
-else
-ifeq ($(OSARCH),win32gnuc)
- BCPHOME=/home/exporting
- EXPORTNATIVE=true
- EXPORTSTATIC=false
-else
-ifeq ($(OSARCH),linux)
- EXPORTNATIVE=true
- EXPORTSTATIC=false
-else
-ifeq ($(OSARCH),osx)
- EXPORTNATIVE=true
- EXPORTSTATIC=false
-else # Solaris
- EXPORTNATIVE=true
- EXPORTSTATIC=true
-endif
-endif
- BCPHOME=$(HOME)
-endif
-endif
-
-EXPORTDIR=$(BCPHOME)/pub/$(NAME)
-DOWNLOADAREA=releases
-DOWNLOADPARENT=$(EXPORTDIR)/download/$(DOWNLOADAREA)
-REALDOWNLOADDIR=$(DOWNLOADPARENT)/$(NAME)-$(VERSION)
-BRANCH=$(MAJORVERSION)
-EXPORTNAME=$(NAME)-$(VERSION)
-# OSX/linux portability
-ifeq ($(OSARCH),osx)
- TMP=$(shell mktemp -d -t unison)
-else
- TMP=$(shell mktemp -d)
-endif
-DOWNLOADDIR=/tmp/$(NAME)-$(VERSION)
-# DOWNLOADDIR=$(REALDOWNLOADDIR)
-
-# OLD
-# Do this when it's time to create a new beta-release from the development trunk
-#beta:
-# @echo "Makefile needs fixing"
-# @exit 1
-# @tools/ask tools/exportmsg.txt
-# (cd ..; svn copy trunk branches/$(BRANCH))
-# (cd ../branches/$(BRANCH); svn commit -m "New release branch")
-# @echo
-# @echo "Press RETURN to export it... "
-# @read JUNK
-# $(MAKE) -C ../branches/$(BRANCH) export
-
-# Do this in a release branch to export a new tarball (e.g., after fixing a bug)
-# (builds a beta release)
-export:
- @echo
- @echo "CHECKLIST:"
- @echo " - Bump minor version number in src/Makefile.ProjectInfo"
- @echo " - Move everything interesting from src/RECENTNEWS to doc/changes.tex"
- @echo ""
- @echo "If all this is done, hit RETURN (otherwise Ctrl-C and do it)"
- @read JUNK
- $(MAKE) $(DOWNLOADDIR)
- $(MAKE) exportdocs
- $(MAKE) exportsources
- (cd $(DOWNLOADDIR); genindexhtml)
- @echo
- @echo "OK to commit? Press RETURN if yes (Crtl-C if no)..."
- @read JUNK
- $(MAKE) commitexport
-
-commitexport:
- $(MAKE) realcommit
- $(MAKE) mailchanges
-
-realcommit:
- @echo
- @echo Committing new export directory
- mv $(DOWNLOADDIR) $(REALDOWNLOADDIR)
- -chmod -R a+r $(EXPORTDIR)
- -chmod -R g+wr $(EXPORTDIR)
- -chmod -R o-w $(EXPORTDIR)
- -$(RM) $(DOWNLOADPARENT)/beta
- -ln -s $(EXPORTNAME) $(DOWNLOADPARENT)/beta
- (cd $(DOWNLOADPARENT); genindexhtml)
-
-$(DOWNLOADDIR):
- @echo Creating DOWNLOADDIR = $(DOWNLOADDIR)
- @echo
- -mkdir -p $(DOWNLOADDIR)
-
-exportsources:
- git archive --output $(DOWNLOADDIR)/$(EXPORTNAME).tar.gz -- HEAD src
-
-exportdocs:
- -rm -f src/unison
- $(MAKE) -C src UISTYLE=text DEBUGGING=false \
- NATIVE=$(EXPORTNATIVE) STATIC=$(EXPORTSTATIC)
- -$(RM) src/strings.ml
- $(MAKE) -C doc TEXDIRECTIVES+="\\\\draftfalse" real
- $(MAKE) -C src UISTYLE=text DEBUGGING=false \
- NATIVE=$(EXPORTNATIVE) STATIC=$(EXPORTSTATIC)
- src/unison -doc news > src/NEWS
- cp doc/unison-manual.ps $(DOWNLOADDIR)/$(EXPORTNAME)-manual.ps
- -cp doc/unison-manual.pdf $(DOWNLOADDIR)/$(EXPORTNAME)-manual.pdf
- cp doc/unison-manual.html $(DOWNLOADDIR)/$(EXPORTNAME)-manual.html
- cp doc/unison-manual.html $(DOWNLOADDIR)/$(NAME)-manual.html
+# "src" is a prerequisite to prevent parallel build errors.
+# manpage builds currently require a pre-built "unison" binary.
+.PHONY: manpage
+manpage: src
+ $(MAKE) -C man
-MAILTMP = $(HOME)/mail.tmp
-
-mailchanges:
- @echo To: $(NAME)-announce@yahoogroups.com,$(NAME)-users@yahoogroups.com \
- > $(MAILTMP)
- @echo Subject: $(NAME) $(VERSION) now available >> $(MAILTMP)
- @echo >> $(MAILTMP)
- @echo Download address: >> $(MAILTMP)
- @echo " " http://www.cis.upenn.edu/~bcpierce/unison/download.html \
- >> $(MAILTMP)
- @echo >> $(MAILTMP)
- @cat src/NEWS >> $(MAILTMP)
- @src/unison -doc news >> $(MAILTMP)
- @echo "Announcement draft can be found in $(MAILTMP)"
-
-######################################################################
-# Export binary for the current architecture
-# (this stuff is all probably dead)
-
-EXPORTTMP=$(TMP)/export-$(OSARCH)x.tmp
-
-exportnative:
- -$(RM) -r $(EXPORTTMP)
- cp -r src $(EXPORTTMP)
- $(MAKE) realexportnative
-ifeq ($(OSARCH),linux)
- $(MAKE) realexportnative EXPORTSTATIC=true KIND=-static
-endif
- $(RM) -r $(EXPORTTMP)
-
-realexportnative:
- -$(MAKE) -C $(EXPORTTMP) clean
- $(MAKE) -C $(EXPORTTMP) UISTYLE=text DEBUGGING=false \
- NATIVE=$(EXPORTNATIVE) STATIC=$(EXPORTSTATIC)
- -mkdir -p $(DOWNLOADDIR)
- cp $(EXPORTTMP)/$(NAME)$(EXEC_EXT) \
- $(DOWNLOADDIR)/$(EXPORTNAME).$(OSARCH)$(KIND)-textui$(EXEC_EXT)
- gzip --best --force -c \
- $(DOWNLOADDIR)/$(EXPORTNAME).$(OSARCH)$(KIND)-textui$(EXEC_EXT) \
- > $(DOWNLOADDIR)/$(EXPORTNAME).$(OSARCH)$(KIND)-textui$(EXEC_EXT).gz
- $(MAKE) -C $(EXPORTTMP) UISTYLE=gtk2 DEBUGGING=false \
- NATIVE=$(EXPORTNATIVE) STATIC=$(EXPORTSTATIC)
- cp $(EXPORTTMP)/$(NAME)$(EXEC_EXT) \
- $(DOWNLOADDIR)/$(EXPORTNAME).$(OSARCH)$(KIND)-gtkui$(EXEC_EXT)
- gzip --best --force -c \
- $(DOWNLOADDIR)/$(EXPORTNAME).$(OSARCH)$(KIND)-gtkui$(EXEC_EXT) \
- > $(DOWNLOADDIR)/$(EXPORTNAME).$(OSARCH)$(KIND)-gtkui$(EXEC_EXT).gz
-
-
-######################################################################
-# Version control
-
-checkin: logmsg remembernews
- git commit -a --file=logmsg
- $(RM) logmsg
- @echo
- @echo "Remember to do:"
- @echo " git pull && git push"
-
-remembernews: logmsg
- echo "CHANGES FROM VERSION" $(VERSION) > rc.tmp
- echo >> rc.tmp
- cat logmsg >> rc.tmp
- echo >> rc.tmp
- echo ------------------------------- >> rc.tmp
- -cat src/RECENTNEWS >> rc.tmp
- mv -f rc.tmp src/RECENTNEWS
-
-######################################################################
-# Misc
+.PHONY: test
+test:
+ ./src/unison -ui text -selftest
-depend::
+.PHONY: depend
+depend:
$(MAKE) -C src depend
-clean::
- $(RM) -r *.tmp \
- *.o *.obj *.cmo *.cmx *.cmi core TAGS *~ *.log \
- *.aux *.log *.dvi *.out *.backup[0-9] *.bak $(STABLEFLAG)
+.PHONY: clean
+clean:
$(MAKE) -C doc clean
+ $(MAKE) -C man clean
$(MAKE) -C src clean
+.PHONY: install
install:
- (cd src; $(MAKE) install)
-
-installtext:
- (cd src; $(MAKE) install UISTYLE=text)
-
-src/$(NAME):
- $(MAKE) -C src
-
-windres:
- windres src/win32rc/unison.rc -O coff src/win32rc/unison.res.lib
- windres src/win32rc/unison.rc -O res src/win32rc/unison.res
+ @printf "\n\n=========================================\n\
+To install, copy the files src/unison, src/unison-gui (optional),\n\
+src/unison-fsmonitor (optional) and src/fsmonitor.py (optional,\n\
+if unison-fsmonitor does not exist) to a freely chosen location.\n\n\
+Manual page is at man/unison.1 and user manual is at\n\
+doc/unison-manual.pdf, doc/unison-manual.html and doc/unison-manual.txt\n\
+=========================================\n\n\n"
+ @exit 1
diff --git a/src/NEWS b/NEWS.md
similarity index 95%
rename from src/NEWS
rename to NEWS.md
index fc5ac2d..f5a329e 100644
--- a/src/NEWS
+++ b/NEWS.md
@@ -1,7 +1,114 @@
+# UNISON NEWS
-Changes in Version 2.51.5
+This file contains a summary of user-visible or important changes, in
+the style of the GNU coding standards. By user-visible, we include
+changes relevant for those building unison from source. We omit most
+bugfixes and minor improvements, but of course every release contains
+some. Refer to the documentation for details; this file is a terse
+notice of changes rather than a tutorial about new features.
+
+As of 2022, this file (NEWS.md at top level) is used for news.
+
+Some software has a "changelog" file that records all changes, but
+unison uses git history for that, and thus there is no changelog file.
+
+## Changes in 2.53.3
+
+Released 2023-04-28
+
+ * On Linux, allow syncing the xattrs where POSIX draft ACLS are
+ stored, which enables syncing the ACL info. (Note that this does
+ not enable syncing ACLs with the `-acl` switch, and does not
+ enable syncing ACLs between other systems and Linux. See the
+ manual.)
+ * Improved ETA calculation and sync speed display in text UI.
+ * Fix CI Windows builds (again).
+ * Drop unmaintained "make install" target.
+ * Bugfixes, minor improvements, cleanups.
+
+## Changes in 2.53.2
+
+Released 2023-03-20
+
+ * Change version string to 2.53.2 (2.53.1 identified as 2.53.0).
+
+## Changes in 2.53.1
+
+Released 2023-03-19
+
+ * Repeat mode is more fault tolerant, recovering after temporary
+ errors.
+ * Preferences "force", "prefer" and related no longer require
+ specifying the full root.
+ * Improve stopping of update propagation.
+ * Enable VT input escape codes in Windows.
+ * Respect user-provided CFLAGS, CPPFLAGS, LDFLAGS, LDLIBS.
+ * Add build instructions in INSTALL.md (and drop from manual).
+ * Add graceful stop in repeat mode - SIGUSR2.
+ * Add watch+seconds to 'repeat' preference.
+
+## Changes in 2.53.0
+
+Released 2022-11-07
+
+ * OCaml >= 4.08 is required to build unison.
+ * unison can be built with (unreleased) OCaml 5.
+ * Change GUI to use GTK3 (via lablgtk3) instead of GTK2 (via lablgtk2)
+ * Add support for syncing extended attributes.
+ * Add support for syncing ACLs.
+ * On Windows, add the ability to build unison as a hybrid
+ application (GUI application attached to a text console) by
+ defining UI_WINOS=hybrid (see src/Makefile). Add this to CI.
+ (Doing this for non-Windows is unnecessary as all applications,
+ both GUI and non-GUI, are always executed with a connection to
+ stdout/stderr. GUI-only applications (ie, no stdout/stderr) is a
+ Windows-only concept.)
+ * Notable bugfixes
+ - Merge results are stored in archive more accurately.
+ - Windows `\\?\` paths now work correctly (including `\\?\Volume{GUID}\` paths).
+ * CI changes
+ - The macOS binaries are properly signed.
+ - Add workaround for bugs in the github CI Windows builds, one of
+ which resulted in the 2.52.1 GUI version failing, in the Windows
+ CI build artifacts. (This does not affect platforms other than
+ Windows, and may not affect other Windows builds.)
+ * Changes that should not affect behavior
+ - Clean up a variety of unmaintained and unused bits, mainly
+ build-related.
+ - OCaml's Unix library is now extensively used also on
+ Windows. This allowed removal of large amount of
+ Windows-specific OCaml and mainly C code.
+
+## Changes in 2.52.1
+
+Released 2022-05-08
+
+ * Deprecate ocaml < 4.08: 2.53.0 will require 4.08 or higher
+ * Add man page
+ * Remove rsh:// URI scheme (ssh:// of course remains).
+ * Significant bugfixes and minor improvements
+ * Deprecate "backups" preference (see manual for alternatives)
+ * Deprecate "stream" and "halfduplex" preferences
+
+## Changes in 2.52.0
+
+Released 2022-03-12
+
+ * Feature negotiation, compatible with 2.51.
+ * New archive format (independent of ocaml version, based on umarshal)
+ Upgrade is automatic.
+ * New wire protocol (independent of ocaml version, based on umarshal)
+ New protocol is used if both sides are >= 2.52.0.
+ * Compatibility with 2.48
+ * Support for unix-domain sockets
+ * Many bugfixes and minor improvements
+ * ocaml compatibility is now >= 4.01
+ * NEWS is now in NEWS.md and not in the manual
+
+## Changes in 2.51.5
+
+Released 2021-12-18
- Changes since 2.51.4:
* Restore OCaml compat to before 4.02
* dune/opam improvements/fixes
* Improve GTK UI by using GtkTreeView
@@ -9,7 +116,10 @@ Changes in Version 2.51.5
* Improve ssh support on Windows (hide Windows console in GUI mode)
* Many bugfixes and minor improvements
- Changes since 2.51.3:
+## Changes in 2.51.4
+
+Released 2021-06-24
+
* OCaml 4.12 support
* fsmonitor improvements and Solaris support
* Color support in text UI, with a new preference, disabled by
@@ -21,7 +131,10 @@ Changes in Version 2.51.5
* Build cleanups, CI improvements, housekeeping
* Many bugfixes and minor improvements
- Changes since 2.51.2:
+## Changes in 2.51.3
+
+Released 2020-10-21
+
* Some nontrivial changes to profile parsing (G.raud Meyer)
+ '=' has been considered whitespace until now: several
following chars are considered as only one; trailing chars are
@@ -39,7 +152,8 @@ Changes in Version 2.51.5
etc., plus several more useful key-commands. Type "?" to
Unison to see all available commands.
- Changes since 2.48:
+## Changes in 2.51.0 through 2.51.2
+
* Repository transplanted from SVN to Git and moved to GitHub ()
(https://github.com/bcpierce00/unison).
* Add a new preference, 'atomic', for specifying directories that
@@ -61,7 +175,8 @@ Changes in Version 2.51.5
+ Added a DockerFile for the convenience of Docker users.
+ Many small bugfixes and UI improvements.
- Changes since 2.45:
+## Changes in 2.48
+
* Incorporated a patch from Christopher Zimmermann to replace the
Uprintf module (which doesn't work with OCaml 4.02, causing Unison
to crash) with equivalent functionality from the standard library.
@@ -103,7 +218,7 @@ Changes in Version 2.51.5
* Minor:
+ Fixed a bug in export procedure that was messing up
documentation strings.
- + Incorporated a patch from Ir�nyossy Knoblauch Art�r to make
+ + Incorporated a patch from Irányossy Knoblauch Artúr to make
temp file names fit within 143 characters (to make eCryptFS
happy).
+ Added a string to the Conflict direction to document the
@@ -120,6 +235,11 @@ Changes in Version 2.51.5
+ Fixed Makefile for cross-compiling towards Windows (updated to
MinGW-w64)
+## Changes in very old versions
+
+(Note that these are written 'Changes since' and thus the content
+applies to the release after that.)
+
Changes since 2.40.63:
* New preference fastercheckUNSAFE, which can be used (with care!) to
achieve much faster update detection when all the common files in
@@ -706,7 +826,7 @@ Changes in Version 2.51.5
+ Ignore trailing dots in filenames in case insensitive mode
+ Proper quoting of paths, files and extensions ignored using
the UI
- + The strings CURRENT1 and CURRENT2 are now correctly substitued
+ + The strings CURRENT1 and CURRENT2 are now correctly substituted
when they occur in the diff preference
+ Improvements to syncing resource forks between Macs via a
non-Mac system.
@@ -1344,7 +1464,7 @@ Changes in Version 2.51.5
preference is a mask indicating which permission bits should
be synchronized. It is set by default to 0o1777: all bits but
the set-uid and set-gid bits are synchronised (synchronizing
- theses latter bits can be a security hazard). If you want to
+ these latter bits can be a security hazard). If you want to
synchronize all bits, you can set the value of this preference
to -1.
+ Added a log preference (default false), which makes Unison
@@ -1446,7 +1566,7 @@ Changes in Version 2.51.5
paths matching this pattern to be displayed last.
The sorting preferences are described in more detail in the user
manual. The sortnewfirst and sortbysize flags can also be accessed
- from the 'Sort' menu in the grpahical user interface.
+ from the 'Sort' menu in the graphical user interface.
* Added two new preferences that can be used to change unison's
fundamental behavior to make it more like a mirroring tool instead
of a synchronizer.
@@ -1813,5 +1933,3 @@ Changes in Version 2.51.5
around with.
* Added a file CONTRIB with some suggestions for how to help us make
Unison better.
-
-
diff --git a/README.md b/README.md
index f3d80d6..749fe17 100644
--- a/README.md
+++ b/README.md
@@ -1,11 +1,17 @@
+
+
# Unison File Synchronizer
-[](https://travis-ci.org/bcpierce00/unison)
-[](https://github.com/bcpierce00/unison/actions?query=workflow%3ACICD)
+## Meta
+
+***Please read this entire README and
+https://github.com/bcpierce00/unison/wiki/Reporting-Bugs-and-Feature-Requests
+before creating or commenting on a github issue.***
+
+***TL;DR: Do not ask questions or ask for help in issues. Upgrade to the latest release.***
-***Please read this entire README before creating or commenting on a
-github issue. TL;DR: Do not ask questions or ask for help in
-issues.***
+For compatibility information with version 2.52, see
+https://github.com/bcpierce00/unison/wiki/2.52-Migration-Guide
## About
@@ -61,12 +67,19 @@ several points where it differs:
Note that only a very small number of people are actively working on
maintaining unison. An estimate is 2.5 people and 0.1 Full-Time
Equivalents. This has a substantial impact on the handling of bug
-reports and enhancement reports; see below. Help in terms of
-high-quality bug reports, fixes, and proposed changes is very welcome.
-
-While much of Unison activity is now at
-https://github.com/bcpierce00/unison/ additional information can be
-found at: http://www.cis.upenn.edu/~bcpierce/unison
+reports and enhancement reports; see the wiki page linked at the top.
+Help in terms of high-quality bug reports, fixes, and proposed changes
+is very welcome. Help in answering mailinglist questions is also
+welcome. Please do not answer questions asked in the bug tracker,
+which is contrary to bug tracker usage guidance.
+
+Unison activity is now centered on the two [Unison
+mailinglists](https://github.com/bcpierce00/unison/wiki/Mailing-Lists)
+for discussion and [Unison's github
+page](https://github.com/bcpierce00/unison/) for code, issues and a
+wiki.
+A no-longer-maintained FAQ can be found at: the [old UPenn
+site](http://www.cis.upenn.edu/~bcpierce/unison).
## Getting Unison
@@ -76,7 +89,7 @@ Unison. Results from Continuous Integration builds, while performed
for the purposes of testing, are available for use on a limited set of
platforms.
-See the manual in doc/ for building instructions, or read the CI
+See the [building instructions](INSTALL.md), or read the CI
recipes. (Currently, this is probably less well explained than it
should be.)
@@ -84,13 +97,19 @@ You may be able to find a pre-built binary for your operating system,
version, and CPU type. For a list of sources, See
https://github.com/bcpierce00/unison/wiki/Downloading-Unison
-Generally, you should use the most recent formal release, currently
-2.51.X. Earlier branches (e.g. 2.48) are no longer maintained, and
-bug reports are not accepted about these versions. This is true even
-though many packaging systems (including GNU/Linux distributions)
-continue to have 2.48. There are sometimes release candidates. There
-is always the master branch in git, which historically has been quite
-stable.
+You should use the most recent formal release, or a newer version from
+git. Earlier versions are no longer maintained, and bug reports are
+not accepted about these versions. This is true even though many
+packaging systems (including GNU/Linux distributions) continue to have
+2.51 or even 2.48. The master branch in git historically has been
+quite stable.
+
+### Version compatibility
+
+For Unison versions 2.52 and newer, see
+https://github.com/bcpierce00/unison/wiki/2.52-Migration-Guide
+
+The information below is true for Unison versions older than 2.52.
Beware that Unison uses OCaml's built-in data marshalling, and that
this facility is unstable across versions of "ocaml" (the standard
@@ -105,42 +124,6 @@ There are two mailinglists: unison-users and unison-hackers.
Descriptions and instructions are at
https://github.com/bcpierce00/unison/wiki/Mailing-Lists
-## Asking for Help and Reporting Bugs
-
-For an expanded discussion of asking for help, see
-https://github.com/bcpierce00/unison/wiki/Reporting-Bugs-and-Feature-Requests
-
-The issue tracker is for bug reports and (limited) enhancement
-requests. Specifically, this means that questions and requests for
-help are not appropriate as issues; those should be directed to
-unison-users (or unison-hackers if the discussion requires reading the
-source code).
-
-Unison's product is the source code. A packaging system having an old
-version is not a bug in Unison. The CI-provided binaries exist for
-Continuous Integration and are useful for users as a side benefit.
-Therefore, the CI binaries not working on a particular operating
-system is not a Unison bug. (In general, binaries should be provided
-by packaging systems.)
-
-A bug means that the reporter can articulate how Unison should have
-behaved and say what it did instead, either as a violation of an
-explicit specification, or an implicit specification that is likely to
-be widely viewed as valid. Bugs should be phrased as "unison randomly
-deletes files outside of the synchronization root", summarizing the
-bad behavior (that's humor -- Unison has never even been accused of
-doing that!).
-
-An enhancement request should describe how Unison should do something
-different or additional, phrased as an imperative as something like
-"Change wire protocol to be independent of ocaml compiler version".
-Enhancement requests are appropriate if they are clearly articulated,
-and would bring benefits to users that are significant compared to
-their likely implementation effort. Speculative or "pie in the sky"
-enhancement requests may be closed on the basis that their continued
-presence in the issue tracker has too much cognitive load compared to
-benefit, especially if the submitter doesn't intend to work on it.
-
## Development and Submitting Proposed Changes
If you want to play with the internals, have a look at the file
diff --git a/debian/changelog b/debian/changelog
index b3a7534..45c12cf 100644
--- a/debian/changelog
+++ b/debian/changelog
@@ -1,3 +1,9 @@
+unison-2.51+4.13.1 (2.53.3-1) UNRELEASED; urgency=low
+
+ * New upstream release.
+
+ -- Debian Janitor <janitor@jelmer.uk> Wed, 10 May 2023 07:06:53 -0000
+
unison-2.51+4.13.1 (2.51.5-1) unstable; urgency=medium
* Compile with OCaml 4.13.1
diff --git a/doc/.depend b/doc/.depend
deleted file mode 100644
index e69de29..0000000
diff --git a/doc/Makefile b/doc/Makefile
index 41d608b..fbae46d 100644
--- a/doc/Makefile
+++ b/doc/Makefile
@@ -6,7 +6,7 @@ all:: unison-manual.html
include ../src/Makefile.OCaml
STRINGS = ../icons/Unison.gif
-SOURCES = unison-manual.tex changes.tex \
+SOURCES = unison-manual.tex \
local.tex short.tex postproc$(EXEC_EXT) Makefile
# ifeq ($(shell ls /usr/local/bin/hevea), /usr/local/bin/hevea)
@@ -40,17 +40,18 @@ ifeq ($(HEVEA),true)
latex unison-manual.tex
hevea unison-manual.tex
./postproc < unison-manual.html > temp.html
- (TERM=vt100; export TERM; lynx -dump temp.html > unison-manual.dtxt)
+ (TERM=vt100; export TERM; lynx -display_charset=utf8 -dump temp.html > unison-manual.dtxt)
+ sed -e "/^----SNIP----/,+2 d" -e "/^Junk/,$$ d" unison-manual.dtxt > unison-manual.txt
./docs$(EXEC_EXT)
endif
- printf '$(TEXDIRECTIVES)\\textversionfalse' > texdirectives.tex
+ printf '$(TEXDIRECTIVES)\\textversionfalse\\draftfalse' > texdirectives.tex
latex unison-manual.tex
latex unison-manual.tex
cp unison-manual.dvi temp.dvi
dvips -t letter -o unison-manual.ps unison-manual.dvi
dvips -t letter -z -Ppdf -G0 -D600 unison-manual.dvi -o junk.ps
ps2pdf junk.ps unison-manual.pdf
-ifdef HEVEA
+ifeq ($(HEVEA),true)
hevea unison-manual.tex
endif
@@ -77,12 +78,12 @@ postproc$(EXEC_EXT) : postproc.ml
clean::
$(RM) -r \
- *.dtxt *.aux *.log *.out \
+ *.dtxt *.aux *.haux *.log *.out \
texdirectives.tex \
junk.* *.htoc *.toc *.bak \
docs docs.exe temp.dvi temp.html unison-manual.html \
postproc postproc.exe postproc.ml \
unison-manual.dvi unison-manual.ps unison-manual.pdf \
- unison-manual.info* unisonversion.tex \
+ unison-manual.txt unison-manual.info* unisonversion.tex \
contact.html faq.html faq.haux index.html
diff --git a/doc/changes.tex b/doc/changes.tex
deleted file mode 100644
index 477ad85..0000000
--- a/doc/changes.tex
+++ /dev/null
@@ -1,2026 +0,0 @@
-\begin{changesfromversion}{2.51.4}
-\item Restore OCaml compat to before 4.02
-\item dune/opam improvements/fixes
-\item Improve GTK UI by using GtkTreeView
-\item Add support for syncing symlinks on Windows (NTFS)
-\item Improve ssh support on Windows (hide Windows console in GUI mode)
-\item Many bugfixes and minor improvements
-\end{changesfromversion}
-
-\begin{changesfromversion}{2.51.3}
-\item OCaml 4.12 support
-\item fsmonitor improvements and Solaris support
-\item Color support in text UI, with a new preference, disabled by
- NO\_COLOR.
-\item Interactive profile selection in text UI, enabled by a new
- preference.
-\item Working files are stored in the unison directory (typically
- ~/.unison) rather than \$HOME.
-\item Build cleanups, CI improvements, housekeeping
-\item Many bugfixes and minor improvements
-\end{changesfromversion}
-
-\begin{changesfromversion}{2.51.2}
-\item Some nontrivial changes to profile parsing (G.raud Meyer)
- \begin{itemize}
- \item '=' has been considered whitespace until now: several
- following chars are considered as only one; trailing chars are
- discarded; any non empty sequence of char is splitting. This is non
- standard and leads to confusion, for example -ignore== 'Name .*=*'
- is valid when -ignore='Name .*=*' is not, and worse -ignore='Name
- *=' is the same as -ignore='Name *'. The parser now takes just a
- single '=' as delimiter after the option name. Other = characters
- are considered as part of the value being assigned to the option.
- \end{itemize}
-\item Numerous improvements to the text user-interface (G.raud Meyer)
- \begin{itemize}
- \item New key-commands that restrict the display to a set of
- "matching" items: ones that are offering to propagate changes in a
- particular direction, conflicts, files to be merged, etc., plus
- several more useful key-commands. Type "?" to Unison to see all
- available commands.
- \end{itemize}
-\end{changesfromversion}
-
-\begin{changesfromversion}{2.48}
-\item Repository transplanted from SVN to Git and moved to GitHub (\URL{https://github.com/bcpierce00/unison}).
-\item Add a new preference, '{\tt atomic}', for specifying directories that
- should be treated atomically: if there are changes within such a
- directory in both replicase, the whole directory is marked as a
- conflict instead of propagating any of the changes. Thanks to
- Julian Squires for submitting this patch!
-\item OSX / macOS
- \begin{itemize}
- \item Ported to 10.13, High Sierra, and Apple's new APFS (earlier
- versions of Unison break because of new behavior of AppleDouble files)
- \item Replaced Growl with OS X native notification center.
-\end{itemize}
-\item Miscellaneous:
-\begin{itemize}
-\item The OCaml compiler version is now included in the ``connection header
---- the string that's printed when connecting to a remote server --- to
-facilitate debugging version mismatch issues.
-\item Compatible with OCaml 4.06.
-\item Added a DockerFile for the convenience of Docker users.
-\item Many small bugfixes and UI improvements.
-\end{itemize}
-\end{changesfromversion}
-
-\begin{changesfromversion}{2.45}
-\item Incorporated a patch from Christopher Zimmermann to replace the
- Uprintf module (which doesn't work with OCaml 4.02, causing Unison to crash) with equivalent
- functionality from the standard library.
-\item Incorporated a refresh of the OSX GUI, contributed by Alan Shutko.
-\item Added a {\tt maxsizethreshold} option, which prevents the transfer of
- files larger than the size specified (in Kb).
-\item Added a "copyonconflict" preference, to make a copy of files that would
- otherwise be overwritten or deleted in case of conflicting changes.
- (This makes it possible to automatically resolve conflicts in a
- fairly safe way when synchronizing continuously, in combination
- with the "{\tt repeat = watch}" and "{\tt prefer = newer}" preferences.
-%%%%%
-\item File system monitoring:
-\begin{itemize}
-\item
-The file watcher now fails when unable to
- watch a directory, rather than silently ignoring the issue.
-\item File system monitoring: more robust communication with the helper program
- (in socket mode, the unison server will still work properly despite
- unexpected unison client disconnections).
-\item A bytecode version of unison-fsmonitor is now produced by "make NATIVE=false"
-\item Improved search for unison-fsmonitor
-\item Detect when the helper process exits.
-\item More robust file watching helper programs for Windows and Linux.
- They communicate with Unison through pipes (Unison redirects stdin
- and stdout), using a race-free protocol.
-\item Retries paths with failures using an exponential backoff algorithm.
-\item The information returned by the file watchers are used
- independently for each replica; thus, when only one replica has
- changes, Unison will only rescan this replica.
-\item When available, used by the graphical UIs to speed up rescanning
- (can be disabled by setting the new {\tt watch} preference to
-\item Small fix to the way fsmonitor.py gets invoked when using the file
- watching functionality, suggested by Josh Berdine. Unison will now
- look for {\tt fsmonitor.py} in the same directory where the Unison
- executable itself lives.
-\end{itemize}
-%%%%%
-\item Minor:
-\begin{itemize}
-\item Fixed a bug in export procedure that was messing up documentation
-strings.
-\item Incorporated a patch from Ir\'anyossy Knoblauch Art\'ur to make temp file
- names fit within 143 characters (to make eCryptFS happy).
-\item Added a string to the Conflict direction to document the reason of
- the conflict.
-\item Log conflicts and problems in the text UI even if nothing is propagated.
-\item Use hash function from OCaml 3.x for comparing archives, even when
- compiled with OCaml 4.x.
-\item Do not restart Unison in case of uncaught exception when the repeat
- preference is set. This seems safer. And it does not work, for
- instance, in case of lost connection.
-\item Fix Unix.readlink invalid argument error under Windows
-\item Fix a crash when the output of the {\tt diff} program is too large.
-\item Fixed Makefile for cross-compiling towards Windows (updated to MinGW-w64)
-\end{itemize}
-\end{changesfromversion}
-
-\begin{changesfromversion}{2.40.63}
-\item New preference {\tt fastercheckUNSAFE}, which can be used (with care!)
-to achieve {\em much} faster update detection when all the common files in
-the two replicas are known to be identical. See the manual for more
-information.
-
-This feature should still be considered experimental, but it's ready for
-other people to try out.
-\item Added option {\tt clientHostName}. If specified, it will be used to as
-the client host name, overriding {\tt UNISONLOCALHOSTNAME} and the actual
-host name.
-\item OS X GUI:
-\begin{itemize}
-\item fix crash under Lion, because of problems with the toolbar, using the
-fix suggested in {\tt http://blitzbasic.com/Community/posts.php?topic=95778}.
-
-\item uimacnew09 is now the standard graphical interface on OSX
-\item A small improvement to the uimacnew09 interface from Alan Schmitt
- and Steve Kalkwarf: when Unison is run with the -batch flag, the
- interface will now automatically propagate changes and terminate,
- without waiting for user interaction.
-\item Show a modal warning window if there is no archive for the hosts. The
-user can then choose to exit or proceed (proceed is the default). The window
-is not shown if the {\tt batch} preference is true.
-\item file details panel selectable
-\end{itemize}
-\item GTK GUI:
-\begin{itemize}
-\item New version of uigtk2.ml from Matt Zagrabelny that reorganizes the
-icons in a slightly more intuitive way.
-\end{itemize}
-\item Minor fixes:
-\begin{itemize}
-\item Setting the {\tt prefer} preference to {\tt older} or {\tt newer} now
-propagates deletions when there is no conflict.
-\item Correctly quote the path when running merge commands.
-\item Add quotes to paths when calling external file watcher utility.
-\item Incorporate a patch to fsmonitor.py (the external filewatcher
- utility) from Tomasz Zernicki to make it work better under Windows.
-\item Incorporated new version of fsmonitor.py from Christophe Gohle
-\item Fixed incompatibility with OpenSSH 5.6.
-\item Fixed fingerprint cache: do not cache file properties
-\item Some spelling corrections in documentation and comments from Stephane
-Glondu
-\item Fixed {\tt O\_APPEND} mode for open under Windows
-\item Fixed String.sub invalid argument error when an AppleDouble file does
- not contain a finder information field
-\item Trim duplicate paths when using "-repeat watch"
-\item Unison now passes path arguments and --follow directives to
- fsmonitor.py. This seems to work except for one small issue with
- how fsmonitor.py treats {\tt -follow} directives for directories that
- don't exist (or maybe this is an issue with how it treats any kind
- of monitoring when the thing being monitored doesn't exist?). If we
- create a symlink to a nonexistent directory, give Unison (hence
- fsmonitor.py) a 'follow' directive for the symlink, start unison, and
- {\em then} create the directory, fsmonitor.py misses the change.
-\item Lines added in profile files by unison always start at a new line
-\end{itemize}
-\end{changesfromversion}
-
-\begin{changesfromversion}{2.40.1}
-\item Added "BelowPath" patterns, that match a path as well as all paths below
- (convenient to use with no{deletion,update,creation}partial preferences)
-\item Added a "fat" preference that makes Unison use the right options
- when one of the replica is on a FAT filesystem.
-\item Allow "prefer/force=newer" even when not synchronizing modification
- times. (The reconciler will not be aware of the modification time
- of unchanged files, so the synchronization choices of Unison can be
- different from when "times=true", but the behavior remains sane:
- changed files with the most recent modification time will be
- propagated.)
-\item Minor fixes and improvements:
-\begin{itemize}
-\item Compare filenames up to decomposition in case sensitive mode when
- one host is running MacOSX and the unicode preference is set to
- true.
-\item Rsync: somewhat faster compressor
-\item Make Unicode the default on all architectures (it was only the
- default when a Mac OS X or Windows machine was involved).
-\end{itemize}
-\end{changesfromversion}
-
-\begin{changesfromversion}{2.32}
-\item Major enhancement: Unicode support.
-\begin{itemize}
-\item Unison should now handle unicode filenames correctly on all platforms.
-\item This functionality is controlled by a new preference {\tt unicode}.
-\item Unicode mode is now the default when one of the hosts is under
- Windows or MacOS. This may make upgrades a bit more painful (the
- archives cannot be reused), but this is a much saner default.
-\end{itemize}
-\item Partial transfer of directories. If an error occurs while
- transferring a directory, the part transferred so far is copied into
- place (and the archives are updated accordingly).
- The "maxerrors" preference controls how many transfer error Unison
- will accept before stopping the transfer of a directory (by default,
- only one). This makes it possible to transfer most of a directory
- even if there are some errors. Currently, only the first error is
- reported by the GUIs.
-
- Also, allow partial transfer of a directory when there was an error deep
- inside this directory during update detection. At the moment, this
- is only activated with the text and GTK UIs, which have been
- modified so that they show that the transfer is going to be partial
- and so that they can display all errors.
-\item Improvement to the code for resuming directory transfers:
-\begin{itemize}
-\item
- if a file was not correctly transferred (or the source has been
- modified since, with unchanged size), Unison performs a new
- transfer rather than failing
- \item spurious files are deleted (this can happen if a file is deleted
- on the source replica before resuming the transfer; not deleting
- the file would result in it reappearing on the target replica)
-\end{itemize}
-\item Experimental streaming protocol for transferring file contents (can
- be disabled by setting the directive "stream" to false): file
- contents is transferred asynchronously (without waiting for a response
- from the destination after each chunk sent) rather than using the
- synchronous RPC mechanism. As a consequence:
- \begin{itemize}
- \item
- Unison now transfers the contents of a single file at a time
- (Unison used to transfer several contents simultaneously in order
- to hide the connection latency.)
- \item the transfer of large files uses the full available bandwidth
- and is not slowed done due to the connection latency anymore
- \item we get performance improvement for small files as well by
- scheduling many files simultaneously (as scheduling a file for
- transfer consume little resource: it does not mean allocating a
- large buffer anymore)
- \end{itemize}
-\item Changes to the internal implementation of the rsync algorithm:
-\begin{itemize}
-\item
- use longer blocks for large files (the size of a block is the
- square root of the size of the file for large files);
- \item transmit less checksum information per block (we still have less
- than one chance in a hundred million of transferring a file
- incorrectly, and Unison will catch any transfer error when
- fingerprinting the whole file)
- \item avoid transfer overhead (which was 4 bytes per block)
-\end{itemize}
- For a 1G file, the first optimization saves a factor 50 on the
- amount of data transferred from the target to the source (blocks
- are 32768 bytes rather than just 700 bytes). The two other
- optimizations save another factor of 2 (from 24 bytes per block
- down to 10).
-\item Implemented an on-disk file fingerprint cache to speed-up update
- detection after a crash: this way, Unison does not have do recompute
- all the file fingerprints from scratch.
- \begin{itemize}
- \item When Unison detects that the archive case-sensitivity mode
- does not match the current settings, it populates the fingerprint
- cache using the archive contents. This way, changing the
- case-sensitivity mode should be reasonably fast.
- \end{itemize}
-\item New preferences "noupdate=root", "nodeletion=root", "nocreation=root"
- that prevent Unison from performing files updates, deletions or
- creations on the given root. Also 'partial' versions of 'noupdate',
- 'nodeletion' and 'nocreation'
-\item Limit the number of simultaneous external copy program
- ("copymax" preference)
-\item New "links" preference. When set to false, Unison will report an
- error on symlinks during update detection. (This is the default
- when one host is running Windows but not Cygwin.) This is better
- than failing during propagation.
-\item Added a preference "halfduplex" to force half-duplex communication
- with the server. This may be useful on unreliable links (as a more
- efficient alternative to "maxthreads = 1").
-\item Renamed preference "pretendwin" to "ignoreinodenumbers" (an alias is
- kept for backwards compatibility).
-\item Ignore one-second differences when synchronizing modification time.
- (Technically, this is an incompatible archive format change, but it
- is backward compatible. To trigger a problem, a user would have to
- synchronize modification times on a filesystem with a two-second
- granularity and then downgrade to a previous version of Unison,
- which does not work well in such a case. Thus, it does not
- seem worthwhile to increment the archive format number, which would
- impact all users.)
-\item Do not keep many files simultaneously opened anymore when the rsync
- algorithm is in use.
-\item Add ``ignorearchives'' preference to ignore existing archives (to
- avoid forcing users to delete them manually, in situations where one
- archive has gotten deleted or corrupted).
-\item Mac OS
-\begin{itemize}
-\item fixed rsync bug which could result in an "index out of bounds"
- error when transferring resource forks.
-\item Fixed bug which made Unison ignore finder information and resource
- fork when compiled to 64bit on Mac OSX.
-\item should now be 64 bit clean (the Growl framework is not up to date,
- though)
-\item Made the bridge between Objective C and Ocaml code GC friendly
- (it was allocating ML values and putting them in an array which
- was not registered with the GC)
-\item use darker grey arrows (patch contributed by Eric Y. Kow)
-\end{itemize}
-\item GTK user interface
-\begin{itemize}
-\item assistant for creating profiles
-\item profile editor
-\item pop up a summary window when the replicas are not fully
- synchronized after transport
-\item display estimated remaining time and transfer rate on the
- progress bar
-\item allow simultaneous selection of several items
-\item Do not reload the preference file before a new update
- detection if it is unchanged
-\item disabled scrolling to the first unfinished item during transport.
- It goes way too fast when lot of small files are synchronized, and it
- makes it impossible to browse the file list during transport.
-\item take into account the "height" preference again
-\item the internal list of selected reconciler item was not always in
- sync with what was displayed (GTK bug?); workaround implemented
-\item Do not display "Looking for change" messages during propagation
- (when checking the targe is unchanged) but only during update detection
-\item Apply patch to fix some crashes in the OSX GUI, thanks to Onne Gorter.
-\end{itemize}
-\item Text UI
-\begin{itemize}
-\item During update detection, display status by updating a single line
-rather than generating a new line of output every so often. Should be less
-confusing.
-\end{itemize}
-\item Windows
-\begin{itemize}
-\item Fastcheck is now the default under Windows. People mostly use NTFS
- nowadays and the Unicode API provides an equivalent to inode numbers
- for this filesystem.
-\item Only use long UNC path for accessing replicas (as '..' is
- not handled with this format of paths, but can be useful)
-\item Windows text UI: now put the console into UTF-8 output mode. This
- is the right thing to do when in Unicode mode, and is no worse than
- what we had previously otherwise (the console use some esoteric
- encoding by default). This only works when using a Unicode font
- instead of the default raster font.
-\item Don't get the home directory from environment variable HOME under
- Windows (except for Cygwin binaries): we don't want the behavior of
- Unison to depends on whether it is run from a Cygwin shell (where
- HOME is set) or in any other way (where HOME is usually not set).
-\end{itemize}
-\item Miscellaneous fixes and improvements
-\begin{itemize}
-\item Made a server waiting on a socket more resilient to unexpected
- lost connections from the client.
-\item Small patch to property setting code suggested by Ulrich Gernkow.
-\item Several fixes to the change transfer functions (both the internal ones
- and external transfers using rsync). In particular, limit the number of
- simultaneous transfer using an rsync
- (as the rsync algorithm can use a large amount of memory when
- processing huge files)
-\item Keep track of which file contents are being transferred, and delay
- the transfer of a file when another file with the same contents is
- currently being transferred. This way, the second transfer can be
- skipped and replaced by a local copy.
-\item Experimental update detection optimization:
- do not read the contents of unchanged directories
-\item When a file transfer fails, turn off fastcheck for this file on the
- next sync.
-\item Fixed bug with case insensitive mode on a case sensitive filesystem:
-\begin{itemize}
-\item
- if file "a/a" is created on one replica and directory "A" is
- created on the other, the file failed to be synchronized the first
- time Unison is run afterwards, as Unison uses the wrong path "a/a"
- (if Unison is run again, the directories are in the archive, so
- the right path is used);
- \item if file "a" appears on one replica and file "A" appears on the
- other with different contents, Unison was unable to synchronize
- them.
-\end{itemize}
-\item Improved error reporting when the destination is updated during
- synchronization: Unison now tells which file has been updated, and how.
-\item Limit the length of temporary file names
-\item Case sensitivity information put in the archive (in a backward
- compatible way) and checked when the archive is loaded
-\item Got rid of the 16mb marshalling limit by marshalling to a bigarray.
-\item Resume copy of partially transferred files.
-\end{itemize}
-\end{changesfromversion}
-
-\begin{changesfromversion}{2.31}
-\item Small user interface changes
-\begin{itemize}
-\item Small change to text UI "scanning..." messages, to print just
- directories (hopefully making it clearer that individual files are
- not necessarily being fingerprinted).
-\end{itemize}
-\item Minor fixes and improvements:
-\begin{itemize}
-\item Ignore one hour differences when deciding whether a file may have
- been updated. This avoids slow update detection after daylight
- saving time changes under Windows. This makes Unison slightly more
- likely to miss an update, but it should be safe enough.
-\item Fix a small bug that was affecting mainly windows users. We need to
- commit the archives at the end of the sync even if there are no
- updates to propagate because some files (in fact, if we've just
- switched to DST on windows, a LOT of files) might have new modtimes
- in the archive. (Changed the text UI only. It's less clear where
- to change the GUI.)
-\item Don't delete the temp file when a transfer fails due to a
- fingerprint mismatch (so that we can have a look and see why!) We've also
- added more debugging code togive more informative error messages when we
- encounter the dreaded and longstanding "assert failed during file
- transfer" bug
-\item Incorrect paths ("path" directive) now result in an error update
- item rather than a fatal error.
-\item Create parent directories (with correct permissions) during
- transport for paths which point to non-existent locations in the
- destination replica.
-\end{itemize}
-\end{changesfromversion}
-
-\begin{changesfromversion}{2.27}
-\item If Unison is interrupted during a directory transfer, it will now
-leave the partially transferred directory intact in a temporary
-location. (This maintains the invariant that new files/directories are
-transferred either completely or not at all.) The next time Unison is run,
-it will continue filling in this temporary directory, skipping transferring
-files that it finds are already there.
-\item We've added experimental support for invoking an external file
-transfer tool for whole-file copies instead of Unison's built-in transfer
-protocol. Three new preferences have been added:
-\begin{itemize}
-\item {\tt copyprog} is a string giving the name (and command-line
-switches, if needed) of an external program that can be used to copy large
-files efficiently. By default, rsync is invoked, but other tools such as
-scp can be used instead by changing the value of this preference. (Although
-this is not its primary purpose, rsync is actually a pretty fast way of
-copying files that don't already exist on the receiving host.) For files
-that do already exist on (but that have been changed in one replica), Unison
-will always use its built-in implementation of the rsync algorithm.
-\item Added a "copyprogrest" preference, so that we can give different
-command lines for invoking the external copy utility depending on whether a
-partially transferred file already exists or not. (Rsync doesn't seem to
-care about this, but other utilities may.)
-\item {\tt copythreshold} is an integer (-1 by default), indicating above what
-filesize (in megabytes) Unison should use the external copying utility
-specified by copyprog. Specifying 0 will cause ALL copies to use the
-external program; a negative number will prevent any files from using it.
-(Default is -1.)
-\end{itemize}
-Thanks to Alan Schmitt for a huge amount of hacking and to an anonymous
-sponsor for suggesting and underwriting this extension.
-\item Small improvements:
-\begin{itemize}
-\item Added a new preference, {\tt dontchmod}. By default, Unison uses the
-{\tt chmod} system call to set the permission bits of files after it has
-copied them. But in some circumstances (and under some operating systems),
-the chmod call always fails. Setting this preference completely prevents
-Unison from ever calling {\tt chmod}.
-\item Don't ignore files that look like backup files if the {\tt
- backuplocation} preference is set to {\tt central}
-\item Shortened the names of several preferences. The old names are also
-still supported, for backwards compatibility, but they do not appear in the
-documentation.
-\item Lots of little documentation tidying. (In particular, preferences are
-separated into Basic and Advanced! This should hopefully make Unison a
-little more approachable for new users.
-\item Unison can sometimes fail to transfer a file, giving the unhelpful
-message "Destination updated during synchronization" even though the file
-has not been changed. This can be caused by programs that change either the
-file's contents \emph{or} the file's extended attributes without changing
-its modification time. It's not clear what is the best fix for this -- it
-is not Unison's fault, but it makes Unison's behavior puzzling -- but at
-least Unison can be more helpful about suggesting a workaround (running once
-with {\tt fastcheck} set to false). The failure message has been changed to
-give this advice.
-\item Further improvements to the OS X GUI (thanks to Alan Schmitt and Craig
-Federighi).
-\end{itemize}
-\item Very preliminary support for triggering Unison from an external
- filesystem-watching utility. The current implementation is very
- simple, not efficient, and almost completely untested---not ready
- for real users. But if someone wants to help improve it (e.g.,
- by writing a filesystem watcher for your favorite OS), please make
- yourself known!
-
- On the Unison side, the new behavior is very simple:
- \begin{itemize}
- \item use the text UI
- \item start Unison with the command-line flag "-repeat FOO",
- where FOO is name of a file where Unison should look
- for notifications of changes
- \item when it starts up, Unison will read the whole contents
- of this file (on both hosts), which should be a
- newline-separated list of paths (relative to the root
- of the synchronization) and synchronize just these paths,
- as if it had been started with the "-path=xxx" option for
- each one of them
- \item when it finishes, it will sleep for a few seconds and then
- examine the watchfile again; if anything has been added, it
- will read the new paths, synchronize them, and go back to
- sleep
- \item that's it!
- \end{itemize}
- To use this to drive Unison "incrementally," just start it in
- this mode and start up a tool (on each host) to watch for
- new changes to the filesystem and append the appropriate paths
- to the watchfile. Hopefully such tools should not be too hard
- to write.
-\item Bug fixes:
-\begin{itemize}
-\item Fixed a bug that was causing new files to be created with
- permissions 0x600 instead of using a reasonable default (like
- 0x644), if the 'perms' flag was set to 0. (Bug reported by Ben
- Crowell.)
-\item Follow maxthreads preference when transferring directories.
-\end{itemize}
-\end{changesfromversion}
-
-\begin{changesfromversion}{2.17}
-\item Major rewrite and cleanup of the whole Mac OS X graphical user
-interface by Craig Federighi. Thanks, Craig!!!
-\item Small fix to ctime (non-)handling in update detection under windows
- with fastcheck.
-\item Several small fixes to the GTK2 UI to make it work better under
-Windows [thanks to Karl M for these].
-\item The backup functionality has been completely rewritten. The external
-interface has not changed, but numerous bugs, irregular behaviors, and
-cross-platform inconsistencies have been corrected.
-\item The Unison project now accepts donations via PayPal. If you'd like to
-donate, you can find a link to the donation page on the
-\URL{http://www.cis.upenn.edu/~bcpierce/unison/lists.html}{Unison home
- page}.
-\item Some important safety improvements:
-\begin{itemize}
-\item Added a new \verb|mountpoint| preference, which can be used to specify
-a path that must exist in both replicas at the end of update detection
-(otherwise Unison aborts). This can be used to avoid potentially dangerous
-situations when Unison is used with removable media such as external hard
-drives and compact flash cards.
-\item The confirmation of ``big deletes'' is now controlled by a boolean preference
- \verb|confirmbigdeletes|. Default is true, which gives the same behavior as
- previously. (This functionality is at least partly superseded by the
- \verb|mountpoint| preference, but it has been left in place in case it is
- useful to some people.)
- \item If Unison is asked to ``follow'' a symbolic link but there is
- nothing at the other end of the link, it will now flag this path as an
- error, rather than treating the symlink itself as missing or deleted.
- This avoids a potentially dangerous situation where a followed symlink
- points to an external filesystem that might be offline when Unison is run
- (whereupon Unison would cheerfully delete the corresponding files in the
- other replica!).
-\end{itemize}
-
-\item Smaller changes:
-\begin{itemize}
-\item Added \verb|forcepartial| and \verb|preferpartial| preferences, which
-behave like \verb|force| and \verb|prefer| but can be specified on a
-per-path basis. [Thanks to Alan Schmitt for this.]
-\item A bare-bones self test feature was added, which runs unison through
- some of its paces and checks that the results are as expected. The
- coverage of the tests is still very limited, but the facility has already
- been very useful in debugging the new backup functionality (especially in
- exposing some subtle cross-platform issues).
-\item Refined debugging code so that the verbosity of individual modules
- can be controlled separately. Instead of just putting '-debug
- verbose' on the command line, you can put '-debug update+', which
- causes all the extra messages in the Update module, but not other
- modules, to be printed. Putting '-debug verbose' causes all modules
- to print with maximum verbosity.
-\item Removed \verb|mergebatch| preference. (It never seemed very useful, and
- its semantics were confusing.)
-\item Rewrote some of the merging functionality, for better cooperation
- with external Harmony instances.
-\item Changed the temp file prefix from \verb|.#| to \verb|.unison|.
-\item Compressed the output from the text user interface (particularly
- when run with the \verb|-terse| flag) to make it easier to interpret the
- results when Unison is run several times in succession from a script.
-\item Diff and merge functions now work under Windows.
-\item Changed the order of arguments to the default diff command (so that
- the + and - annotations in diff's output are reversed).
-\item Added \verb|.mpp| files to the ``never fastcheck'' list (like
-\verb|.xls| files).
-\end{itemize}
-
-\item Many small bugfixes, including:
-\begin{itemize}
-\item Fixed a longstanding bug regarding fastcheck and daylight saving time
- under Windows when Unison is set up to synchronize modification times.
- (Modification times cannot be updated in the archive in this case,
- so we have to ignore one hour differences.)
-\item Fixed a bug that would occasionally cause the archives to be left in
- non-identical states on the two hosts after synchronization.
-\item Fixed a bug that prevented Unison from communicating correctly between
- 32- and 64-bit architectures.
-\item On windows, file creation times are no longer used as a proxy for
- inode numbers. (This is unfortunate, as it makes fastcheck a little less
- safe. But it turns out that file creation times are not reliable
- under Windows: if a file is removed and a new file is created in its
- place, the new one will sometimes be given the same creation date as the
- old one!)
-\item Set read-only file to R/W on OSX before attempting to change other attributes.
-\item Fixed bug resulting in spurious "Aborted" errors during transport
-(thanks to Jerome Vouillon)
-\item Enable diff if file contents have changed in one replica, but
-only properties in the other.
-\item Removed misleading documentation for 'repeat' preference.
-\item Fixed a bug in merging code where Unison could sometimes deadlock
- with the external merge program, if the latter produced large
- amounts of output.
-\item Workaround for a bug compiling gtk2 user interface against current versions
- of gtk2+ libraries.
-\item Added a better error message for "ambiguous paths".
-\item Squashed a longstanding bug that would cause file transfer to fail
- with the message ``Failed: Error in readWrite: Is a directory.''
-\item Replaced symlinks with copies of their targets in the Growl framework in src/uimac.
- This should make the sources easier to check out from the svn repository on WinXP
- systems.
-\item Added a workaround (suggested by Karl M.) for the problem discussed
- on the unison users mailing list where, on the Windows platform, the
- server would hang when transferring files. I conjecture that
- the problem has to do with the RPC mechanism, which was used to
- make a call {\em back} from the server to the client (inside the Trace.log
- function) so that the log message would be appended to the log file on
- the client. The workaround is to dump these messages (about when
- xferbycopying shortcuts are applied and whether they succeed) just to the
- standard output of the Unison process, not to the log file.
-\end{itemize}
-\end{changesfromversion}
-
-\begin{changesfromversion}{2.13.0}
-\item The features for performing backups and for invoking external merge
-programs have been completely rewritten by Stephane Lescuyer (thanks,
-Stephane!). The user-visible functionality should not change, but the
-internals have been rationalized and there are a number of new features.
-See the manual (in particular, the description of the \verb|backupXXX|
-preferences) for details.
-\item Incorporated patches for ipv6 support, contributed by Samuel Thibault.
-(Note that, due to a bug in the released OCaml 3.08.3 compiler, this code
-will not actually work with ipv6 unless compiled with the CVS version of the
-OCaml compiler, where the bug has been fixed; however, ipv4 should continue
-to work normally.)
-\item OSX interface:
-\begin{itemize}
-\item Incorporated Ben Willmore's cool new icon for the Mac UI.
-\end{itemize}
-\item Small fixes:
-\begin{itemize}
-\item Fixed off by one error in month numbers (in printed dates) reported
- by Bob Burger
-\end{itemize}
-\end{changesfromversion}
-
-\begin{changesfromversion}{2.12.0}
-\item New convention for release numbering: Releases will continue to be
-given numbers of the form \verb|X.Y.Z|, but,
-from now on, just the major version number (\verb|X.Y|) will be considered
-significant when checking compatibility between client and server versions.
-The third component of the version number will be used only to identify
-``patch levels'' of releases.
-
-This change goes hand in hand with a change to the procedure for making new
-releases. Candidate releases will initially be given ``beta release''
-status when they are announced for public consumption. Any bugs that are
-discovered will be fixed in a separate branch of the source repository
-(without changing the major version number) and new tarballs re-released as
-needed. When this process converges, the patched beta version will be
-dubbed stable.
-\item Warning (failure in batch mode) when one path is completely emptied.
- This prevents Unison from deleting everything on one replica when
- the other disappear.
-\item Fix diff bug (where no difference is shown the first time the diff
- command is given).
-\item User interface changes:
-\begin{itemize}
-\item Improved workaround for button focus problem (GTK2 UI)
-\item Put leading zeroes in date fields
-\item More robust handling of character encodings in GTK2 UI
-\item Changed format of modification time displays, from \verb|modified at hh:mm:ss on dd MMM, yyyy|
-to \verb|modified on yyyy-mm-dd hh:mm:ss|
-\item Changed time display to include seconds (so that people on FAT
- filesystems will not be confused when Unison tries to update a file
- time to an odd number of seconds and the filesystem truncates it to
- an even number!)
-\item Use the diff "-u" option by default when showing differences between files
- (the output is more readable)
-\item In text mode, pipe the diff output to a pager if the environment
- variable PAGER is set
-\item Bug fixes and cleanups in ssh password prompting. Now works with
- the GTK2 UI under Linux. (Hopefully the Mac OS X one is not broken!)
-\item Include profile name in the GTK2 window name
-\item Added bindings ',' (same as '<') and '.' (same as '>') in the GTK2 UI
-\end{itemize}
-\item Mac GUI:
-\begin{itemize}
-\item actions like < and > scroll to the next item as necessary.
-\item Restart has a menu item and keyboard shortcut (command-R).
-\item
- Added a command-line tool for Mac OS X. It can be installed from
- the Unison menu.
-\item New icon.
-\item Handle the "help" command-line argument properly.
-\item Handle profiles given on the command line properly.
-\item When a profile has been selected, the profile dialog is replaced by a
- "connecting" message while the connection is being made. This
- gives better feedback.
-\item Size of left and right columns is now large enough so that
- "PropsChanged" is not cut off.
-\end{itemize}
-\item Minor changes:
-\begin{itemize}
-\item Disable multi-threading when both roots are local
-\item Improved error handling code. In particular, make sure all files
- are closed in case of a transient failure
-\item Under Windows, use \verb|$UNISON| for home directory as a last resort
- (it was wrongly moved before \verb|$HOME| and \verb|$USERPROFILE| in
- Unison 2.12.0)
-\item Reopen the logfile if its name changes (profile change)
-\item Double-check that permissions and modification times have been
- properly set: there are some combination of OS and filesystem on
- which setting them can fail in a silent way.
-\item Check for bad Windows filenames for pure Windows synchronization
- also (not just cross architecture synchronization).
- This way, filenames containing backslashes, which are not correctly
- handled by unison, are rejected right away.
-\item Attempt to resolve issues with synchronizing modification times
- of read-only files under Windows
-\item Ignore chmod failures when deleting files
-\item Ignore trailing dots in filenames in case insensitive mode
-\item Proper quoting of paths, files and extensions ignored using the UI
-\item The strings CURRENT1 and CURRENT2 are now correctly substitued when
- they occur in the diff preference
-\item Improvements to syncing resource forks between Macs via a non-Mac system.
-\end{itemize}
-\end{changesfromversion}
-
-\begin{changesfromversion}{2.10.2}
-\item \incompatible{} Archive format has changed.
-\item Source code availability: The Unison sources are now managed using
- Subversion. One nice side-effect is that anonymous checkout is now
- possible, like this:
-\begin{verbatim}
- svn co https://cvs.cis.upenn.edu:3690/svnroot/unison/
-\end{verbatim}
-We will also continue to export a ``developer tarball'' of the current
-(modulo one day) sources in the web export directory. To receive commit logs
-for changes to the sources, subscribe to the \verb|unison-hackers| list
-(\ONEURL{http://www.cis.upenn.edu/~bcpierce/unison/lists.html}).
-\item Text user interface:
-\begin{itemize}
-\item Substantial reworking of the internal logic of the text UI to make it
-a bit easier to modify.
-\item The {\tt dumbtty} flag in the text UI is automatically set to true if
-the client is running on a Unix system and the {\tt EMACS} environment
-variable is set to anything other than the empty string.
-\end{itemize}
-\item Native OS X gui:
-\begin{itemize}
-\item Added a synchronize menu item with keyboard shortcut
-\item Added a merge menu item, still needs to be debugged
-\item Fixes to compile for Panther
-\item Miscellaneous improvements and bugfixes
-\end{itemize}
-\item Small changes:
-\begin{itemize}
-\item Changed the filename checking code to apply to Windows only, instead
- of OS X as well.
-\item Finder flags now synchronized
-\item Fallback in copy.ml for filesystem that do not support \verb|O_EXCL|
-\item Changed buffer size for local file copy (was highly inefficient with
- synchronous writes)
-\item Ignore chmod failure when deleting a directory
-\item Fixed assertion failure when resolving a conflict content change /
- permission changes in favor of the content change.
-\item Workaround for transferring large files using rsync.
-\item Use buffered I/O for files (this is the only way to open files in binary
- mode under Cygwin).
-\item On non-Cygwin Windows systems, the UNISON environment variable is now checked first to determine
- where to look for Unison's archive and preference files, followed by \verb|HOME| and
- \verb|USERPROFILE| in that order. On Unix and Cygwin systems, \verb|HOME| is used.
-\item Generalized \verb|diff| preference so that it can be given either as just
- the command name to be used for calculating diffs or else a whole command
- line, containing the strings \verb|CURRENT1| and \verb|CURRENT2|, which will be replaced
- by the names of the files to be diff'ed before the command is called.
-\item Recognize password prompts in some newer versions of ssh.
-\end{itemize}
-\end{changesfromversion}
-
-\begin{changesfromversion}{2.9.20}
-\item \incompatible{} Archive format has changed.
-\item Major functionality changes:
-\begin{itemize}
-\item Major tidying and enhancement of 'merge' functionality. The main
- user-visible change is that the external merge program may either write
- the merged output to a single new file, as before, or it may modify one or
- both of its input files, or it may write {\em two} new files. In the
- latter cases, its modifications will be copied back into place on both the
- local and the remote host, and (if the two files are now equal) the
- archive will be updated appropriately. More information can be found in
- the user manual. Thanks to Malo Denielou and Alan Schmitt for these
- improvements.
-
- Warning: the new merging functionality is not completely compatible with
- old versions! Check the manual for details.
-\item Files larger than 2Gb are now supported.
-\item Added preliminary (and still somewhat experimental) support for the
- Apple OS X operating system.
-\begin{itemize}
-\item Resource forks should be transferred correctly. (See the manual for
-details of how this works when synchronizing HFS with non-HFS volumes.)
-Synchronization of file type and creator information is also supported.
-\item On OSX systems, the name of the directory for storing Unison's
-archives, preference files, etc., is now determined as follows:
-\begin{itemize}
- \item if \verb+~/.unison+ exists, use it
- \item otherwise, use \verb|~/Library/Application Support/Unison|,
- creating it if necessary.
-\end{itemize}
-\item A preliminary native-Cocoa user interface is under construction. This
-still needs some work, and some users experience unpredictable crashes, so
-it is only for hackers for now. Run make with {\tt UISTYLE=mac} to build
-this interface.
-\end{itemize}
-\end{itemize}
-
-\item Minor functionality changes:
-\begin{itemize}
-\item Added an {\tt ignorelocks} preference, which forces Unison to override left-over
- archive locks. (Setting this preference is dangerous! Use it only if you
- are positive you know what you are doing.)
-% BCP: removed later
-% \item Running with the {\tt -timers} flag set to true will now show the total time taken
-% to check for updates on each directory. (This can be helpful for tidying directories to improve
-% update detection times.)
-\item Added a new preference {\tt assumeContentsAreImmutable}. If a directory
- matches one of the patterns set in this preference, then update detection
- is skipped for files in this directory. (The
- purpose is to speed update detection for cases like Mail folders, which
- contain lots and lots of immutable files.) Also a preference
- {\tt assumeContentsAreImmutableNot}, which overrides the first, similarly
- to {\tt ignorenot}. (Later amendment: these preferences are now called
- {\tt immutable} and {\tt immutablenot}.)
-\item The {\tt ignorecase} flag has been changed from a boolean to a three-valued
- preference. The default setting, called {\tt default}, checks the operating systems
- running on the client and server and ignores filename case if either of them is
- OSX or Windows. Setting ignorecase to {\tt true} or {\tt false} overrides
- this behavior. If you have been setting {\tt ignorecase} on the command
- line using {\tt -ignorecase=true} or {\tt -ignorecase=false}, you will
- need to change to {\tt -ignorecase true} or {\tt -ignorecase false}.
-\item a new preference, 'repeat', for the text user interface (only). If 'repeat' is set to
- a number, then, after it finishes synchronizing, Unison will wait for that many seconds and
- then start over, continuing this way until it is killed from outside. Setting repeat to true
- will automatically set the batch preference to true.
-\item Excel files are now handled specially, so that the {\tt fastcheck}
- optimization is skipped even if the {\tt fastcheck} flag is set. (Excel
- does some naughty things with modtimes, making this optimization
- unreliable and leading to failures during change propagation.)
-\item The ignorecase flag has been changed from a boolean to a three-valued
- preference. The default setting, called 'default', checks the operating systems
- running on the client and server and ignores filename case if either of them is
- OSX or Windows. Setting ignorecase to 'true' or 'false' overrides this behavior.
-\item Added a new preference, 'repeat', for the text user interface (only,
- at the moment). If 'repeat' is set to a number, then, after it finishes
- synchronizing, Unison will wait for that many seconds and then start over,
- continuing this way until it is killed from outside. Setting repeat to
- true will automatically set the batch preference to true.
-\item The 'rshargs' preference has been split into 'rshargs' and 'sshargs'
- (mainly to make the documentation clearer). In fact, 'rshargs' is no longer
- mentioned in the documentation at all, since pretty much everybody uses
- ssh now anyway.
-\end{itemize}
-\item Documentation
-\begin{itemize}
-\item The web pages have been completely redesigned and reorganized.
- (Thanks to Alan Schmitt for help with this.)
-\end{itemize}
-\item User interface improvements
-\begin{itemize}
-\item Added a GTK2 user interface, capable (among other things) of displaying filenames
- in any locale encoding. Kudos to Stephen Tse for contributing this code!
-\item The text UI now prints a list of failed and skipped transfers at the end of
- synchronization.
-\item Restarting update detection from the graphical UI will reload the current
- profile (which in particular will reset the -path preference, in case
- it has been narrowed by using the ``Recheck unsynchronized items''
- command).
-\item Several small improvements to the text user interface, including a
- progress display.
-\end{itemize}
-\item Bug fixes (too numerous to count, actually, but here are some):
-\begin{itemize}
-\item The {\tt maxthreads} preference works now.
-\item Fixed bug where warning message about uname returning an unrecognized
- result was preventing connection to server. (The warning is no longer
- printed, and all systems where 'uname' returns anything other than 'Darwin'
- are assumed not to be running OS X.)
-\item Fixed a problem on OS X that caused some valid file names (e.g.,
- those including colons) to be considered invalid.
-\item Patched Path.followLink to follow links under cygwin in addition to Unix
- (suggested by Matt Swift).
-\item Small change to the storeRootsName function, suggested by bliviero at
- ichips.intel.com, to fix a problem in unison with the `rootalias'
- option, which allows you to tell unison that two roots contain the same
- files. Rootalias was being applied after the hosts were
- sorted, so it wouldn't work properly in all cases.
-\item Incorporated a fix by Dmitry Bely for setting utimes of read-only files
- on Win32 systems.
-\end{itemize}
-\item Installation / portability:
-\begin{itemize}
-\item Unison now compiles with OCaml version 3.07 and later out of the box.
-\item Makefile.OCaml fixed to compile out of the box under OpenBSD.
-\item a few additional ports (e.g. OpenBSD, Zaurus/IPAQ) are now mentioned in
- the documentation
-\item Unison can now be installed easily on OSX systems using the Fink
- package manager
-\end{itemize}
-\end{changesfromversion}
-
-\begin{changesfromversion}{2.9.1}
-\item Added a preference {\tt maxthreads} that can be used to limit the
-number of simultaneous file transfers.
-\item Added a {\tt backupdir} preference, which controls where backup
-files are stored.
-\item Basic support added for OSX. In particular, Unison now recognizes
-when one of the hosts being synchronized is running OSX and switches to
-a case-insensitive treatment of filenames (i.e., 'foo' and 'FOO' are
-considered to be the same file).
- (OSX is not yet fully working,
- however: in particular, files with resource forks will not be
- synchronized correctly.)
-\item The same hash used to form the archive name is now also added to
-the names of the temp files created during file transfer. The reason for
-this is that, during update detection, we are going to silently delete
-any old temp files that we find along the way, and we want to prevent
-ourselves from deleting temp files belonging to other instances of Unison
-that may be running in parallel, e.g. synchronizing with a different
-host. Thanks to Ruslan Ermilov for this suggestion.
-\item Several small user interface improvements
-\item Documentation
-\begin{itemize}
-\item FAQ and bug reporting instructions have been split out as separate
- HTML pages, accessible directly from the unison web page.
-\item Additions to FAQ, in particular suggestions about performance
-tuning.
-\end{itemize}
-\item Makefile
-\begin{itemize}
-\item Makefile.OCaml now sets UISTYLE=text or UISTYLE=gtk automatically,
- depending on whether it finds lablgtk installed
-\item Unison should now compile ``out of the box'' under OSX
-\end{itemize}
-\end{changesfromversion}
-
-\begin{changesfromversion}{2.8.1}
-\item Changing profile works again under Windows
-\item File movement optimization: Unison now tries to use local copy instead of
- transfer for moved or copied files. It is controlled by a boolean option
- ``xferbycopying''.
-\item Network statistics window (transfer rate, amount of data transferred).
- [NB: not available in Windows-Cygwin version.]
-\item symlinks work under the cygwin version (which is dynamically linked).
-\item Fixed potential deadlock when synchronizing between Windows and
-Unix
-\item Small improvements:
- \begin{itemize}
- \item If neither the {\tt USERPROFILE} nor the {\tt HOME} environment
- variables are set, then Unison will put its temporary commit log
- (called {\tt DANGER.README}) into the directory named by the
- {\tt UNISON} environment variable, if any; otherwise it will use
- {\tt C:}.
- \item alternative set of values for fastcheck: yes = true; no = false;
- default = auto.
- \item -silent implies -contactquietly
- \end{itemize}
-\item Source code:
- \begin{itemize}
- \item Code reorganization and tidying. (Started breaking up some of the
- basic utility modules so that the non-unison-specific stuff can be
- made available for other projects.)
- \item several Makefile and docs changes (for release);
- \item further comments in ``update.ml'';
- \item connection information is not stored in global variables anymore.
- \end{itemize}
-\end{changesfromversion}
-
-\begin{changesfromversion}{2.7.78}
-\item Small bugfix to textual user interface under Unix (to avoid leaving
- the terminal in a bad state where it would not echo inputs after Unison
- exited).
-\end{changesfromversion}
-
-\begin{changesfromversion}{2.7.39}
-\item Improvements to the main web page (stable and beta version docs are
- now both accessible).
-\item User manual revised.
-\item Added some new preferences:
-\begin{itemize}
-\item ``sshcmd'' and ``rshcmd'' for specifying paths to ssh and rsh programs.
-\item ``contactquietly'' for suppressing the ``contacting server'' message
-during Unison startup (under the graphical UI).
-\end{itemize}
-\item Bug fixes:
-\begin{itemize}
-\item Fixed small bug in UI that neglected to change the displayed column
- headers if loading a new profile caused the roots to change.
-\item Fixed a bug that would put the text UI into an infinite loop if it
- encountered a conflict when run in batch mode.
-\item Added some code to try to fix the display of non-Ascii characters in
- filenames on Windows systems in the GTK UI. (This code is currently
- untested---if you're one of the people that had reported problems with
- display of non-ascii filenames, we'd appreciate knowing if this actually
- fixes things.)
-\item `\verb|-prefer/-force newer|' works properly now.
- (The bug was reported by Sebastian Urbaniak and Sean Fulton.)
-\end{itemize}
-\item User interface and Unison behavior:
-\begin{itemize}
-\item Renamed `Proceed' to `Go' in the graphical UI.
-\item Added exit status for the textual user interface.
-\item Paths that are not synchronized because of conflicts or errors during
- update detection are now noted in the log file.
-\item \verb|[END]| messages in log now use a briefer format
-\item Changed the text UI startup sequence so that
- {\tt ./unison -ui text} will use the default profile instead of failing.
-\item Made some improvements to the error messages.
-\item Added some debugging messages to remote.ml.
-\end{itemize}
-\end{changesfromversion}
-
-\begin{changesfromversion}{2.7.7}
-\item Incorporated, once again, a multi-threaded transport sub-system.
- It transfers several files at the same time, thereby making much
- more effective use of available network bandwidth. Unlike the
- earlier attempt, this time we do not rely on the native thread
- library of OCaml. Instead, we implement a light-weight,
- non-preemptive multi-thread library in OCaml directly. This version
- appears stable.
-
- Some adjustments to unison are made to accommodate the multi-threaded
- version. These include, in particular, changes to the
- user interface and logging, for example:
- \begin{itemize}
- \item Two log entries for each transferring task, one for the
- beginning, one for the end.
- \item Suppressed warning messages against removing temp files left
- by a previous unison run, because warning does not work nicely
- under multi-threading. The temp file names are made less likely
- to coincide with the name of a file created by the user. They
- take the form \\ \verb|.#<filename>.<serial>.unison.tmp|.
- [N.b. This was later changed to \verb|.unison.<filename>.<serial>.unison.tmp|.]
- \end{itemize}
-\item Added a new command to the GTK user interface: pressing 'f' causes
- Unison to start a new update detection phase, using as paths {\em just}
- those paths that have been detected as changed and not yet marked as
- successfully completed. Use this command to quickly restart Unison on
- just the set of paths still needing attention after a previous run.
-\item Made the {\tt ignorecase} preference user-visible, and changed the
- initialization code so that it can be manually set to true, even if
- neither host is running Windows. (This may be useful, e.g., when using
- Unison running on a Unix system with a FAT volume mounted.)
-\item Small improvements and bug fixes:
- \begin{itemize}
- \item Errors in preference files now generate fatal errors rather than
- warnings at startup time. (I.e., you can't go on from them.) Also,
- we fixed a bug that was preventing these warnings from appearing in the
- text UI, so some users who have been running (unsuspectingly) with
- garbage in their prefs files may now get error reports.
- \item Error reporting for preference files now provides file name and
- line number.
- \item More intelligible message in the case of identical change to the same
- files: ``Nothing to do: replicas have been changed only in identical
- ways since last sync.''
- \item Files with prefix '.\#' excluded when scanning for preference
- files.
- \item Rsync instructions are send directly instead of first
- marshaled.
- \item Won't try forever to get the fingerprint of a continuously changing file:
- unison will give up after certain number of retries.
- \item Other bug fixes, including the one reported by Peter Selinger
- (\verb|force=older preference| not working).
- \end{itemize}
-\item Compilation:
- \begin{itemize}
- \item Upgraded to the new OCaml 3.04 compiler, with the LablGtk
- 1.2.3 library (patched version used for compiling under Windows).
- \item Added the option to compile unison on the Windows platform with
- Cygwin GNU C compiler. This option only supports building
- dynamically linked unison executables.
- \end{itemize}
-\end{changesfromversion}
-
-\begin{changesfromversion}{2.7.4}
-\item Fixed a silly (but debilitating) bug in the client startup sequence.
-\end{changesfromversion}
-
-\begin{changesfromversion}{2.7.1}
-\item Added \verb|addprefsto| preference, which (when set) controls which
-preference file new preferences (e.g. new ignore patterns) are added to.
-\item Bug fix: read the initial connection header one byte at a time, so
-that we don't block if the header is shorter than expected. (This bug
-did not affect normal operation --- it just made it hard to tell when you
-were trying to use Unison incorrectly with an old version of the server,
-since it would hang instead of giving an error message.)
-\end{changesfromversion}
-
-\begin{changesfromversion}{2.6.59}
-\item Changed \verb|fastcheck| from a boolean to a string preference. Its
- legal values are \verb|yes| (for a fast check), \verb|no| (for a safe
- check), or \verb|default| (for a fast check---which also happens to be
- safe---when running on Unix and a safe check when on Windows). The default
- is \verb|default|.
- \item Several preferences have been renamed for consistency. All
- preference names are now spelled out in lowercase. For backward
- compatibility, the old names still work, but they are not mentioned in
- the manual any more.
-\item The temp files created by the 'diff' and 'merge' commands are now
- named by {\em pre}pending a new prefix to the file name, rather than
- appending a suffix. This should avoid confusing diff/merge programs
- that depend on the suffix to guess the type of the file contents.
-\item We now set the keepalive option on the server socket, to make sure
- that the server times out if the communication link is unexpectedly broken.
-\item Bug fixes:
-\begin{itemize}
-\item When updating small files, Unison now closes the destination file.
-\item File permissions are properly updated when the file is behind a
- followed link.
-\item Several other small fixes.
-\end{itemize}
-\end{changesfromversion}
-
-
-\begin{changesfromversion}{2.6.38}
-\item Major Windows performance improvement!
-
-We've added a preference \verb|fastcheck| that makes Unison look only at
-a file's creation time and last-modified time to check whether it has
-changed. This should result in a huge speedup when checking for updates
-in large replicas.
-
- When this switch is set, Unison will use file creation times as
- 'pseudo inode numbers' when scanning Windows replicas for updates,
- instead of reading the full contents of every file. This may cause
- Unison to miss propagating an update if the create time,
- modification time, and length of the file are all unchanged by
- the update (this is not easy to achieve, but it can be done).
- However, Unison will never {\em overwrite} such an update with
- a change from the other replica, since it
- always does a safe check for updates just before propagating a
- change. Thus, it is reasonable to use this switch most of the time
- and occasionally run Unison once with {\tt fastcheck} set to false,
- if you are worried that Unison may have overlooked an update.
-
- Warning: This change is has not yet been thoroughly field-tested. If you
- set the \verb|fastcheck| preference, pay careful attention to what
- Unison is doing.
-
-\item New functionality: centralized backups and merging
-\begin{itemize}
-\item This version incorporates two pieces of major new functionality,
- implemented by Sylvain Roy during a summer internship at Penn: a
- {\em centralized backup} facility that keeps a full backup of
- (selected files
- in) each replica, and a {\em merging} feature that allows Unison to
- invoke an external file-merging tool to resolve conflicting changes to
- individual files.
-
-\item Centralized backups:
-\begin{itemize}
- \item Unison now maintains full backups of the last-synchronized versions
- of (some of) the files in each replica; these function both as
- backups in the usual sense
- and as the ``common version'' when invoking external
- merge programs.
- \item The backed up files are stored in a directory ~/.unison/backup on each
- host. (The name of this directory can be changed by setting
- the environment variable \verb|UNISONBACKUPDIR|.)
- \item The predicate \verb|backup| controls which files are actually
- backed up:
- giving the preference '\verb|backup = Path *|' causes backing up
- of all files.
- \item Files are added to the backup directory whenever unison updates
- its archive. This means that
- \begin{itemize}
- \item When unison reconstructs its archive from scratch (e.g.,
- because of an upgrade, or because the archive files have
- been manually deleted), all files will be backed up.
- \item Otherwise, each file will be backed up the first time unison
- propagates an update for it.
- \end{itemize}
- \item The preference \verb|backupversions| controls how many previous
- versions of each file are kept. The default is 2 (i.e., the last
- synchronized version plus one backup).
- \item For backward compatibility, the \verb|backups| preference is also
- still supported, but \verb|backup| is now preferred.
- \item It is OK to manually delete files from the backup directory (or to throw
- away the directory itself). Before unison uses any of these files for
- anything important, it checks that its fingerprint matches the one
- that it expects.
-\end{itemize}
-
-\item Merging:
-\begin{itemize}
- \item Both user interfaces offer a new 'merge' command, invoked by pressing
- 'm' (with a changed file selected).
- \item The actual merging is performed by an external program.
- The preferences \verb|merge| and \verb|merge2| control how this
- program is invoked. If a backup exists for this file (see the
- \verb|backup| preference), then the \verb|merge| preference is used for
- this purpose; otherwise \verb|merge2| is used. In both cases, the
- value of the preference should be a string representing the command
- that should be passed to a shell to invoke the
- merge program. Within this string, the special substrings
- \verb|CURRENT1|, \verb|CURRENT2|, \verb|NEW|, and \verb|OLD| may appear
- at any point. Unison will substitute these as follows before invoking
- the command:
- \begin{itemize}
- \item \relax\verb|CURRENT1| is replaced by the name of the local
- copy of the file;
- \item \relax\verb|CURRENT2| is replaced by the name of a temporary
- file, into which the contents of the remote copy of the file have
- been transferred by Unison prior to performing the merge;
- \item \relax\verb|NEW| is replaced by the name of a temporary
- file that Unison expects to be written by the merge program when
- it finishes, giving the desired new contents of the file; and
- \item \relax\verb|OLD| is replaced by the name of the backed up
- copy of the original version of the file (i.e., its state at the
- end of the last successful run of Unison), if one exists
- (applies only to \verb|merge|, not \verb|merge2|).
- \end{itemize}
- For example, on Unix systems setting the \verb|merge| preference to
-\begin{verbatim}
- merge = diff3 -m CURRENT1 OLD CURRENT2 > NEW
-\end{verbatim}
- will tell Unison to use the external \verb|diff3| program for merging.
-
- A large number of external merging programs are available. For
- example, \verb|emacs| users may find the following convenient:
-\begin{verbatim}
- merge2 = emacs -q --eval '(ediff-merge-files "CURRENT1" "CURRENT2"
- nil "NEW")'
- merge = emacs -q --eval '(ediff-merge-files-with-ancestor
- "CURRENT1" "CURRENT2" "OLD" nil "NEW")'
-\end{verbatim}
-(These commands are displayed here on two lines to avoid running off the
-edge of the page. In your preference file, each should be written on a
-single line.)
-
- \item If the external program exits without leaving any file at the
- path \verb|NEW|,
- Unison considers the merge to have failed. If the merge program writes
- a file called \verb|NEW| but exits with a non-zero status code,
- then Unison
- considers the merge to have succeeded but to have generated conflicts.
- In this case, it attempts to invoke an external editor so that the
- user can resolve the conflicts. The value of the \verb|editor|
- preference controls what editor is invoked by Unison. The default
- is \verb|emacs|.
-
- \item Please send us suggestions for other useful values of the
- \verb|merge2| and \verb|merge| preferences -- we'd like to give several
- examples in the manual.
-\end{itemize}
-\end{itemize}
-
-\item Smaller changes:
-\begin{itemize}
-\item When one preference file includes another, unison no longer adds the
- suffix '\verb|.prf|' to the included file by default. If a file with
- precisely the given name exists in the .unison directory, it will be used;
- otherwise Unison will
- add \verb|.prf|, as it did before. (This change means that included
- preference files can be named \verb|blah.include| instead of
- \verb|blah.prf|, so that unison will not offer them in its 'choose
- a preference file' dialog.)
-\item For Linux systems, we now offer both a statically linked and a dynamically
- linked executable. The static one is larger, but will probably run on more
- systems, since it doesn't depend on the same versions of dynamically
- linked library modules being available.
-\item Fixed the \verb|force| and \verb|prefer| preferences, which were
- getting the propagation direction exactly backwards.
-\item Fixed a bug in the startup code that would cause unison to crash
- when the default profile (\verb|~/.unison/default.prf|) does not exist.
-\item Fixed a bug where, on the run when a profile is first created,
- Unison would confusingly display the roots in reverse order in the user
- interface.
-\end{itemize}
-
-\item For developers:
-\begin{itemize}
-\item We've added a module dependency diagram to the source distribution, in
- \verb|src/DEPENDENCIES.ps|, to help new prospective developers with
- navigating the code.
-\end{itemize}
-\end{changesfromversion}
-
-\begin{changesfromversion}{2.6.11}
-\item \incompatible{} Archive format has changed.
-
-\item \incompatible{} The startup sequence has been completely rewritten
-and greatly simplified. The main user-visible change is that the
-\verb|defaultpath| preference has been removed. Its effect can be
-approximated by using multiple profiles, with \verb|include| directives
-to incorporate common settings. All uses of \verb|defaultpath| in
-existing profiles should be changed to \verb|path|.
-
-Another change in startup behavior that will affect some users is that it
-is no longer possible to specify roots {\em both} in the profile {\em
- and} on the command line.
-
-You can achieve a similar effect, though, by breaking your profile into
-two:
-\begin{verbatim}
-
- default.prf =
- root = blah
- root = foo
- include common
-
- common.prf =
- <everything else>
-\end{verbatim}
-Now do
-\begin{verbatim}
- unison common root1 root2
-\end{verbatim}
-when you want to specify roots explicitly.
-
-\item The \verb|-prefer| and \verb|-force| options have been extended to
-allow users to specify that files with more recent modtimes should be
-propagated, writing either \verb|-prefer newer| or \verb|-force newer|.
-(For symmetry, Unison will also accept \verb|-prefer older| or
-\verb|-force older|.) The \verb|-force older/newer| options can only be
-used when \verb|-times| is also set.
-
-The graphical user interface provides access to these facilities on a
-one-off basis via the \verb|Actions| menu.
-
-\item Names of roots can now be ``aliased'' to allow replicas to be
-relocated without changing the name of the archive file where Unison
-stores information between runs. (This feature is for experts only. See
-the ``Archive Files'' section of the manual for more information.)
-
-\item Graphical user-interface:
-\begin{itemize}
-\item A new command is provided in the Synchronization menu for
- switching to a new profile without restarting Unison from scratch.
-\item The GUI also supports one-key shortcuts for commonly
-used profiles. If a profile contains a preference of the form
-%
-'\verb|key = n|', where \verb|n| is a single digit, then pressing this
-key will cause Unison to immediately switch to this profile and begin
-synchronization again from scratch. (Any actions that may have been
-selected for a set of changes currently being displayed will be
-discarded.)
-
-\item Each profile may include a preference '\verb|label = <string>|' giving a
- descriptive string that described the options selected in this profile.
- The string is listed along with the profile name in the profile selection
- dialog, and displayed in the top-right corner of the main Unison window.
-\end{itemize}
-
-\item Minor:
-\begin{itemize}
-\item Fixed a bug that would sometimes cause the 'diff' display to order
- the files backwards relative to the main user interface. (Thanks
- to Pascal Brisset for this fix.)
-\item On Unix systems, the graphical version of Unison will check the
- \verb|DISPLAY| variable and, if it is not set, automatically fall back
- to the textual user interface.
-\item Synchronization paths (\verb|path| preferences) are now matched
- against the ignore preferences. So if a path is both specified in a
- \verb|path| preference and ignored, it will be skipped.
-\item Numerous other bugfixes and small improvements.
-\end{itemize}
-\end{changesfromversion}
-
-\begin{changesfromversion}{2.6.1}
-\item The synchronization of modification times has been disabled for
- directories.
-
-\item Preference files may now include lines of the form
- \verb+include <name>+, which will cause \verb+name.prf+ to be read
- at that point.
-
-\item The synchronization of permission between Windows and Unix now
- works properly.
-
-\item A binding \verb|CYGWIN=binmode| in now added to the environment
- so that the Cygwin port of OpenSSH works properly in a non-Cygwin
- context.
-
-\item The \verb|servercmd| and \verb|addversionno| preferences can now
- be used together: \verb|-addversionno| appends an appropriate
- \verb+-NNN+ to the server command, which is found by using the value
- of the \verb|-servercmd| preference if there is one, or else just
- \verb|unison|.
-
-\item Both \verb|'-pref=val'| and \verb|'-pref val'| are now allowed for
- boolean values. (The former can be used to set a preference to false.)
-
-\item Lot of small bugs fixed.
-\end{changesfromversion}
-
-\begin{changesfromversion}{2.5.31}
-\item The \verb|log| preference is now set to \verb|true| by default,
- since the log file seems useful for most users.
-\item Several miscellaneous bugfixes (most involving symlinks).
-\end{changesfromversion}
-
-\begin{changesfromversion}{2.5.25}
-\item \incompatible{} Archive format has changed (again).
-
-\item Several significant bugs introduced in 2.5.25 have been fixed.
-\end{changesfromversion}
-
-\begin{changesfromversion}{2.5.1}
-\item \incompatible{} Archive format has changed. Make sure you
-synchronize your replicas before upgrading, to avoid spurious
-conflicts. The first sync after upgrading will be slow.
-
-\item New functionality:
-\begin{itemize}
-\item Unison now synchronizes file modtimes, user-ids, and group-ids.
-
-These new features are controlled by a set of new preferences, all of
-which are currently \verb|false| by default.
-
-\begin{itemize}
-\item When the \verb|times| preference is set to \verb|true|, file
-modification times are propaged. (Because the representations of time
-may not have the same granularity on both replicas, Unison may not always
-be able to make the modtimes precisely equal, but it will get them as
-close as the operating systems involved allow.)
-\item When the \verb|owner| preference is set to \verb|true|, file
-ownership information is synchronized.
-\item When the \verb|group| preference is set to \verb|true|, group
-information is synchronized.
-\item When the \verb|numericIds| preference is set to \verb|true|, owner
-and group information is synchronized numerically. By default, owner and
-group numbers are converted to names on each replica and these names are
-synchronized. (The special user id 0 and the special group 0 are never
-mapped via user/group names even if this preference is not set.)
-\end{itemize}
-
-\item Added an integer-valued preference \verb|perms| that can be used to
-control the propagation of permission bits. The value of this preference
-is a mask indicating which permission bits should be synchronized. It is
-set by default to $0o1777$: all bits but the set-uid and set-gid bits are
-synchronised (synchronizing theses latter bits can be a security hazard).
-If you want to synchronize all bits, you can set the value of this
-preference to $-1$.
-
-\item Added a \verb|log| preference (default \verb|false|), which makes
-Unison keep a complete record of the changes it makes to the replicas.
-By default, this record is written to a file called \verb|unison.log| in
-the user's home directory (the value of the \verb|HOME| environment
-variable). If you want it someplace else, set the \verb|logfile|
-preference to the full pathname you want Unison to use.
-
-\item Added an \verb|ignorenot| preference that maintains a set of patterns
- for paths that should definitely {\em not} be ignored, whether or not
- they match an \verb|ignore| pattern. (That is, a path will now be ignored
- iff it matches an ignore pattern and does not match any ignorenot patterns.)
-\end{itemize}
-
-\item User-interface improvements:
-\begin{itemize}
-\item Roots are now displayed in the user interface in the same order
-as they were given on the command line or in the preferences file.
-\item When the \verb|batch| preference is set, the graphical user interface no
- longer waits for user confirmation when it displays a warning message: it
- simply pops up an advisory window with a Dismiss button at the bottom and
- keeps on going.
-\item Added a new preference for controlling how many status messages are
- printed during update detection: \verb|statusdepth| controls the maximum
- depth for paths on the local machine (longer paths are not displayed, nor
- are non-directory paths). The value should be an integer; default is 1.
-\item Removed the \verb|trace| and \verb|silent| preferences. They did
-not seem very useful, and there were too many preferences for controlling
-output in various ways.
-\item The text UI now displays just the default command (the one that
-will be used if the user just types \verb|<return>|) instead of all
-available commands. Typing \verb|?| will print the full list of
-possibilities.
-\item The function that finds the canonical hostname of the local host
-(which is used, for example, in calculating the name of the archive file
-used to remember which files have been synchronized) normally uses the
-\verb|gethostname| operating system call. However, if the environment
-variable \verb|UNISONLOCALHOSTNAME| is set, its value will now be used
-instead. This makes it easier to use Unison in situations where a
-machine's name changes frequently (e.g., because it is a laptop and gets
-moved around a lot).
-\item File owner and group are now displayed in the ``detail window'' at
-the bottom of the screen, when unison is configured to synchronize them.
-\end{itemize}
-
-\item For hackers:
-\begin{itemize}
-\item Updated to Jacques Garrigue's new version of \verb|lablgtk|, which
- means we can throw away our local patched version.
-
- If you're compiling the GTK version of unison from sources, you'll need
- to update your copy of lablgtk to the developers release.
- (Warning: installing lablgtk under Windows is currently a bit
- challenging.)
-
-\item The TODO.txt file (in the source distribution) has been cleaned up
-and reorganized. The list of pending tasks should be much easier to
-make sense of, for people that may want to contribute their programming
-energies. There is also a separate file BUGS.txt for open bugs.
-\item The Tk user interface has been removed (it was not being maintained
-and no longer compiles).
-\item The \verb|debug| preference now prints quite a bit of additional
-information that should be useful for identifying sources of problems.
-\item The version number of the remote server is now checked right away
- during the connection setup handshake, rather than later. (Somebody
- sent a bug report of a server crash that turned out to come from using
- inconsistent versions: better to check this earlier and in a way that
- can't crash either client or server.)
-\item Unison now runs correctly on 64-bit architectures (e.g. Alpha
-linux). We will not be distributing binaries for these architectures
-ourselves (at least for a while) but if someone would like to make them
-available, we'll be glad to provide a link to them.
-\end{itemize}
-
-\item Bug fixes:
-\begin{itemize}
-\item Pattern matching (e.g. for \verb|ignore|) is now case-insensitive
- when Unison is in case-insensitive mode (i.e., when one of the replicas
- is on a windows machine).
-\item Some people had trouble with mysterious failures during
- propagation of updates, where files would be falsely reported as having
- changed during synchronization. This should be fixed.
-\item Numerous smaller fixes.
-\end{itemize}
-\end{changesfromversion}
-
-\begin{changesfromversion}{2.4.1}
-\item Added a number of 'sorting modes' for the user interface. By
-default, conflicting changes are displayed at the top, and the rest of
-the entries are sorted in alphabetical order. This behavior can be
-changed in the following ways:
-\begin{itemize}
-\item Setting the \verb|sortnewfirst| preference to \verb|true| causes
-newly created files to be displayed before changed files.
-\item Setting \verb|sortbysize| causes files to be displayed in
-increasing order of size.
-\item Giving the preference \verb|sortfirst=<pattern>| (where
-\verb|<pattern>| is a path descriptor in the same format as 'ignore' and 'follow'
-patterns, causes paths matching this pattern to be displayed first.
-\item Similarly, giving the preference \verb|sortlast=<pattern>|
-causes paths matching this pattern to be displayed last.
-\end{itemize}
-The sorting preferences are described in more detail in the user manual.
-The \verb|sortnewfirst| and \verb|sortbysize| flags can also be accessed
-from the 'Sort' menu in the grpahical user interface.
-
-\item Added two new preferences that can be used to change unison's
-fundamental behavior to make it more like a mirroring tool instead of
-a synchronizer.
-\begin{itemize}
-\item Giving the preference \verb|prefer| with argument \verb|<root>|
-(by adding \verb|-prefer <root>| to the command line or \verb|prefer=<root>|)
-to your profile) means that, if there is a conflict, the contents of
-\verb|<root>|
-should be propagated to the other replica (with no questions asked).
-Non-conflicting changes are treated as usual.
-\item Giving the preference \verb|force| with argument \verb|<root>|
-will make unison resolve {\em all} differences in favor of the given
-root, even if it was the other replica that was changed.
-\end{itemize}
-These options should be used with care! (More information is available in
-the manual.)
-
-\item Small changes:
-\begin{itemize}
-\item
-Changed default answer to 'Yes' in all two-button dialogs in the
- graphical interface (this seems more intuitive).
-
-\item The \verb|rsync| preference has been removed (it was used to
-activate rsync compression for file transfers, but rsync compression is
-now enabled by default).
-\item In the text user interface, the arrows indicating which direction
-changes are being
- propagated are printed differently when the user has overridden Unison's
- default recommendation (\verb|====>| instead of \verb|---->|). This
- matches the behavior of the graphical interface, which displays such
- arrows in a different color.
-\item Carriage returns (Control-M's) are ignored at the ends of lines in
- profiles, for Windows compatibility.
-\item All preferences are now fully documented in the user manual.
-\end{itemize}
-\end{changesfromversion}
-
-\begin{changesfromversion}{2.3.12}
-\item \incompatible{} Archive format has changed. Make sure you
-synchronize your replicas before upgrading, to avoid spurious
-conflicts. The first sync after upgrading will be slow.
-
-\item New/improved functionality:
-\begin{itemize}
-\item A new preference -sortbysize controls the order in which changes
- are displayed to the user: when it is set to true, the smallest
- changed files are displayed first. (The default setting is false.)
-\item A new preference -sortnewfirst causes newly created files to be
- listed before other updates in the user interface.
-\item We now allow the ssh protocol to specify a port.
-\item Incompatible change: The unison: protocol is deprecated, and we added
- file: and socket:. You may have to modify your profiles in the
- .unison directory.
- If a replica is specified without an explicit protocol, we now
- assume it refers to a file. (Previously "//saul/foo" meant to use
- SSH to connect to saul, then access the foo directory. Now it means
- to access saul via a remote file mechanism such as samba; the old
- effect is now achieved by writing {\tt ssh://saul/foo}.)
-\item Changed the startup sequence for the case where roots are given but
- no profile is given on the command line. The new behavior is to
- use the default profile (creating it if it does not exist), and
- temporarily override its roots. The manual claimed that this case
- would work by reading no profile at all, but AFAIK this was never
- true.
-\item In all user interfaces, files with conflicts are always listed first
-\item A new preference 'sshversion' can be used to control which version
- of ssh should be used to connect to the server. Legal values are 1 and 2.
- (Default is empty, which will make unison use whatever version of ssh
- is installed as the default 'ssh' command.)
-\item The situation when the permissions of a file was updated the same on
- both side is now handled correctly (we used to report a spurious conflict)
-
-\end{itemize}
-
-\item Improvements for the Windows version:
-\begin{itemize}
-\item The fact that filenames are treated case-insensitively under
-Windows should now be handled correctly. The exact behavior is described
-in the cross-platform section of the manual.
-\item It should be possible to synchronize with Windows shares, e.g.,
- //host/drive/path.
-\item Workarounds to the bug in syncing root directories in Windows.
-The most difficult thing to fix is an ocaml bug: Unix.opendir fails on
-c: in some versions of Windows.
-\end{itemize}
-
-\item Improvements to the GTK user interface (the Tk interface is no
-longer being maintained):
-\begin{itemize}
-\item The UI now displays actions differently (in blue) when they have been
- explicitly changed by the user from Unison's default recommendation.
-\item More colorful appearance.
-\item The initial profile selection window works better.
-\item If any transfers failed, a message to this effect is displayed along with
- 'Synchronization complete' at the end of the transfer phase (in case they
- may have scrolled off the top).
-\item Added a global progress meter, displaying the percentage of {\em total}
- bytes that have been transferred so far.
-\end{itemize}
-
-\item Improvements to the text user interface:
-\begin{itemize}
-\item The file details will be displayed automatically when a
- conflict is been detected.
-\item when a warning is generated (e.g. for a temporary
- file left over from a previous run of unison) Unison will no longer
- wait for a response if it is running in -batch mode.
-\item The UI now displays a short list of possible inputs each time it waits
- for user interaction.
-\item The UI now quits immediately (rather than looping back and starting
- the interaction again) if the user presses 'q' when asked whether to
- propagate changes.
-\item Pressing 'g' in the text user interface will proceed immediately
- with propagating updates, without asking any more questions.
-\end{itemize}
-
-\item Documentation and installation changes:
-\begin{itemize}
-\item The manual now includes a FAQ, plus sections on common problems and
-on tricks contributed by users.
-\item Both the download page and the download directory explicitly say
-what are the current stable and beta-test version numbers.
-\item The OCaml sources for the up-to-the-minute developers' version (not
-guaranteed to be stable, or even to compile, at any given time!) are now
-available from the download page.
-\item Added a subsection to the manual describing cross-platform
- issues (case conflicts, illegal filenames)
-\end{itemize}
-
-\item Many small bug fixes and random improvements.
-
-\end{changesfromversion}
-
-\begin{changesfromversion}{2.3.1}
-\item Several bug fixes. The most important is a bug in the rsync
-module that would occasionally cause change propagation to fail with a
-'rename' error.
-\end{changesfromversion}
-
-\begin{changesfromversion}{2.2}
-\item The multi-threaded transport system is now disabled by default.
-(It is not stable enough yet.)
-\item Various bug fixes.
-\item A new experimental feature:
-
- The final component of a -path argument may now be the wildcard
- specifier \verb|*|. When Unison sees such a path, it expands this path on
- the client into into the corresponding list of paths by listing the
- contents of that directory.
-
- Note that if you use wildcard paths from the command line, you will
- probably need to use quotes or a backslash to prevent the * from
- being interpreted by your shell.
-
- If both roots are local, the contents of the first one will be used
- for expanding wildcard paths. (Nb: this is the first one {\em after} the
- canonization step -- i.e., the one that is listed first in the user
- interface -- not the one listed first on the command line or in the
- preferences file.)
-\end{changesfromversion}
-
-\begin{changesfromversion}{2.1}
-\item The transport subsystem now includes an implementation by
-Sylvain Gommier and Norman Ramsey of Tridgell and Mackerras's
-\verb|rsync| protocol. This protocol achieves much faster
-transfers when only a small part of a large file has been changed by
-sending just diffs. This feature is mainly helpful for transfers over
-slow links---on fast local area networks it can actually degrade
-performance---so we have left it off by default. Start unison with
-the \verb|-rsync| option (or put \verb|rsync=true| in your preferences
-file) to turn it on.
-
-\item ``Progress bars'' are now displayed during remote file transfers,
-showing what percentage of each file has been transferred so far.
-
-\item The version numbering scheme has changed. New releases will now
- be have numbers like 2.2.30, where the second component is
- incremented on every significant public release and the third
- component is the ``patch level.''
-
-\item Miscellaneous improvements to the GTK-based user interface.
-\item The manual is now available in PDF format.
-
-\item We are experimenting with using a multi-threaded transport
-subsystem to transfer several files at the same time, making
-much more effective use of available network bandwidth. This feature
-is not completely stable yet, so by default it is disabled in the
-release version of Unison.
-
-If you want to play with the multi-threaded version, you'll need to
-recompile Unison from sources (as described in the documentation),
-setting the THREADS flag in Makefile.OCaml to true. Make sure that
-your OCaml compiler has been installed with the \verb|-with-pthreads|
-configuration option. (You can verify this by checking whether the
-file \verb|threads/threads.cma| in the OCaml standard library
-directory contains the string \verb|-lpthread| near the end.)
-\end{changesfromversion}
-
-\begin{changesfromversion}{1.292}
-\item Reduced memory footprint (this is especially important during
-the first run of unison, where it has to gather information about all
-the files in both repositories).
-\item Fixed a bug that would cause the socket server under NT to fail
- after the client exits.
-\item Added a SHIFT modifier to the Ignore menu shortcut keys in GTK
- interface (to avoid hitting them accidentally).
-\end{changesfromversion}
-
-\begin{changesfromversion}{1.231}
-\item Tunneling over ssh is now supported in the Windows version. See
-the installation section of the manual for detailed instructions.
-
-\item The transport subsystem now includes an implementation of the
-\verb|rsync| protocol, built by Sylvain Gommier and Norman Ramsey.
-This protocol achieves much faster transfers when only a small part of
-a large file has been changed by sending just diffs. The rsync
-feature is off by default in the current version. Use the
-\verb|-rsync| switch to turn it on. (Nb. We still have a lot of
-tuning to do: you may not notice much speedup yet.)
-
-\item We're experimenting with a multi-threaded transport subsystem,
-written by Jerome Vouillon. The downloadable binaries are still
-single-threaded: if you want to try the multi-threaded version, you'll
-need to recompile from sources. (Say \verb|make THREADS=true|.)
-Native thread support from the compiler is required. Use the option
-\verb|-threads N| to select the maximal number of concurrent
-threads (default is 5). Multi-threaded
-and single-threaded clients/servers can interoperate.
-
-\item A new GTK-based user interface is now available, thanks to
-Jacques Garrigue. The Tk user interface still works, but we'll be
-shifting development effort to the GTK interface from now on.
-\item OCaml 3.00 is now required for compiling Unison from sources.
-The modules \verb|uitk| and \verb|myfileselect| have been changed to
-use labltk instead of camltk. To compile the Tk interface in Windows,
-you must have ocaml-3.00 and tk8.3. When installing tk8.3, put it in
-\verb|c:\Tcl| rather than the suggested \verb|c:\Program Files\Tcl|,
-and be sure to install the headers and libraries (which are not
-installed by default).
-
-\item Added a new \verb|-addversionno| switch, which causes unison to
-use \verb|unison-<currentversionnumber>| instead of just \verb|unison|
-as the remote server command. This allows multiple versions of unison
-to coexist conveniently on the same server: whichever version is run
-on the client, the same version will be selected on the server.
-\end{changesfromversion}
-
-\begin{changesfromversion}{1.219}
-\item \incompatible{} Archive format has changed. Make sure you
-synchronize your replicas before upgrading, to avoid spurious
-conflicts. The first sync after upgrading will be slow.
-
-\item This version fixes several annoying bugs, including:
-\begin{itemize}
-\item Some cases where propagation of file permissions was not
-working.
-\item umask is now ignored when creating directories
-\item directories are create writable, so that a read-only directory and
- its contents can be propagated.
-\item Handling of warnings generated by the server.
-\item Synchronizing a path whose parent is not a directory on both sides is
-now flagged as erroneous.
-\item Fixed some bugs related to symnbolic links and nonexistent roots.
-\begin{itemize}
-\item
- When a change (deletion or new contents) is propagated onto a
- 'follow'ed symlink, the file pointed to by the link is now changed.
- (We used to change the link itself, which doesn't fit our assertion
- that 'follow' means the link is completely invisible)
- \item When one root did not exist, propagating the other root on top of it
- used to fail, because unison could not calculate the working directory
- into which to write changes. This should be fixed.
-\end{itemize}
-\end{itemize}
-
-\item A human-readable timestamp has been added to Unison's archive files.
-
-\item The semantics of Path and Name regular expressions now
-correspond better.
-
-\item Some minor improvements to the text UI (e.g. a command for going
-back to previous items)
-
-\item The organization of the export directory has changed --- should
-be easier to find / download things now.
-\end{changesfromversion}
-
-\begin{changesfromversion}{1.200}
-\item \incompatible{} Archive format has changed. Make sure you
-synchronize your replicas before upgrading, to avoid spurious
-conflicts. The first sync after upgrading will be slow.
-
-\item This version has not been tested extensively on Windows.
-
-\item Major internal changes designed to make unison safer to run
-at the same time as the replicas are being changed by the user.
-
-\item Internal performance improvements.
-\end{changesfromversion}
-
-\begin{changesfromversion}{1.190}
-\item \incompatible{} Archive format has changed. Make sure you
-synchronize your replicas before upgrading, to avoid spurious
-conflicts. The first sync after upgrading will be slow.
-
-\item A number of internal functions have been changed to reduce the
-amount of memory allocation, especially during the first
-synchronization. This should help power users with very big replicas.
-
-\item Reimplementation of low-level remote procedure call stuff, in
-preparation for adding rsync-like smart file transfer in a later
-release.
-
-\item Miscellaneous bug fixes.
-\end{changesfromversion}
-
-\begin{changesfromversion}{1.180}
-\item \incompatible{} Archive format has changed. Make sure you
-synchronize your replicas before upgrading, to avoid spurious
-conflicts. The first sync after upgrading will be slow.
-
-\item Fixed some small bugs in the interpretation of ignore patterns.
-
-\item Fixed some problems that were preventing the Windows version
-from working correctly when click-started.
-
-\item Fixes to treatment of file permissions under Windows, which were
-causing spurious reports of different permissions when synchronizing
-between windows and unix systems.
-
-\item Fixed one more non-tail-recursive list processing function,
-which was causing stack overflows when synchronizing very large
-replicas.
-\end{changesfromversion}
-
-\begin{changesfromversion}{1.169}
-\item The text user interface now provides commands for ignoring
- files.
-\item We found and fixed some {\em more} non-tail-recursive list
- processing functions. Some power users have reported success with
- very large replicas.
-\item \incompatible
-Files ending in \verb|.tmp| are no longer ignored automatically. If you want
-to ignore such files, put an appropriate ignore pattern in your profile.
-
-\item \incompatible{} The syntax of {\tt ignore} and {\tt follow}
-patterns has changed. Instead of putting a line of the form
-\begin{verbatim}
- ignore = <regexp>
-\end{verbatim}
- in your profile ({\tt .unison/default.prf}), you should put:
-\begin{verbatim}
- ignore = Regex <regexp>
-\end{verbatim}
-Moreover, two other styles of pattern are also recognized:
-\begin{verbatim}
- ignore = Name <name>
-\end{verbatim}
-matches any path in which one component matches \verb|<name>|, while
-\begin{verbatim}
- ignore = Path <path>
-\end{verbatim}
-matches exactly the path \verb|<path>|.
-
-Standard ``globbing'' conventions can be used in \verb|<name>| and
-\verb|<path>|:
-\begin{itemize}
-\item a \verb|?| matches any single character except \verb|/|
-\item a \verb|*| matches any sequence of characters not including \verb|/|
-\item \verb|[xyz]| matches any character from the set $\{{\tt x},
- {\tt y}, {\tt z} \}$
-\item \verb|{a,bb,ccc}| matches any one of \verb|a|, \verb|bb|, or
- \verb|ccc|.
-\end{itemize}
-
-See the user manual for some examples.
-\end{changesfromversion}
-
-\begin{changesfromversion}{1.146}
-\item Some users were reporting stack overflows when synchronizing
- huge directories. We found and fixed some non-tail-recursive list
- processing functions, which we hope will solve the problem. Please
- give it a try and let us know.
-\item Major additions to the documentation.
-\end{changesfromversion}
-
-\begin{changesfromversion}{1.142}
-\item Major internal tidying and many small bugfixes.
-\item Major additions to the user manual.
-\item Unison can now be started with no arguments -- it will prompt
-automatically for the name of a profile file containing the roots to
-be synchronized. This makes it possible to start the graphical UI
-from a desktop icon.
-\item Fixed a small bug where the text UI on NT was raising a 'no such
- signal' exception.
-\end{changesfromversion}
-
-\begin{changesfromversion}{1.139}
-\item The precompiled windows binary in the last release was compiled
-with an old OCaml compiler, causing propagation of permissions not to
-work (and perhaps leading to some other strange behaviors we've heard
-reports about). This has been corrected. If you're using precompiled
-binaries on Windows, please upgrade.
-\item Added a \verb|-debug| command line flag, which controls debugging
-of various modules. Say \verb|-debug XXX| to enable debug tracing for
-module \verb|XXX|, or \verb|-debug all| to turn on absolutely everything.
-\item Fixed a small bug where the text UI on NT was raising a 'no such signal'
-exception.
-\end{changesfromversion}
-
-\begin{changesfromversion}{1.111}
-\item \incompatible{} The names and formats of the preference files in
-the .unison directory have changed. In particular:
-\begin{itemize}
-\item the file ``prefs'' should be renamed to default.prf
-\item the contents of the file ``ignore'' should be merged into
- default.prf. Each line of the form \verb|REGEXP| in ignore should
- become a line of the form \verb|ignore = REGEXP| in default.prf.
-\end{itemize}
-\item Unison now handles permission bits and symbolic links. See the
-manual for details.
-
-\item You can now have different preference files in your .unison
-directory. If you start unison like this
-\begin{verbatim}
- unison profilename
-\end{verbatim}
-(i.e. with just one ``anonymous'' command-line argument), then the
-file \verb|~/.unison/profilename.prf| will be loaded instead of
-\verb|default.prf|.
-
-\item Some improvements to terminal handling in the text user interface
-
-\item Added a switch -killServer that terminates the remote server process
-when the unison client is shutting down, even when using sockets for
-communication. (By default, a remote server created using ssh/rsh is
-terminated automatically, while a socket server is left running.)
-\item When started in 'socket server' mode, unison prints 'server started' on
- stderr when it is ready to accept connections.
- (This may be useful for scripts that want to tell when a socket-mode server
- has finished initialization.)
-\item We now make a nightly mirror of our current internal development
- tree, in case anyone wants an up-to-the-minute version to hack
- around with.
-\item Added a file CONTRIB with some suggestions for how to help us
-make Unison better.
-\end{changesfromversion}
diff --git a/doc/docs.ml b/doc/docs.ml
index ab084ae..7e6f376 100644
--- a/doc/docs.ml
+++ b/doc/docs.ml
@@ -55,9 +55,6 @@ let prmanual() =
close_in ch;
fprintf ml " [];;\n\n" in
-(* FIX: this should be derived automatically from projectInfo.ml *)
-let myName = "unison" in
-
(* Docs *)
prmanual ();
diff --git a/doc/hevea.sty b/doc/hevea.sty
index 51a17aa..3aab95b 100644
--- a/doc/hevea.sty
+++ b/doc/hevea.sty
@@ -1,11 +1,11 @@
-% htmlgen Verion 0.0 : html.sty
+% htmlgen Version 0.0 : html.sty
% This is a very basic style file for latex document to be processed
% with htmlgen. It contains definitions of LaTeX commands which are
% processed in a special way by the translator.
% Mostly :
% - environment latexonly, not processed by htmlgen, processed by latex.
% - environment htmlonly , the reverse
-% - environemnt htmlraw, to include raw HTML in hevea output.
+% - environment htmlraw, to include raw HTML in hevea output.
%
\makeatletter%
@@ -148,13 +148,13 @@
% Basic approach:
% to comment something out, scoop up every line in verbatim mode
% as macro argument, then throw it away.
-% For inclusions, both the opening and closing comands
+% For inclusions, both the opening and closing commands
% are defined as noop
%
% Changed \next to \html@next to prevent clashes with other sty files
% (mike@emn.fr)
% Changed \html@next to \htmlnext so the \makeatletter and
-% \makeatother commands could be removed (they were cuasing other
+% \makeatother commands could be removed (they were causing other
% style files - changebar.sty - to crash) (nikos@cbl.leeds.ac.uk)
diff --git a/doc/local.tex b/doc/local.tex
index c8941fc..c773436 100644
--- a/doc/local.tex
+++ b/doc/local.tex
@@ -84,7 +84,7 @@
\ifhevea
\SNIP{#1}{#3}%
\iftextversion\else \@print{<hr>}\fi%
- \section*{\label{#2}#1}%
+ \section*{\aname{#2}#1}%
\else
\newpage
\section{\label{#2}#1}%
@@ -94,7 +94,7 @@
\newcommand{\SUBSECTION}[2]{%
\ifhevea
- \subsection*{\label{#2}#1}%
+ \subsection*{\aname{#2}#1}%
\else
\subsection{\label{#2}#1}%
\addtocontents{htoc}{\hspace{10em}\bullet\string\urlref{#2}{#1}\\}
@@ -103,7 +103,7 @@
\newcommand{\SUBSUBSECTION}[2]{%
\ifhevea
- \subsubsection*{\label{#2}#1}%
+ \subsubsection*{\aname{#2}#1}%
\else
\subsubsection{\label{#2}#1}%
\addtocontents{htoc}{\hspace{18em}\string\urlref{#2}{#1}\\}
diff --git a/doc/unison-manual.tex b/doc/unison-manual.tex
old mode 100755
new mode 100644
index 9c869c9..61eeaab
--- a/doc/unison-manual.tex
+++ b/doc/unison-manual.tex
@@ -4,6 +4,7 @@
\usepackage{moreverb}
% \usepackage{hyperref}
\usepackage{hevea}
+\ifhevea\@def@charset{UTF-8}\fi
\input{local}
\fulltrue
@@ -230,10 +231,9 @@ Either click-start it, or type \showtt{unison -version} at the command
line.
Unison can be used in three different modes: with different directories on a
-single machine, with a remote machine over a direct socket connection, or
+single machine, with a local or a remote machine over a direct socket connection, or
with a remote machine using {\tt ssh} for authentication and secure
-transfer. If you intend to use the last option, you may need to install
-{\tt ssh}; see \sectionref{ssh}{Installing Ssh}.
+transfer.
\SUBSECTION{Running Unison}{afterinstall}
@@ -256,6 +256,84 @@ you roll back to the previous version of Unison, you will find the old
archives intact), which means that any differences between the replicas will
show up as conflicts that need to be resolved manually.
+As of version 2.52, Unison has a degree of backward and forward
+compatibility. This means three things. First, it is possible for local
+and remote machines to run a different version of Unison. Second, it is
+possible for local and remote machines to run a version (same or different)
+of Unison built with a different version of OCaml compiler (this has been
+problematic historically). Lastly, it is possible to upgrade Unison on
+the local machine (compiled with any OCaml version) and keep the existing
+archive.
+
+If version interoperability requirements are followed then Unison 2.52 and
+newer can upgrade the archive created by earlier Unison versions. To avoid
+rebuilding archive files when upgrading from a version older than 2.52, you
+must install version 2.52 or newer built with the same OCaml version as your
+previous version of Unison, and then run it at least once on each root. Doing
+so will upgrade the archive file.
+
+After upgrading the archive, you are free to swap the Unison 2.52 or newer
+executable to one compiled with a different version of OCaml.
+The archive file is no longer dependent on the compiler version.
+
+\SUBSUBSECTION{Version interoperability}{interoperability}
+
+To ensure interoperability with different Unison versions on local and
+remote machines, and to upgrade from an earlier version {\em without
+rebuilding the archive files}, you have to remember these guidelines.
+Upgrading from an incompatible version, while possible and normal, will
+require fully scanning both roots, which can be time-consuming with big
+replicas.
+
+{\bf Unison 2.52 and newer} are compatible with:
+\begin{itemize}
+\item {\em Unison 2.52 or newer} (for as long as backwards compatibility
+is maintained in the newer versions). You do not have to pay any attention
+to OCaml compiler versions.
+\item {\em Unison 2.51} if both versions are compiled with same OCaml
+compiler version (you can see which compiler version was used by running
+{\tt unison -version}).
+\item {\em Unison 2.48} if both versions are compiled with same OCaml
+compiler version. See special notes below.
+\end{itemize}
+
+\vspace{1em}
+\noindent {\bf Interoperability matrix} for quick reference:
+
+\vspace{1em}
+\begin{tabular}{r||c|c|c}
+ Client versions & \multicolumn{3}{c}{Server versions} \\
+ & 2.52 or newer & 2.51 & 2.48 \\
+ \hline \hline
+ 2.52 or newer & full interop & same OCaml version & same OCaml version \\
+ \hline
+ 2.51 & same OCaml version & full interop & no interop \\
+ \hline
+ 2.48 & same OCaml version* & no interop & full interop \\
+\end{tabular}
+\vspace{2em}
+
+\noindent {\it Special notes for Unison 2.48:}
+\begin{itemize}
+\item Unison 2.48 does not show which OCaml compiler was used to compile it.
+If you do not have the option of re-compiling the 2.48 version, you have
+two alternatives. First (and most likely to succeed), see what is the version
+of the OCaml compiler in the same package repository where you installed
+Unison 2.48 from, then use Unison 2.52 compiled with that version.
+Second, you can just try Unison 2.52 executables compiled with different
+OCaml versions and see which one works with your copy of Unison 2.48.
+\item When running Unison 2.48 on the client machine with Unison 2.52 or
+newer on the server machine, you have to do some additional configuration.
+The Unison executable name on the server must start with \verb|unison-2.48|
+(just \verb|unison-2.48| is ok, as is \verb|unison-2.48.exe|, but also
+\verb|unison-2.48+ocaml-4.05|). If using TCP socket connection to the
+server then you're all set! If using {\tt ssh} then you have to add one
+of the following options to your profile or as a command-line argument
+on the client machine: \verb|-addversionno|; see
+\sectionref{remote}{Remote Usage}, or \verb|-servercmd|; see
+\sectionref{rshmeth}{Remote Shell Method}.
+\end{itemize}
+
\SUBSECTION{Building Unison from Scratch}{building}
@@ -267,106 +345,7 @@ ported and on which the \verb|Unix| module is fully implemented. It has
been tested on many flavors of Windows (98, NT, 2000, XP) and Unix (OS X,
Solaris, Linux, FreeBSD), and on both 32- and 64-bit architectures.
-
-\SUBSUBSECTION{Unix}{build-unix}
-
-Unison can be built with or without a graphical user interface (GUI). The
-build system will decide automatically depending on the libraries installed
-on your system, but you can also type {\tt make UISTYLE=text} to build
-Unison without GUI.
-
-You'll need the Objective Caml compiler,
-available from \ONEURL{http://caml.inria.fr}. OCaml is available from most
-package managers
-Building and installing OCaml
-on Unix systems is very straightforward; just follow the instructions in the
-distribution. You'll probably want to build the native-code compiler in
-addition to the bytecode compiler, as Unison runs much faster when compiled
-to native code, but this is not absolutely necessary.
-%
-(Quick start: on many systems, the following sequence of commands will
-get you a working and installed compiler: first do {\tt make world opt},
-then {\tt su} to root and do {\tt make install}.)
-
-You'll also need the GNU {\tt make} utility, which is standard on most Unix
-systems. Unison's build system is not parallelizable, so don't use flags
-that cause it to start processes in parallel (e.g. -j).
-
-Once you've got OCaml installed, grab a copy of the Unison sources, unzip
-and untar them, change to the new \showtt{unison} directory, and type ``{\tt
- make UISTYLE=text}''. The result should be an executable file called
-\showtt{unison}. Type \showtt{./unison} to make sure the program is
-executable. You should get back a usage message.
-
-If you want to build the graphical user interface, you will need to install
-some additional things:
-\begin{itemize}
-\item The Gtk2 development libraries (package {\tt libgtk2.0-dev} on debian
-based systems).
-\item OCaml bindings for Gtk2. Install them from your software repositories
-(package {\tt liblablgtk2-ocaml} on debian based systems). Also available
-from \ONEURL{http://wwwfun.kurims.kyoto-u.ac.jp/soft/olabl/lablgtk.html}.
-\item Pango, a text rendering library and a part of Gtk2. On some systems
-(e.g. Ubuntu) the bindings between Pango and OCaml need to be installed
-explicitly (package {\tt liblablgtk-extras-ocaml-dev} on Ubuntu).
-\end{itemize}
-Type {\tt make src} to build Unison. If Gtk2 is available on the system,
-Unison with a GUI will be built automatically.
-
-Put the \verb|unison| executable somewhere in your search path, either by
-adding the Unison directory to your PATH variable or by copying the
-executable to some standard directory where executables are stored. Or just
-type {\tt make install} to install Unison to {\tt \$HOME/bin/unison}.
-
-\SUBSUBSECTION{Mac OS X}{build-osx}
-
-To build the text-only user interface, follow the instructions above for
-building on Unix systems. You should do this first, even if you are also
-planning on building the GUI, just to make sure it works.
-
-To build the basic GUI version, you'll first need to download and install
-the XCode developer tools from Apple. Once this is done, just type {\tt
- make} in the {\tt src} directory, and if things go well you
-should get an application that you can move from {\tt
- uimac/build/Default/Unison.app} to wherever you want it.
-
-\SUBSUBSECTION{Windows}{build-win}
-
-Although the binary distribution should work on any version of Windows,
-some people may want to build Unison from scratch on those systems too.
-
-\paragraph{Bytecode version:} The simpler but slower compilation option
-to build a Unison executable is to build a bytecode version. You need
-first install Windows version of the OCaml compiler (version 3.07 or
-later, available from \ONEURL{http://caml.inria.fr}). Then grab a copy
-of Unison sources and type
-\begin{verbatim}
- make NATIVE=false
-\end{verbatim}
-to compile the bytecode. The result should be an executable file called
-\verb|unison.exe|.
-
-\paragraph{Native version:} Building a more efficient, native version of
-Unison on Windows requires a little more work. See the file {\tt
- INSTALL.win32} in the source code distribution.
-
-
-\SUBSUBSECTION{Installation Options}{build-opts}
-
-The \verb|Makefile| in the distribution includes several switches that
-can be used to control how Unison is built. Here are the most useful
-ones:
-\begin{itemize}
-\item Building with \verb|NATIVE=true| uses the native-code OCaml
-compiler, yielding an executable that will run quite a bit faster. We use
-this for building distribution versions.
-\item Building with \verb|make DEBUGGING=true| generates debugging
-symbols.
-\item Building with \verb|make STATIC=true| generates a (mostly)
-statically linked executable. We use this for building distribution
-versions, for portability.
-\end{itemize}
-%\finish{Any other important ones?}
+Building instructions are included with the source code.
\SECTION{Tutorial}{tutorial}{tutorial}
@@ -536,6 +515,13 @@ when the file has been dealt with.
Next, we'll get Unison set up to synchronize replicas on two different
machines.
+NB: Unison has not been designed to run with elevated privileges
+(e.g. setuid), and it has not been audited for that environment.
+Therefore Unison should be run with the userid of the owner of the
+files to be synchronized, and should never be run setuid or similar.
+(Problems encountered when running setuid etc. must be reproduced
+without setuid before being reported as bugs.)
+
Follow the instructions in the Installation section to download or
build an executable version of Unison on the server machine, and
install it somewhere on your search path. (It doesn't matter whether
@@ -556,11 +542,15 @@ communicating between the client and the server:
command line, using a facility such as \verb|ssh|.
This method is more convenient (since there is no need to manually
start a ``unison server'' process on the server) and also more
- secure (especially if you use \verb|ssh|).
+ secure, assuming you are using \verb|ssh|).
-\item {\em Socket method}: This method requires only that you can get
- TCP packets from the client to the server and back. A draconian
- firewall can prevent this, but otherwise it should work anywhere.
+\item {\em TCP socket method}: This method requires only that you can
+ get TCP packets from the client to the server and back. It is
+ insecure and should not be used.
+
+\item {\em Unix socket method}: This method only works within a
+ single machine. It is similar to the TCP sockets method, but it is
+ possible to configure it securely.
\end{itemize}
Decide which of these you want to try, and continue with
@@ -570,18 +560,13 @@ Decide which of these you want to try, and continue with
\SUBSECTION{Remote Shell Method}{rshmeth}
-The standard remote shell facility on Unix systems is \verb|ssh|, which provides the
-same functionality as the older \verb|rsh| but much better security. Ssh is available from
-\ONEURL{http://www.openssh.org}. See section~\ref{ssh-win}
-for installation instructions for the Windows version.
+The standard remote shell facility on Unix systems is \verb|ssh|.
Running
\verb|ssh| requires some coordination between the client and server
machines to establish that the client is allowed to invoke commands on
the server; please refer to the \verb|ssh| documentation
-for information on how to set this up. The examples in this section
-use \verb|ssh|, but you can substitute \verb|rsh| for \verb|ssh| if
-you wish.
+for information on how to set this up.
First, test that we can invoke Unison on the server from the client.
Typing
@@ -638,18 +623,37 @@ of the path:
on the server by using the command-line option \showtt{-servercmd
/full/path/name/of/unison} or adding
\showtt{servercmd=/full/path/name/of/unison} to your profile (see
- \sectionref{profile}{Profiles}). Similarly, you can specify a
+ \sectionref{profile}{Profiles}). Similarly, you can specify an
explicit path for the \verb|ssh| program using the \showtt{-sshcmd}
option.
Extra arguments can be passed to \verb|ssh| by setting the
\verb|-sshargs| preference.
+
+\item By leveraging \showtt{-sshcmd} and \showtt{-sshargs}, you can
+ effectively use any remote shell program, not just \verb|ssh|; just
+ remember that the roots are still specified with \verb|ssh| as the
+ protocol, that is, they have to start with \showtt{ssh://}.
\end{itemize}
\SUBSECTION{Socket Method}{socketmeth}
+To run Unison over a socket connection, you must start a Unison
+daemon process on the server. This process runs continuously,
+waiting for connections over a given socket from client machines
+running Unison and processing their requests in turn.
+
+Since the socket method is not used by many people, its functionality is
+rather limited. For example, the server can only deal with one client at a
+time.
+
+Note that the Unison daemon process is always started with a command-line
+argument; not from a profile.
+
+\SUBSUBSECTION{TCP Sockets}{socket-tcp}
+
\begin{quote}
- {\bf\ifhevea\red\fi Warning:} The socket method is
+ {\bf\ifhevea\red\fi Warning:} The TCP socket method is
insecure: not only are the texts of your changes transmitted over
the network in unprotected form, it is also possible for anyone in
the world to connect to the server process and read out the contents
@@ -660,31 +664,27 @@ of the path:
else should use the \verb|ssh| method.
\end{quote}
-To run Unison over a socket connection, you must start a Unison
-daemon process on the server. This process runs continuously,
-waiting for connections over a given socket from client machines
-running Unison and processing their requests in turn.
-
-Note that socket mode cannot be started from a profile. It should be started as a command-line argument only.
-To start the daemon, type
+To start the daemon for connections over a TCP socket, type
\begin{verbatim}
unison -socket NNNN
\end{verbatim}
-on the server machine, where {\tt NNNN} is the socket number that the
+on the server machine, where {\tt NNNN} is the TCP port number that the
daemon should listen on for connections from clients. ({\tt NNNN} can
be any large number that is not being used by some other program; if
\texttt{NNNN} is already in use, Unison will exit with an error
-message.) Note that paths specified by the client will be interpreted
-relative to the directory in which you start the server process; this
-behavior is different from the ssh case, where the path is relative to
-your home directory on the server.
+message.)
Create a test directory {\tt a.tmp} in your home directory on the
client machine. Now type:
\begin{alltt}
unison a.tmp socket://\NT{remotehostname}:NNNN/a.tmp
\end{alltt}
+Note that paths specified by the client will be interpreted relative
+to the directory in which you start the server process; this behavior
+is different from the ssh case, where the path is relative to your home
+directory on the server.
+%
The result should be that the entire directory {\tt a.tmp} is
propagated from the client to the server (\texttt{a.tmp} will be
created on the server in the directory that the server was started
@@ -694,10 +694,40 @@ After finishing the first synchronization, change a few files and try
synchronizing again. You should see similar results as in the local
case.
-Since the socket method is not used by many people, its functionality is
-rather limited. For example, the server can only deal with one client at a
-time.
+By default Unison will listen for incoming connections on all interfaces.
+If you want to limit this to certain interfaces or addresses then you
+can use the {\tt -listen} command-line argument, specifying a host name
+or an IP address to listen on. {\tt -listen} can be given multiple
+times to listen on several addresses.
+\SUBSUBSECTION{Unix Domain Sockets}{socket-unix}
+
+To start the daemon for connections over a Unix domain socket, type
+\begin{verbatim}
+ unison -socket PPPP
+\end{verbatim}
+where {\tt PPPP} is the path to a Unix socket that the daemon should
+open for connections from clients. ({\tt PPPP} can be any absolute or
+relative path the server process has access to but it must not exist
+yet; the socket is created at that path when the daemon process is
+started.) You are responsible for securing access to the socket path.
+For example, this can be done by controlling the permissions of
+socket's parent directory, or ensuring a restrictive {\tt umask} value
+when starting Unison.
+
+Clients can connect to a server over a Unix domain socket by specifying
+the absolute or relative path to the socket, instead of a server address
+and port number:
+\begin{alltt}
+ unison a.tmp socket://\{\NT{path/to/unix/socket}\}/a.tmp
+\end{alltt}
+(socket path is enclosed in curly braces).
+
+Note that Unix domain sockets are local sockets (they exist in the
+filesystem namespace).
+One could use Unixs socket remotely, by forwarding access to the
+socket by other means, for example by using {\tt spiped} secure pipe
+daemon.
\SUBSECTION{Using Unison for All Your Files}{usingit}
@@ -792,7 +822,7 @@ lists, to receive announcements of new versions. See
To understand how Unison works, it is necessary to discuss a few
straightforward concepts.
-%
+
These concepts are developed more rigorously and at more length in a number
of papers, available at \ONEURL{http://www.cis.upenn.edu/\home{bcpierce}/papers}.
But the informal presentation here should be enough for most users.
@@ -815,21 +845,29 @@ started, while
\noindent
specifies a root relative to the top of the local filesystem,
independent of where Unison is running. Remote roots can begin with
-\verb|ssh://|,
-\verb|rsh://|
-to indicate that the remote server should be started with rsh or ssh:
+\verb|ssh://|
+to indicate that the remote server should be started with ssh:
\begin{alltt}
ssh://\NT{remotehost}//\NT{absolute/path/of/root}
- rsh://\NT{user}@\NT{remotehost}/\NT{relative/path/of/root}
+ ssh://\NT{user}@\NT{remotehost}/\NT{relative/path/of/root}
\end{alltt}
If the remote server is already running (in the socket mode), then the syntax
\begin{alltt}
socket://\NT{remotehost}:\NT{portnum}//\NT{absolute/path/of/root}
socket://\NT{remotehost}:\NT{portnum}/\NT{relative/path/of/root}
+ socket://[\NT{IPv6literal}]:\NT{portnum}/\NT{path}
\end{alltt}
\noindent
is used to specify the hostname and the port that the client Unison should
use to contact it.
+Syntax
+\begin{alltt}
+ socket://\{\NT{path/of/socket}\}//\NT{absolute/path/of/root}
+ socket://\{\NT{path/of/socket}\}/\NT{relative/path/of/root}
+\end{alltt}
+\noindent
+is used to specify the Unix domain socket the client Unison should use to
+contact the server.
The syntax for roots is based on that of URIs (described in RFC 2396).
The full grammar is:
@@ -840,11 +878,14 @@ The full grammar is:
\NT{protocol} ::= file
| socket
| ssh
- | rsh
- \NT{user} ::= [-_a-zA-Z0-9]+
+ \NT{user} ::= [-\_a-zA-Z0-9]+
+
+ \NT{host} ::= [-\_a-zA-Z0-9.]+
+ | \textbackslash[ [a-f0-9:.]+ \NT{zone}? \textbackslash] IPv6 literals (no future format).
+ | \{ [\^{}\}]+ \} For Unix domain sockets only.
- \NT{host} ::= [-_a-zA-Z0-9.]+
+ \NT{zone} ::= \%[-\_a-zA-Z0-9~\%.]+
\NT{port} ::= [0-9]+
\end{alltt}
@@ -1325,10 +1366,11 @@ Here are all the preferences supported by Unison. This list can be
\begin{quote}
\verbatiminput{prefs.tmp}
\end{quote}
+
Here, in more detail, is what they do. Many are discussed in greater detail
in other sections of the manual.
-It should be noted that some command-line arguments are handled specially during startup, including \verb|-doc|, \verb|-help|, \verb|-version|, \verb|-server|, \verb|-socket|, and \verb|-ui|. They are expected to appear on the command-line only, not in a profile. In particular, \verb|-version| and \verb|-doc| will print to the standard output, so they only make sense if invoked from the command-line (and not a click-launched gui that has no standard output). Furthermore, the actions associated with these command-line arguments are executed without loading a profile or doing the usual command-line parsing. This is because we want to run the actions without loading a profile; and then we can't do command-line parsing because it is intertwined with profile loading.
+It should be noted that some command-line arguments are handled specially during startup, including \verb|-doc|, \verb|-help|, \verb|-version|, \verb|-socket|, and \verb|-ui|. They are expected to appear on the command-line only, not in a profile. In particular, \verb|-version| and \verb|-doc| will print to the standard output, so they only make sense if invoked from the command-line (and not a click-launched gui that has no standard output). Furthermore, the actions associated with these command-line arguments are executed without loading a profile or doing the usual command-line parsing.
%
\input{prefsdocs.tmp}
@@ -1357,10 +1399,16 @@ for a boolean flag or
\end{verbatim}
for a preference of any other type.
-Whitespaces around {\tt p} and {\tt xxx} are ignored.
-A profile may also include blank lines and lines beginning
+A profile may include blank lines and lines beginning
with {\tt \#}; both are ignored.
+Spaces and tabs before and after {\tt p} and {\tt xxx} are ignored.
+Spaces, tabs, and non-printable characters within values are not
+treated specially, so that e.g. \verb|root = /foo bar| refers to a
+directory containing a space.
+(On systems using newline for line ending, carriage returns are
+currently ignored, but this is not part of the specification.)
+
When Unison starts, it first reads the profile and then the command
line, so command-line options will override settings from the
profile.
@@ -1375,7 +1423,7 @@ A similar line of the form \texttt{source \ARG{name}} does the same except
that it does not attempt to add a suffix to \ARG{name}.
Similar lines of the form \texttt{include\mbox{?} \ARG{name}} or
\texttt{source\mbox{?} \ARG{name}} do the same as their respective lines
-without the question mark except that it does not constitue an error to
+without the question mark except that it does not constitute an error to
specify a non-existing file \ARG{name}.
In \ARG{name} the backslash is an escape character.
@@ -1545,7 +1593,7 @@ preference. For example,
\begin{verbatim}
backup = Name *
\end{verbatim}
-causes Unison to keep backups of {\em all} files and directories. The
+causes Unison to create backups of {\em all} files and directories. The
\verb|backupnot| preference can be used to give a few exceptions: it
specifies which files and directories should {\em not} be backed up, even if
they match the \verb|backup| pathspec.
@@ -1562,7 +1610,10 @@ regardless of their names.
Backup files can be stored either {\em centrally} or {\em locally}. This
behavior is controlled by the preference \verb|backuplocation|, whose value
must be either \verb|central| or \verb|local|. (The default is
-\verb|central|.)
+\verb|central|.) Note that central storage of backups can lead to
+backup files being stored in a different filesystem than the original
+files, which could have different security properties and different
+amounts of available storage.
When backups are stored locally, they are kept in the same
directory as the original.
@@ -1573,8 +1624,10 @@ environment variable \verb|UNISONBACKUPDIR|. (The environment variable is
checked first.) If neither of these are set, then the directory
\verb|.unison/backup| in the user's home directory is used.
-The preference \verb|maxbackups| controls how many previous versions of
-each file are kept (including the current version).
+The preference \verb|maxbackups| (default 2) controls how many
+previous versions of each file are kept (including the current
+version), following the usual plan of deleting the oldest when
+creating a new one.
By default, backup files are named \verb|.bak.VERSION.FILENAME|,
where \verb|FILENAME| is the original filename and \verb|VERSION| is the
@@ -1594,6 +1647,9 @@ note that the string \verb|$VERSION| in either \verb|backupprefix| or
the version number. This can be used, for example, to ensure that backup
files retain the same extension as the originals.
+Other than \verb|maxbackups| (which will never delete the last
+backup), there are no other mechanisms for deleting backups.
+
For backward compatibility, the \verb|backups| preference is also supported.
%
It simply means \verb|backup = Name *| and \verb|backuplocation = local|.
@@ -1622,15 +1678,16 @@ need to be merged, but also a file containing the {\em last synchronized
version}. You can ask Unison to keep a copy of the last synchronized
version for some files using the \verb|backupcurrent| preference. This
preference is used in exactly the same way as \verb|backup| and its meaning
-is similar, except that it causes backups to be kept of the {\em current}
+is similar, except that it causes backups to be created of the {\em current}
contents of each file after it has been synchronized by Unison, rather than
-the {\em previous} contents that Unison overwrote. These backups are kept
-on {\em both} replicas in the same place as ordinary backup files---i.e.
+the {\em previous} contents that Unison overwrote. These backups are stored
+in {\em both} replicas in the same place as ordinary backup files---i.e.
according to the \verb|backuplocation| and \verb|backupdir| preferences.
They are named like the original files if \verb|backupslocation| is set to
'central' and otherwise, Unison uses the \verb|backupprefix| and
\verb|backupsuffix| preferences and assumes a version number 000 for these
-backups.
+backups. Note that there are no mechanisms (beyond the limit on the number of
+backups for each file) to remove backup files.
The \verb|<MERGECMD>| part of the preference specifies what external command
should be invoked to merge files at paths matching the \verb|<PATHSPEC>|.
@@ -1813,6 +1870,41 @@ Setting the \verb|dumbtty| preference will force Unison to leave the
terminal alone and process input a line at a time.
\end{itemize}
+\SUBSECTION{Interrupting a Synchronization}{intr}
+
+It is possible to interrupt an ongoing synchronization process before it
+completes. Different user interfaces offer different ways of doing it.
+
+\begin{tkui}
+In the graphical user interface the synchronization process can be interrupted
+before it is finished by pressing the ``Stop'' button or by closing the window.
+The ``Stop'' button causes the onging propagation to be stopped as quickly as
+possible while still doing proper cleanup. The application keeps running and a
+rescan can be performed or a different profile selected. Closing the window in
+the middle of update propagation process will exit the application immediately
+without doing proper cleanup; it is therefore not recommended unless the
+``Stop'' button does not react quickly enough.
+\end{tkui}
+
+\begin{textui}
+When not synchronizing continuously, the text interface terminates when
+synchronization is finished normally or due to a fatal error occurring.
+
+In the text interface, to interrupt synchronization before it is finished,
+press ``Ctrl-C'' (or send signal \verb|SIGINT| or \verb|SIGTERM|). This will
+interrupt update propagation as quickly as possible but still complete proper
+cleanup. If the process does not stop even after pressing ``Ctrl-C'' then keep
+doing it repeatedly. This will bypass cleanup procedures and terminates the
+process forcibly (similar to \verb|SIGKILL|). Doing so may leave the archives
+or replicas in an inconsistent state or locked.
+
+When synchronizing continuously (time interval repeat or with filesystem
+monitoring), interrupting with ``Ctrl-C'' or with signal \verb|SIGINT| or
+\verb|SIGTERM| works the same way as described above and will additionally stop
+the continuous process. To stop only the continuous process and let the last
+synchronization complete normally, send signal \verb|SIGUSR2| instead.
+\end{textui}
+
\SUBSECTION{Exit Code}{exit}
When running in the textual mode, Unison returns an exit status, which
@@ -2034,12 +2126,157 @@ propagated. The values of the other bits are set to default values
Unix system).
\item For security reasons, the Unix \verb|setuid| and \verb|setgid|
bits are not propagated.
-\item The Unix owner and group ids are not propagated. (What would
-this mean, in general?) All files are created with the owner and
-group of the server process.
+\item The Unix owner and group ids can be propagated (see \verb|owner|
+and \verb|group| preferences) by mapping names or by numeric ids (see
+\verb|numericids| preference).
\end{itemize}
+\SUBSECTION{Access Control Lists - ACLs}{acls}
+
+Unison allows synchronizing access control lists (ACLs) on platforms
+and filesystems that support them. In general, synchronization makes
+sense only in case both replicas support the same type of ACLs and
+recognize same users and groups. In some cases you may be able to
+go beyond that and synchronize ACLs to a replica that couldn't fully
+use them---this may be be useful for the purpose of preserving ACLs.
+
+If one of the replicas does not support any type of ACLs then
+Unison will not attempt ACL synchronization. If the other replica
+does support ACLs then those will remain intact.
+
+If both replicas support ACLs of any supported type then you can
+request Unison to try ACL synchronization (\verb|acl| preference).
+Success of synchronization depends on permissions of the owner and
+group of Unison process (Unison must have permissions to set ACL)
+and the compatibility of ACL types on both replicas.
+
+An ACL is propagated as a single unit, with all ACEs. There is no
+merging of ACEs from the replicas.
+
+{\em Caveat}: ACE inheritance may in certain scenarios cause synchronization
+inconsistencies. In Windows, only explicit ACEs are synchronized; inherited
+ACEs are not actively synchronized, but Windows will propagate ACEs from parent
+directories (unless inheritance is explicitly prevented on a file or a
+directory---this prevention is also synchronized). Due to inheritance, the
+ultimately effective ACL may be different, or provide different access, even
+after synchronization.
+
+Unison currently supports the following platforms and ACL types:
+\begin{itemize}
+ \item Windows (Windows XP SP2 and later)
+ \begin{itemize}
+ \item NTFS ACL (discrete ACL (DACL) only)
+ \end{itemize}
+\item Solaris, OpenSolaris and illumos-based OS (OpenIndiana, SmartOS,
+ OmniOS, etc.)
+ \begin{itemize}
+ \item NFSv4 ACL (ZFS ACL)
+ \item POSIX-draft ACL
+ \item Some NFSv4 ACL (ZFS ACL) cross-synchronization with
+ POSIX-draft ACL
+ \item Full cross-synchronization with other platforms that support
+ NFSv4 ACLs; limited cross-synchronization with POSIX-draft ACLs
+ \end{itemize}
+\item FreeBSD, NetBSD
+ \begin{itemize}
+ \item NFSv4 ACL (ZFS ACL)
+ \item Limited POSIX-draft ACL (access ACL only; not default ACL)
+ \item Full cross-synchronization with other platforms that support
+ NFSv4 ACLs
+ \end{itemize}
+\item Darwin (macOS)
+ \begin{itemize}
+ \item Extended ACL
+ \end{itemize}
+\end{itemize}
+Not all filesystems on the listed platforms support all ACL types
+(or any ACLs at all).
+
+Synchronizing POSIX ACLs on Linux is not supported directly. However, it is
+possible to synchronize these ACLs with another Linux system by synchronizing
+extended attributes (xattrs) instead, because POSIX ACLs are stored as xattrs
+by Linux. This is disabled by default (see \sectionref{xattrs}{Extended
+Attributes - xattrs}). A simple way to enable syncing POSIX ACLs on Linux is
+to enable the preference \verb|xattrs| and add a preference
+\verb|xattrignorenot| with a value \texttt{Path !system.posix\_acl\_*}. The
+\verb|*| will be expanded to include both \verb|posix_acl_access| and
+\verb|posix_acl_default| attributes -- if you only want to sync either one,
+just remove the \verb|*| and type out the attribute name in full. If you want
+to prevent other xattrs from being synced then add an \verb|xattrignore| with a
+value \texttt{Path *} (value \texttt{Regex .*} will also work).
+
+
+\SUBSECTION{Extended Attributes - xattrs}{xattrs}
+
+Unison allows synchronizing extended attributes on platforms and
+filesystems that support them. System attributes are not synchronized.
+What exactly is considered a system attribute is platform-dependent.
+Synchronization is possible cross-platform, but see caveats below.
+
+If one of the replicas does not support extended attributes then
+Unison will not attempt attribute synchronization. If the other
+replica does support extended attributes then those will remain intact.
+
+If both replicas support extended attributes then you can request
+Unison to try attribute synchronization (\verb|xattrs| preference).
+Extended attributes from both replicas will not be merged, all extended
+attributes are propagated as a set from one replica to another.
+
+Unison currently supports extended attributes on the following platforms:
+\begin{itemize}
+\item {\em Linux}
+Attributes in user, trusted and security namespaces. Synchronization of
+the latter two namespaces depends on \verb|unison| process privileges
+and is disabled by default. To sync one or more attributes in the security
+namespace, for example, you can set the preference
+\verb|xattrignorenot| to \verb|Path !security.*| (for all) or to
+\verb|Path !security.selinux| (for one specific attribute).
+Attributes in system namespace are not synchronized, with the exception of
+\verb|system.posix_acl_default| and \verb|system.posix_acl_access| (also
+disabled by default).
+\item {\em Solaris, OpenSolaris and illumos-based OS (OpenIndiana, SmartOS,
+ OmniOS, etc.)}
+\item {\em FreeBSD, NetBSD}
+Attributes in user namespace.
+\item {\em Darwin (macOS)}
+\end{itemize}
+Not all filesystems on the listed platforms may support extended attributes.
+
+\noindent {\it Caveats:}
+\begin{itemize}
+\item Some platforms and file systems support very large extended attribute
+values. Unison synchronizes only up to 16 MB of each attribute value.
+\item Attributes are synchronized as simple name-value pairs. More complex
+extended attribute concepts supported by some platforms are not synchronized.
+\item On Linux, attribute names always have a fully qualified form
+(\texttt{namespace.attribute}). Other platforms do not have the same constraint.
+The consequence of this is that Unison will sync the attribute names on Linux
+as follows: an \verb|!| is prepended to the namespace name, except for the
+\verb|user| namespace; the \verb|user.| prefix is stripped from attribute names
+instead. This allows syncing extended attributes from Linux to other platforms.
+These transformations are reversed when syncing {\em to} Linux, resulting in
+correct fully qualified attribute names.
+The \verb|xattrignore| and \verb|xattrignorenot| preferences work on the
+transformed attribute names. This means that any patterns for the user
+namespace must be specified without the \verb|user.| prefix and any patterns
+intended for other namespaces must begin with an \verb|!|.
+\end{itemize}
+
+The \verb|xattrignore| preference can be used to filter the names of extended
+attributes that will be synchronized. The most useful ignore patterns can
+be constructed with the \verb|Path| form (where shell wildcards \verb|*| and
+\verb|?| are supported) and with the \verb|Regex| form. The
+\verb|xattrignorenot| preference can be used to override \verb|xattrignore|.
+
+Disabling the security and trusted namespaces on Linux is achieved by setting
+a default \verb|xattrignore| pattern of
+\texttt{Regex !(security|trusted)[.].*}.
+Disabling the syncing of attributes used to store POSIX ACL on Linux is
+achieved by setting a default \verb|xattrignore| pattern of
+\texttt{Path !system.posix\_acl\_*}.
+
+
\SUBSECTION{Cross-Platform Synchronization}{crossplatform}
If you use Unison to synchronize files between Windows and Unix
@@ -2123,14 +2360,6 @@ are:
copyprog = rsync --inplace --compress
copyprogrest = rsync --partial --inplace --compress
\end{verbatim}
-You may also need to set the {\tt copyquoterem} preference. When it is set
-to {\tt true}, this causes Unison to add an extra layer of quotes to
-the remote path passed to the external copy program. This is is needed by
-rsync, for example, which internally uses an ssh connection, requiring an
-extra level of quoting for paths containing spaces. When this flag is set to
-{\tt default}, extra quotes are added if the value of {\tt copyprog}
-contains the string {\tt rsync}. The default value is {\tt default},
-naturally.
If a {\em directory} transfer is interrupted, the next run of Unison will
automatically skip any files that were completely transferred before the
@@ -2215,15 +2444,6 @@ To use Unison in this mode, you must first create a profile (see
\appendix
-\SECTION{Ssh}{ssh}{ssh}
-
-Your local host will need just an ssh client; the remote host needs an
-ssh server (or daemon). ssh is now normal, and Unison thus does not
-provide instructions.
-
-\SECTION{Changes in Version \unisonversion}{news}{news}
-
-\input{changes.tex}
\finishlater{
\SECTION{Other Synchronizers}{other}{other}
diff --git a/dune-project b/dune-project
index 4458215..a20112a 100644
--- a/dune-project
+++ b/dune-project
@@ -1,2 +1,76 @@
(lang dune 2.3)
+
(name unison)
+
+(version dev)
+
+(generate_opam_files false)
+
+(license GPL-3.0-or-later)
+
+(maintainers "unison-hackers@lists.seas.upenn.edu")
+
+(authors "Trevor Jim" "Benjamin C. Pierce" "J\195\169r\195\180me Vouillon")
+
+(source
+ (github bcpierce00/unison))
+
+(homepage https://www.cis.upenn.edu/~bcpierce/unison/)
+
+(documentation "https://github.com/bcpierce00/unison/wiki")
+
+(package
+ (name unison)
+ (synopsis "File-synchronization tool for Unix and Windows")
+ (description "\
+Text based user interface for Unison.
+
+Unison is a file-synchronization tool for Unix and Windows.
+It allows two replicas of a collection of files and directories
+to be stored on different hosts (or different disks on the same host),
+modified separately, and then brought up to date by propagating
+the changes in each replica to the other.
+")
+ (depends
+ (ocaml
+ (>= 4.08))
+ (dune
+ (>= 2.3))))
+
+(package
+ (name unison-gui)
+ (synopsis "File-synchronization tool for Unix and Windows")
+ (description "\
+Graphical user interface for Unison.
+
+Unison is a file-synchronization tool for Unix and Windows.
+It allows two replicas of a collection of files and directories
+to be stored on different hosts (or different disks on the same host),
+modified separately, and then brought up to date by propagating
+the changes in each replica to the other.
+")
+ (depends
+ (ocaml
+ (>= 4.08))
+ (dune
+ (>= 2.3))
+ lablgtk))
+
+(package
+ (name unison-fsmonitor)
+ (synopsis "File-synchronization tool for Unix and Windows")
+ (description "\
+This optional add-on for unison monitors file system changes
+on all given (relative to root) paths.
+
+Unison is a file-synchronization tool for Unix and Windows.
+It allows two replicas of a collection of files and directories
+to be stored on different hosts (or different disks on the same host),
+modified separately, and then brought up to date by propagating
+the changes in each replica to the other.
+")
+ (depends
+ (ocaml
+ (>= 4.08))
+ (dune
+ (>= 2.3))))
diff --git a/icons/unison.png b/icons/unison.png
new file mode 100644
index 0000000..1994a53
Binary files /dev/null and b/icons/unison.png differ
diff --git a/icons/unison.svg b/icons/unison.svg
new file mode 100644
index 0000000..6586a4c
--- /dev/null
+++ b/icons/unison.svg
@@ -0,0 +1,13 @@
+<?xml version="1.0" encoding="UTF-8"?>
+<svg width="207px" height="52px" viewBox="0 0 207 52" version="1.1" xmlns="http://www.w3.org/2000/svg" xmlns:xlink="http://www.w3.org/1999/xlink">
+ <title>Unison</title>
+ <defs>
+ <linearGradient x1="49.9999257%" y1="31.7505524%" x2="49.9999257%" y2="69.6081184%" id="linearGradient-1">
+ <stop stop-color="#F9F90A" offset="0%"></stop>
+ <stop stop-color="#FF3201" offset="100%"></stop>
+ </linearGradient>
+ </defs>
+ <g id="Page-1" stroke="none" stroke-width="1" fill="none" fill-rule="evenodd">
+ <path d="M38.315852,1.168 L30.184852,10.193 C29.889852,10.52 30.121852,11.042 30.561852,11.042 L30.561852,11.042 L32.982852,11.042 C33.262852,11.042 33.490852,11.27 33.490852,11.551 L33.490852,11.551 L33.490852,31.41 C33.490852,34.932 33.099852,37.653 32.317852,39.57 L32.317852,39.57 C31.534852,41.487 30.291852,42.992 28.585852,44.085 L28.585852,44.085 C27.285852,44.919 25.834852,45.425 24.241852,45.623 L24.241852,45.623 C24.190852,45.629 24.136852,45.629 24.085852,45.623 L24.085852,45.623 C22.493852,45.425 21.042852,44.919 19.742852,44.085 L19.742852,44.085 C18.035852,42.992 16.792852,41.487 16.010852,39.57 L16.010852,39.57 C15.227852,37.653 14.836852,34.932 14.836852,31.41 L14.836852,31.41 L14.836852,11.551 C14.836852,11.27 15.063852,11.042 15.345852,11.042 L15.345852,11.042 L17.764852,11.042 C18.205852,11.042 18.437852,10.52 18.142852,10.193 L18.142852,10.193 L10.012852,1.168 C9.80985201,0.944 9.45785201,0.944 9.25685201,1.169 L9.25685201,1.169 L1.13185201,10.193 C0.836852007,10.521 1.06985201,11.042 1.50985201,11.042 L1.50985201,11.042 L3.92985201,11.042 C4.20985201,11.042 4.43785201,11.27 4.43785201,11.551 L4.43785201,11.551 L4.43185201,31.41 C4.44985201,32.987 4.52485201,34.353 4.66485201,35.557 L4.66485201,35.557 C4.82485201,36.939 5.06585201,38.21 5.38785201,39.369 L5.38785201,39.369 C6.42985201,42.938 8.33685201,45.657 11.104852,47.529 L11.104852,47.529 C12.829852,48.734 14.776852,49.627 16.943852,50.205 L16.943852,50.205 C19.109852,50.785 21.516852,51.075 24.163852,51.075 L24.163852,51.075 C26.810852,51.075 29.218852,50.785 31.383852,50.205 L31.383852,50.205 C33.550852,49.627 35.497852,48.734 37.222852,47.529 L37.222852,47.529 C39.991852,45.657 41.897852,42.938 42.940852,39.369 L42.940852,39.369 C43.262852,38.21 43.503852,36.939 43.663852,35.557 L43.663852,35.557 C43.802852,34.353 43.877852,32.987 43.895852,31.41 L43.895852,31.41 L43.890852,11.551 C43.889852,11.27 44.116852,11.042 44.398852,11.042 L44.398852,11.042 L46.817852,11.042 C47.258852,11.042 47.491852,10.521 47.195852,10.193 L47.195852,10.193 L39.070852,1.169 C38.969852,1.056 38.831852,1 38.692852,1 L38.692852,1 C38.554852,1 38.416852,1.056 38.315852,1.168 L38.315852,1.168 Z M90.934852,5.122 C89.810852,6.193 89.249852,7.464 89.249852,8.935 L89.249852,8.935 C89.249852,10.362 89.810852,11.588 90.934852,12.613 L90.934852,12.613 C92.058852,13.64 93.362852,14.152 94.848852,14.152 L94.848852,14.152 C96.493852,14.152 97.846852,13.662 98.909852,12.681 L98.909852,12.681 C99.973852,11.7 100.505852,10.473 100.505852,9.002 L100.505852,9.002 C100.505852,7.396 99.983852,6.082 98.941852,5.055 L98.941852,5.055 C97.896852,4.03 96.593852,3.516 95.028852,3.516 L95.028852,3.516 C93.422852,3.516 92.058852,4.052 90.934852,5.122 L90.934852,5.122 Z M186.230852,19.218 C185.464852,19.703 184.821852,20.187 184.298852,20.671 L184.298852,20.671 C183.775852,21.154 183.152852,21.881 182.427852,22.848 L182.427852,22.848 L182.427852,21.263 C182.427852,20.34 182.146852,19.505 181.584852,18.756 L181.584852,18.756 C181.302852,18.405 181.061852,18.174 180.862852,18.063 L180.862852,18.063 C180.660852,17.953 180.440852,17.898 180.199852,17.898 L180.199852,17.898 L178.936852,18.164 L171.770852,20.969 C170.645852,21.503 170.084852,22.238 170.084852,23.172 L170.084852,23.172 C170.084852,24.062 170.593852,24.729 171.617852,25.175 L171.617852,25.175 C172.761852,25.53 173.334852,26.509 173.334852,28.111 L173.334852,28.111 L173.334852,43.13 C173.334852,44.643 172.752852,45.667 171.589852,46.201 L171.589852,46.201 C170.584852,46.603 170.084852,47.27 170.084852,48.204 L170.084852,48.204 C170.084852,49.494 170.783852,50.139 172.183852,50.139 L172.183852,50.139 L184.235852,50.139 C185.474852,50.139 186.094852,49.494 186.094852,48.205 L186.094852,48.205 C186.094852,47.226 185.592852,46.559 184.589852,46.202 L184.589852,46.202 C184.147852,46.024 183.856852,45.836 183.716852,45.635 L183.716852,45.635 C183.576852,45.435 183.465852,45.125 183.385852,44.702 L183.385852,44.702 C183.305852,44.28 183.265852,43.802 183.265852,43.267 L183.265852,43.267 L183.265852,28.921 C183.265852,27.543 183.854852,26.297 185.031852,25.185 L185.031852,25.185 C186.208852,24.073 187.508852,23.517 188.930852,23.517 L188.930852,23.517 C190.554852,23.517 191.752852,24.14 192.524852,25.385 L192.524852,25.385 C192.889852,26.052 193.131852,26.675 193.254852,27.254 L193.254852,27.254 C193.377852,27.832 193.437852,28.856 193.437852,30.323 L193.437852,30.323 L193.437852,33.392 L193.437852,37.996 C193.437852,39.596 193.417852,40.921 193.377852,41.966 L193.377852,41.966 C193.337852,43.011 193.296852,43.867 193.256852,44.535 L193.256852,44.535 C193.137852,45.335 192.644852,45.902 191.782852,46.236 L191.782852,46.236 C190.919852,46.57 190.489852,47.226 190.489852,48.205 L190.489852,48.205 C190.489852,49.494 191.170852,50.139 192.535852,50.139 L192.535852,50.139 L204.392852,50.139 C205.033852,50.139 205.545852,49.962 205.927852,49.605 L205.927852,49.605 C206.308852,49.25 206.499852,48.783 206.499852,48.204 L206.499852,48.204 C206.499852,47.27 206.065852,46.624 205.199852,46.268 L205.199852,46.268 C204.333852,45.912 203.811852,45.468 203.633852,44.933 L203.633852,44.933 C203.457852,44.399 203.369852,43.086 203.369852,40.994 L203.369852,40.994 L203.369852,38.591 L203.369852,35.588 C203.369852,31.494 203.268852,28.657 203.067852,27.077 L203.067852,27.077 C202.866852,25.496 202.462852,24.083 201.860852,22.837 L201.860852,22.837 C200.049852,19.545 196.689852,17.898 191.781852,17.898 L191.781852,17.898 C189.729852,17.898 187.880852,18.338 186.230852,19.218 L186.230852,19.218 Z M140.170852,22.562 C137.041852,25.671 135.475852,29.602 135.475852,34.353 L135.475852,34.353 C135.475852,39.195 136.999852,43.17 140.049852,46.278 L140.049852,46.278 C143.099852,49.387 147.031852,50.942 151.847852,50.942 L151.847852,50.942 C156.622852,50.942 160.554852,49.387 163.645852,46.278 L163.645852,46.278 C166.733852,43.17 168.279852,39.217 168.279852,34.42 L168.279852,34.42 C168.279852,29.623 166.733852,25.671 163.645852,22.562 L163.645852,22.562 C160.554852,19.453 156.662852,17.898 151.967852,17.898 L151.967852,17.898 C147.232852,17.898 143.300852,19.453 140.170852,22.562 L140.170852,22.562 Z M146.701852,43.301 C145.476852,41.195 144.865852,38.235 144.865852,34.42 L144.865852,34.42 C144.865852,30.606 145.476852,27.646 146.701852,25.539 L146.701852,25.539 C147.924852,23.433 149.640852,22.38 151.847852,22.38 L151.847852,22.38 C154.093852,22.38 155.840852,23.445 157.084852,25.572 L157.084852,25.572 C158.326852,27.702 158.949852,30.628 158.949852,34.353 L158.949852,34.353 C158.949852,38.168 158.326852,41.14 157.084852,43.267 L157.084852,43.267 C155.840852,45.397 154.093852,46.46 151.847852,46.46 L151.847852,46.46 C149.640852,46.46 147.924852,45.408 146.701852,43.301 L146.701852,43.301 Z M109.172852,22.359 C107.728852,24.223 107.006852,26.354 107.006852,28.75 L107.006852,28.75 C107.006852,30.171 107.276852,31.381 107.818852,32.379 L107.818852,32.379 C108.359852,33.378 109.312852,34.431 110.677852,35.542 L110.677852,35.542 C111.881852,36.385 113.025852,36.962 114.109852,37.272 L114.109852,37.272 L119.044852,38.604 C119.925852,38.871 120.549852,39.091 120.909852,39.27 L120.909852,39.27 C121.270852,39.447 121.591852,39.692 121.873852,40.001 L121.873852,40.001 C122.514852,40.579 122.836852,41.378 122.836852,42.399 L122.836852,42.399 C122.836852,43.509 122.354852,44.44 121.391852,45.195 L121.391852,45.195 C120.428852,45.949 119.264852,46.326 117.900852,46.326 L117.900852,46.326 C115.531852,46.326 113.587852,45.269 112.062852,43.151 L112.062852,43.151 L110.737852,41.365 C110.496852,41.101 110.265852,40.902 110.045852,40.769 L110.045852,40.769 C109.825852,40.637 109.614852,40.527 109.413852,40.44 L109.413852,40.44 L108.450852,40.306 C107.728852,40.306 107.126852,40.594 106.644852,41.17 L106.644852,41.17 C106.163852,41.748 105.922852,42.456 105.922852,43.298 L105.922852,43.298 C105.922852,45.38 107.206852,47.175 109.774852,48.683 L109.774852,48.683 C112.342852,50.188 115.351852,50.942 118.803852,50.942 L118.803852,50.942 C122.776852,50.942 126.116852,49.854 128.824852,47.68 L128.824852,47.68 C131.533852,45.505 132.888852,42.82 132.888852,39.624 L132.888852,39.624 C132.888852,37.582 131.799852,35.606 129.758852,33.565 L129.758852,33.565 C129.391852,33.197 128.167852,32.091 126.567852,31.501 L126.567852,31.501 L121.451852,29.97 C120.166852,29.659 119.234852,29.315 118.653852,28.938 L118.653852,28.938 C118.069852,28.561 117.629852,28.051 117.329852,27.407 L117.329852,27.407 C117.027852,26.763 116.877852,26.22 116.877852,25.776 L116.877852,25.776 C116.877852,23.511 118.221852,22.38 120.909852,22.38 L120.909852,22.38 C123.757852,22.38 125.865852,23.658 127.230852,26.214 L127.230852,26.214 C127.630852,26.92 128.012852,27.405 128.374852,27.669 L128.374852,27.669 C128.734852,27.934 129.215852,28.065 129.817852,28.065 L129.817852,28.065 C131.101852,28.065 131.744852,27.313 131.744852,25.805 L131.744852,25.805 C131.744852,23.016 131.322852,21.309 130.479852,20.688 L130.479852,20.688 C129.355852,19.803 127.891852,19.117 126.086852,18.63 L126.086852,18.63 C124.280852,18.143 122.393852,17.898 120.428852,17.898 L120.428852,17.898 C115.211852,17.898 111.460852,19.385 109.172852,22.359 L109.172852,22.359 Z M96.652852,18.099 L88.768852,20.909 C87.644852,21.354 87.082852,22.09 87.082852,23.115 L87.082852,23.115 C87.082852,24.008 87.585852,24.677 88.587852,25.122 L88.587852,25.122 C89.710852,25.48 90.273852,26.483 90.273852,28.133 L90.273852,28.133 L90.273852,43.049 C90.273852,43.986 90.152852,44.678 89.912852,45.122 L89.912852,45.122 C89.671852,45.569 89.139852,45.958 88.316852,46.293 L88.316852,46.293 C87.494852,46.628 87.082852,47.262 87.082852,48.199 L87.082852,48.199 C87.082852,49.493 87.784852,50.139 89.189852,50.139 L89.189852,50.139 L101.288852,50.139 C101.929852,50.139 102.441852,49.962 102.823852,49.604 L102.823852,49.604 C103.203852,49.248 103.394852,48.779 103.394852,48.199 L103.394852,48.199 C103.394852,47.262 102.963852,46.628 102.100852,46.293 L102.100852,46.293 C101.236852,45.958 100.706852,45.58 100.505852,45.156 L100.505852,45.156 C100.304852,44.733 100.204852,44.008 100.204852,42.982 L100.204852,42.982 L100.204852,22.982 C100.204852,19.594 99.441852,17.898 97.917852,17.898 L97.917852,17.898 L96.652852,18.099 Z M63.865852,19.218 C63.098852,19.703 62.456852,20.187 61.933852,20.671 L61.933852,20.671 C61.410852,21.154 60.787852,21.881 60.063852,22.848 L60.063852,22.848 L60.063852,21.263 C60.063852,20.34 59.781852,19.505 59.219852,18.756 L59.219852,18.756 C58.938852,18.405 58.696852,18.174 58.496852,18.063 L58.496852,18.063 C58.295852,17.953 58.075852,17.898 57.834852,17.898 L57.834852,17.898 L56.570852,18.164 L49.405852,20.969 C48.280852,21.503 47.718852,22.238 47.718852,23.172 L47.718852,23.172 C47.718852,24.062 48.229852,24.729 49.252852,25.175 L49.252852,25.175 C50.396852,25.53 50.969852,26.509 50.969852,28.111 L50.969852,28.111 L50.969852,43.13 C50.969852,44.643 50.387852,45.667 49.223852,46.201 L49.223852,46.201 C48.220852,46.603 47.718852,47.27 47.718852,48.204 L47.718852,48.204 C47.718852,49.494 48.418852,50.139 49.817852,50.139 L49.817852,50.139 L61.871852,50.139 C63.110852,50.139 63.729852,49.494 63.729852,48.205 L63.729852,48.205 C63.729852,47.226 63.227852,46.559 62.224852,46.202 L62.224852,46.202 C61.783852,46.024 61.492852,45.836 61.351852,45.635 L61.351852,45.635 C61.210852,45.435 61.101852,45.125 61.020852,44.702 L61.020852,44.702 C60.940852,44.28 60.901852,43.802 60.901852,43.267 L60.901852,43.267 L60.901852,28.921 C60.901852,27.543 61.489852,26.297 62.666852,25.185 L62.666852,25.185 C63.844852,24.073 65.143852,23.517 66.564852,23.517 L66.564852,23.517 C68.190852,23.517 69.388852,24.14 70.160852,25.385 L70.160852,25.385 C70.524852,26.052 70.766852,26.675 70.889852,27.254 L70.889852,27.254 C71.011852,27.832 71.072852,28.856 71.072852,30.323 L71.072852,30.323 L71.072852,33.392 L71.072852,37.996 C71.072852,39.596 71.052852,40.921 71.012852,41.966 L71.012852,41.966 C70.972852,43.011 70.932852,43.867 70.891852,44.535 L70.891852,44.535 C70.772852,45.335 70.279852,45.902 69.417852,46.236 L69.417852,46.236 C68.554852,46.57 68.123852,47.226 68.123852,48.205 L68.123852,48.205 C68.123852,49.494 68.804852,50.139 70.170852,50.139 L70.170852,50.139 L82.027852,50.139 C82.669852,50.139 83.180852,49.962 83.562852,49.605 L83.562852,49.605 C83.942852,49.25 84.133852,48.783 84.133852,48.204 L84.133852,48.204 C84.133852,47.27 83.700852,46.624 82.834852,46.268 L82.834852,46.268 C81.968852,45.912 81.446852,45.468 81.269852,44.933 L81.269852,44.933 C81.092852,44.399 81.004852,43.086 81.004852,40.994 L81.004852,40.994 L81.004852,38.591 L81.004852,35.588 C81.004852,31.494 80.903852,28.657 80.701852,27.077 L80.701852,27.077 C80.501852,25.496 80.098852,24.083 79.494852,22.837 L79.494852,22.837 C77.684852,19.545 74.325852,17.898 69.416852,17.898 L69.416852,17.898 C67.364852,17.898 65.514852,18.338 63.865852,19.218 L63.865852,19.218 Z" id="Unison" stroke="#000000" fill="url(#linearGradient-1)"></path>
+ </g>
+</svg>
\ No newline at end of file
diff --git a/man/Makefile b/man/Makefile
new file mode 100644
index 0000000..00829c8
--- /dev/null
+++ b/man/Makefile
@@ -0,0 +1,22 @@
+-include ../src/Makefile.ProjectInfo
+
+all:: $(NAME).1
+
+../src/$(NAME)$(EXEC_EXT):
+ $(MAKE) -C ../src UISTYLE=text
+
+$(NAME).1: $(NAME).1.in opt_short.tmp opt_full.tmp
+ sed -e '/@OPTIONS_SHORT@/r ./opt_short.tmp' \
+ -e '/@OPTIONS_SHORT@/d' \
+ -e '/@OPTIONS_FULL@/r ./opt_full.tmp' \
+ -e '/@OPTIONS_FULL@/d' $(NAME).1.in > $(NAME).1
+
+# Listing of preferences
+opt_short.tmp: ../src/$(NAME)$(EXEC_EXT)
+ ../src/$(NAME)$(EXEC_EXT) -prefsman short > opt_short.tmp
+
+opt_full.tmp: ../src/$(NAME)$(EXEC_EXT)
+ ../src/$(NAME)$(EXEC_EXT) -prefsman full > opt_full.tmp
+
+clean::
+ $(RM) *.tmp $(NAME).1
diff --git a/man/unison.1.in b/man/unison.1.in
new file mode 100644
index 0000000..e2397e5
--- /dev/null
+++ b/man/unison.1.in
@@ -0,0 +1,518 @@
+.\" Unison file synchronizer: man/unison.1
+.\" Copyright 1999-2022, Unison authors
+.\"
+.\" This program is free software: you can redistribute it and/or modify
+.\" it under the terms of the GNU General Public License as published by
+.\" the Free Software Foundation, either version 3 of the License, or
+.\" (at your option) any later version.
+.\"
+.\" This program is distributed in the hope that it will be useful,
+.\" but WITHOUT ANY WARRANTY; without even the implied warranty of
+.\" MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+.\" GNU General Public License for more details.
+.\"
+.\" You should have received a copy of the GNU General Public License
+.\" along with this program. If not, see <http://www.gnu.org/licenses/>.
+.\"
+.Dd March 17, 2022
+.Os unison
+.Dt UNISON 1 URM
+.Sh NAME
+.Nm unison
+.Nd a multi-platform bi-directional file synchronization tool
+.Sh SYNOPSIS
+.Nm
+.Op Ar options
+.Nm
+.Ar root1 root2
+.Op Ar options
+.Nm
+.Ar profilename
+.Op Ar options
+.Sh DESCRIPTION
+.Nm Unison
+is a file-synchronization tool for POSIX-compliant systems (e.g. *BSD and
+GNU/Linux), macOS and Windows. It allows two replicas of a collection of files
+and directories to be stored on different hosts (or different disks on the same
+host), modified separately, and then brought up to date by propagating the
+changes in each replica to the other.
+.Pp
+Unison has been in use for over 20 years and many people use it to synchronize
+data they care about.
+.Pp
+Unison shares a number of features with other tools. Some of the distinguishing
+features are:
+.Bl -bullet -compact
+.It
+Unlike simple mirroring or backup utilities, Unison can deal with updates to
+both replicas of a distributed directory structure.
+.It
+Unison works across platforms, allowing you to synchronize a Windows laptop
+with a Unix server, for example.
+.It
+Unlike most distributed filesystems, Unison is a user-level program that simply
+uses normal systems calls: there is no need to modify the kernel, to have
+superuser privileges on either host, or to have a FUSE implementation.
+.It
+Unison works between any pair of machines connected to the internet, typically
+communicating over
+.Xr ssh 1 ,
+but also directly over TCP. It is careful with network bandwidth, and runs well
+over slow links. Transfers of small updates to large files are optimized using
+a compression protocol similar to
+.Xr rsync 1 .
+.It
+Unison is resilient to failure. It is careful to leave the replicas and its own
+private structures in a sensible state at all times, even in case of abnormal
+termination or communication failures.
+.El
+.Sh OPTION SUMMARY
+@OPTIONS_SHORT@
+.Sh OPTIONS
+Most of the options can be given as command line arguments or in a profile. On
+command line, but not in a profile, the options are specified with a leading
+dash. Like this:
+.Fl option .
+@OPTIONS_FULL@
+.Sh ROOTS
+A replica’s root tells Unison where to find a set of files to be synchronized,
+either on the local machine or on
+a remote host. For example,
+.Pp
+.Dl relative/path/of/root
+.Pp
+specifies a local root relative to the directory where Unison is started, while
+.Pp
+.Dl /absolute/path/of/root
+.Pp
+specifies a root relative to the top of the local filesystem, independent of
+where Unison is running. Remote roots can begin with
+.Sy ssh://
+to indicate that the remote server should be started with
+.Xr ssh 1 :
+.Pp
+.Dl ssh://remotehost//absolute/path/of/root
+.Dl ssh://user@remotehost/relative/path/of/root
+.Pp
+If the remote server is already running (in the socket mode), then the syntax
+.Pp
+.Dl socket://remotehost:portnum//absolute/path/of/root
+.Dl socket://remotehost:portnum/relative/path/of/root
+.Dl socket://[IPv6literal]:portnum/path
+.Pp
+is used to specify the hostname and the port that the client Unison should use
+to contact it. Syntax
+.Pp
+.Dl socket://{path/of/socket}//absolute/path/of/root
+.Dl socket://{path/of/socket}/relative/path/of/root
+.Pp
+is used to specify the Unix domain socket the client Unison should use to
+contact the server.
+.Pp
+The syntax for roots is based on that of URIs (described in RFC 2396). The full
+grammar is:
+.Bd -literal
+ replica ::= [protocol:]//[user@][host][:port][/path]
+ | path
+
+ protocol ::= file
+ | socket
+ | ssh
+
+ user ::= [-_a-zA-Z0-9]+
+
+ host ::= [-_a-zA-Z0-9.]+
+ | \e[ [a-f0-9:.]+ zone? \e] IPv6 literals (no future format).
+ | { [^}]+ } For Unix domain sockets only.
+
+ zone ::= %[-_a-zA-Z0-9~%.]+
+
+ port ::= [0-9]+
+
+.Ed
+When path is given without any protocol prefix, the protocol is assumed to be
+.Sy file: .
+Under Windows, it is possible to synchronize with a remote directory using the
+.Sy file:
+protocol over the Windows Network Neighborhood. For example,
+.Pp
+.Dl unison foo //host/drive/bar
+.Pp
+synchronizes the local directory
+.Pa foo
+with the directory
+.Pa drive:\ebar
+on the machine
+.Sy host ,
+provided that host is accessible via Network Neighborhood. When the
+.Sy file:
+protocol is used in this way, there is no need for a Unison server to be
+running on the remote host. However, running Unison this way is only a good
+idea if the remote host is reached by a very fast network connection, since the
+full contents of every file in the remote replica will have to be transferred
+to the local machine to detect updates.
+.Sh PATHS
+A path refers to a point within a set of files being synchronized; it is
+specified relative to the root of the replica. Formally, a path is just a
+sequence of names, separated by /. Note that the path separator character is
+always a forward slash, no matter what operating system Unison is running on.
+The empty path (i.e., the empty sequence of names) denotes the whole replica.
+.Sh PATH SPECIFICATION
+Several Unison preferences (e.g.,
+.Sy ignore/ignorenot , follow , sortfirst/sortlast , backup , merge ,
+etc.) specify individual paths or sets of paths. These preferences share a
+common syntax based on regular expressions. Each preference is associated with
+a list of path patterns; the paths specified are those that match any one of
+the path pattern.
+.Pp
+Each pattern can have one of three forms. The most general form is a Posix
+extended regular expression introduced by the keyword
+.Sy Regex .
+(The collating sequences and character classes of full Posix regexps are not
+currently supported.)
+.Pp
+.Dl Cm Regex Ar regexp
+.Pp
+For convenience, three other styles of pattern are also recognized:
+.Pp
+.Dl Cm Name Ar name
+.Pp
+matches any path in which the last component matches
+.Ar name ,
+.Pp
+.Dl Cm Path Ar path
+.Pp
+matches exactly the path
+.Ar path ,
+and
+.Pp
+.Dl Cm BelowPath Ar path
+.Pp
+matches the path
+.Ar path
+and any path below. The
+.Ar name
+and
+.Ar path
+arguments of the latter forms of patterns are
+.Em not
+regular expressions. Instead, standard
+.Dq globbing
+conventions can be used in
+.Ar name
+and
+.Ar path :
+.Bl -dash
+.It
+a
+.Sy "*"
+matches any sequence of characters not including / (and not beginning with .,
+when used at the beginning of a
+.Ar name )
+.It
+a
+.Sy \&?
+matches any single character except / (and leading .)
+.It
+.Sy [xyz]
+matches any character from the set {x, y, z}
+.It
+.Sy {a,bb,ccc}
+matches any one of a, bb, or ccc. (Be careful not to put extra spaces after the
+commas: these will be interpreted literally as part of the strings to be
+matched!)
+.El
+.Pp
+The path separator in path patterns is always the forward-slash character
+.Dq /
+— even when the client or server is running under Windows, where the normal
+separator character is a backslash. This makes it possible to use the same set
+of path patterns for both Unix and Windows file systems.
+.Pp
+A path specification may be followed by the separator
+.Dq " -> "
+itself followed by a string which will be associated to the matching paths:
+.Pp
+.Dl Cm Path Ar path No -> Ar "associated string"
+.Pp
+Not all pathspec preferences use these associated strings but all pathspec
+preferences are parsed identically and the strings may be ignored. Only the
+last match of the separator string on the line is used as a delimiter. Thus to
+allow a path specification to contain the separator string, append an
+associated string to it, even if it is not used. The associated string cannot
+contain the separator string.
+.Sh PROFILES
+A profile is a text file that specifies permanent settings for roots, paths,
+ignore patterns, and other preferences, so that they do not need to be typed at
+the command line every time Unison is run. Profiles should reside in the
+.Pa .unison
+directory on the client machine. If Unison is started with just one argument
+.Ar name
+on the
+command line, it looks for a profile called
+.Em name Ns Sy .prf
+in the
+.Pa .unison
+directory. If it is started with no arguments, it scans the
+.Pa .unison
+directory for files whose names end in
+.Sy .prf
+and offers a menu (when using the graphical user interface; for the text
+interface, you have to use the
+.Fl i
+option). If a file named
+.Pa default.prf
+is found, its settings will be used as the default preferences.
+.Pp
+To set the value of a preference
+.Sy p
+permanently, add to the appropriate profile a line of the form
+.Pp
+.Dl p = true
+.Pp
+for a boolean flag or
+.Pp
+.Dl p = <value>
+.Pp
+for a preference of any other type.
+Whitespaces around
+.Sy p
+and the value are ignored. A profile may also include blank lines and lines
+beginning with #; both are ignored.
+.Pp
+When Unison starts, it first reads the profile and then the command line, so
+command-line options will override settings from the profile.
+.Sh TERMINATION
+When not synchronizing continuously, the text interface terminates when
+synchronization is finished normally or due to a fatal error occurring.
+.Pp
+In the text interface, to interrupt synchronization before it is finished,
+press
+.Sy Ctrl-C
+(or send signal
+.Sy SIGINT
+or
+.Sy SIGTERM ) .
+This will interrupt update propagation as quickly as possible but still
+complete proper cleanup. If the process does not stop even after pressing
+.Sy Ctrl-C
+then keep doing it repeatedly. This will bypass cleanup procedures and
+terminates the process forcibly (similar to
+.Sy SIGKILL ) .
+Doing so may leave the archives or replicas in an inconsistent state or locked.
+.Pp
+When synchronizing continuously (time interval repeat or with filesystem
+monitoring), interrupting with
+.Sy Ctrl-C
+or with signal
+.Sy SIGINT
+or
+.Sy SIGTERM
+works the same way as described above and will additionally stop the continuous
+process. To stop only the continuous process and let the last synchronization
+complete normally, send signal
+.Sy SIGUSR2
+instead.
+.Sh ENVIRONMENT
+.Bl -tag
+.It Ev UNISON
+Unison stores a variety of information in a private directory on each host. If
+the environment variable
+.Sy UNISON
+is defined, then its value will be used as the path for this directory. This
+can be just a name, or a path. If
+.Sy UNISON
+is not defined, then the directory depends on which operating system you are
+using. In Unix, the default is to use
+.Pa $HOME/.unison .
+In Windows, if the environment variable
+.Sy USERPROFILE
+is defined, then the directory will be
+.Pa $USERPROFILE\e.unison ;
+otherwise, it will be
+.Pa c:\e.unison .
+On macOS,
+.Pa $HOME/.unison
+will be used if it is present, but
+.Pa "$HOME/Library/Application Support/Unison"
+will be created and used by default.
+.It Ev UNISONLOCALHOSTNAME
+The function that finds the canonical hostname of the local host (which is
+used, for example, in calculating the name of the archive file used to remember
+which files have been synchronized) normally uses the
+.Sy gethostname
+operating system call. However, if the environment variable
+.Sy UNISONLOCALHOSTNAME
+is set, its value will be used instead. This makes it easier to use Unison in
+situations where a machine’s name changes frequently (e.g., because it is a
+laptop and gets moved around a lot).
+.It Ev UNISONBACKUPDIR
+When backups are stored centrally, the directory used to hold them is
+controlled by the preference
+.Sy backupdir
+and the environment variable
+.Sy UNISONBACKUPDIR .
+If both are specified then the environment variable overrides the preference.
+If neither of these are set, then the directory
+.Pa $UNISON/backup
+is used (see environment variable
+.Sy UNISON
+above).
+.It Ev PAGER
+Used by the text interface as the pager when displaying the differences between
+changed files.
+.It Ev NO_COLOR
+If the environment variable
+.Sy NO_COLOR
+is set then Unison's text interface will not produce any color output by
+default. The
+.Sy color
+preference overrides this environment variable.
+.El
+.Sh FILES
+.Bl -tag -compact
+.It Pa ~/.unison
+Unison stores a variety of information in a private directory on each host.
+This is the default path of this private directory. This path may be changed by
+the
+.Sy UNISON
+environment variable.
+.Pp
+.It Pa ~/.unison/*.prf
+Profile files. Each profile is stored in a file named
+.Em profilename Ns Sy .prf .
+.Pp
+.It Pa ~/.unison/ar*
+.It Pa ~/.unison/tm*
+.It Pa ~/.unison/sc*
+Main and temporary archive files. These files may be deleted if you know what
+you are doing. Deleting an archive file is equivalent to using the
+.Fl ignorearchives
+option.
+.Pp
+.It Pa ~/.unison/fp*
+Fingerprint cache files. These files may be safely deleted. Keep in mind that
+deleting a fingerprint cache file means that any unsynchronized changes must be
+scanned again. Depending on your replicas, this may mean scanning gigabytes of
+file contents.
+.Pp
+.It Pa ~/.unison/lk*
+Lock files indicating a running Unison process. These files may be deleted if
+you are careful and know that there is no Unison process currently running.
+Deleting a lock file is equivalent to using the
+.Fl ignorelocks
+option.
+.El
+.Sh EXAMPLES
+.Bl -tag -width ""
+.It Sy Synchronize two local directories
+.Pp
+.Dl unison path/to/dir1 /dir2
+.Pp
+This command synchronizes two local directories using the default options.
+Default options are defined by Unison and can be overridden by user in a
+profile called
+.Dq default ,
+which is by default stored in file
+.Pa ~/.unison/default.prf
+.It Sy Synchronize a local and a remote directory
+.Pp
+.Dl unison local/dir ssh://user@host//absolute/path
+.Pp
+This command synchronizes a local directory (here specified by a relative path)
+and a remote directory (here specified by an absolute path) using
+.Xr ssh 1
+and the default options (see example above).
+.It Sy Synchronize with all options specified in a profile
+.Pp
+.Dl unison profilename
+.Pp
+This command reads all the options from the profile named
+.Dq profilename
+and synchronizes according to those options.
+.It Sy Synchronize with options specified in a profile and roots on command line
+.Pp
+.Dl unison profilename /path/to/dir ssh://host/path/on/server
+.Pp
+This command reads all options from the profile named
+.Dq profilename
+with only the roots specified on the command line. Roots must not be specified
+in the profile as the roots from command line will not override roots in the
+profile, rather append to the list of roots.
+.It Sy Synchronize automatically
+.Pp
+.Dl unison -batch /path/to/dir ssh://host/path/on/server
+.Pp
+This command synchronizes all non-conflicting changes automatically, once.
+.It Sy Synchronize continuously
+.Pp
+.Dl unison -repeat watch /path/to/dir ssh://host/path/on/server
+.Pp
+This command first fully synchronizes the roots and then remains dormant,
+waiting for any file changes within either root and then automatically
+synchronizes these changes. This also works in a profile
+.No ( Ns Sy "repeat = watch" ) .
+If the filesystem monitoring helper program is not available or not desired for
+other reasons, it is possible to make Unison synchronize repeatedly with a
+defined time interval:
+.Pp
+.Dl unison -repeat 60 /path/to/dir ssh://host/path/on/server
+.Pp
+This command synchronizes every 60 seconds. Using
+.Fl repeat
+implies
+.Fl batch .
+.Pp
+Currently, continuous synchronization is not possible when using the GUI.
+.El
+.Sh DIAGNOSTICS
+When running in the textual mode, Unison returns an exit status, which
+describes whether, and at which level, the synchronization was successful. The
+exit status could be useful when Unison is invoked from a script. Currently,
+there are four possible values for the exit status:
+.Bl -tag -width 1m
+.It 0
+successful synchronization; everything is up-to-date now.
+.It 1
+some files were skipped, but all file transfers were successful.
+.It 2
+non-fatal failures occurred during file transfer.
+.It 3
+a fatal error occurred, or the execution was interrupted.
+.El
+.Pp
+The graphical interface does not return any useful information through the exit
+status.
+.Sh COMPATIBILITY
+If you are using Unison versions \*(>= 2.52 on all machines, you do not have to
+do anything extra for compatibility.
+.Pp
+Historically (versions \*(Lt 2.52), Unison versions had to be matched
+relatively exactly for them to work together. Additionally, the version of
+compiler used to build Unison also had significant relevance for compatibility.
+.Pp
+As of version 2.52, Unison has a degree of backward and forward compatibility.
+This means three things. First, it is possible for local and remote machines to
+run a different version of Unison. Second, it is possible for local and remote
+machines to run a version (same or different) of Unison built with a different
+version of compiler. Lastly, it is possible to upgrade Unison on the local
+machine and keep the existing archive.
+.Pp
+For more information on co-existence of versions \*(Lt 2.52 and \*(>= 2.52, see
+.Lk https://github.com/bcpierce00/unison/wiki/2.52-Migration-Guide
+.Sh SEE ALSO
+There is a full user manual (pdf, html and txt) included with Unison and
+available online. Depending on your operating system, this manual may have been
+installed at
+.Pa /usr/share/doc/unison/
+or a similar location. The manual can also be read in the GUI (look in the Help
+menu) or on the command line by
+.Sy unison -doc all
+(you probably want to pipe the output to a pager).
+.Pp
+.Lk https://github.com/bcpierce00/unison
+.Pp
+.Lk https://www.cis.upenn.edu/~bcpierce/unison/
+.\" .Sh STANDARDS
+.\" .Sh HISTORY
+.\" .Sh BUGS
diff --git a/setup/README.md b/setup/README.md
deleted file mode 100644
index 226bd28..0000000
--- a/setup/README.md
+++ /dev/null
@@ -1,9 +0,0 @@
-This directory contains the files for creating setups for Microsoft Windows using [Inno Setup](https://github.com/jrsoftware/issrc).
-
-Building Unison setup
----------------------
-
-* Download GTK 2 runtime and place it in directory `bin`
-* Download Unison binaries from https://www.irif.fr/~vouillon/unison/ and place Unison GTK binary together with `unison-fsmonitor.exe` in directory `bin`
-* Download `plink.exe` and `putty.exe` from https://www.chiark.greenend.org.uk/~sgtatham/putty/latest.html and place both in directory `bin`
-* Open `Unison.iss` by Inno Setup, adjust version information and compile it
diff --git a/setup/Unison.iss b/setup/Unison.iss
deleted file mode 100644
index 061d681..0000000
--- a/setup/Unison.iss
+++ /dev/null
@@ -1,50 +0,0 @@
-#define MyAppName "Unison"
-#define MyAppURL "http://www.cis.upenn.edu/~bcpierce/unison/"
-#define MyAppExeName "unison 2.48.4 GTK.exe"
-#define ProductVersion "2.48.4"
-
-[Setup]
-AppId={{2B41C63F-C8D0-411C-8BB5-8AACD2BA33ED}
-AppName={#MyAppName}
-AppVersion={#ProductVersion}
-AppVerName={#MyAppName} {#ProductVersion}
-AppCopyright=Benjamin Pierce
-AppPublisher=Benjamin Pierce
-AppPublisherURL={#MyAppURL}
-AppSupportURL={#MyAppURL}/lists.html
-CreateAppDir=yes
-DefaultDirName={pf}\{#MyAppName}
-DefaultGroupName={#MyAppName}
-DisableDirPage=auto
-DisableProgramGroupPage=yes
-LicenseFile=../LICENSE
-InfoAfterFile=postinstall.txt
-OutputDir=.
-OutputBaseFilename=unison{#ProductVersion}_setup
-Compression=lzma
-SolidCompression=yes
-UninstallDisplayIcon={app}\{#MyAppExeName}
-VersionInfoVersion={#ProductVersion}
-
-[Languages]
-Name: "english"; MessagesFile: "compiler:Default.isl"
-Name: "french"; MessagesFile: "compiler:Languages\French.isl"
-Name: "german"; MessagesFile: "compiler:Languages\German.isl"
-
-[Tasks]
-Name: "desktopicon"; Description: "{cm:CreateDesktopIcon}"; GroupDescription: "{cm:AdditionalIcons}"
-
-[Files]
-Source: "plink.bat"; DestDir: "{app}"; Flags: ignoreversion
-Source: "..\bin\*"; DestDir: "{app}"; Flags: ignoreversion recursesubdirs
-
-[Icons]
-Name: "{group}\{#MyAppName}"; Filename: "{app}\{#MyAppExeName}"
-Name: "{group}\{cm:UninstallProgram,{#MyAppName}}"; Filename: "{uninstallexe}"
-Name: "{commondesktop}\{#MyAppName}"; Filename: "{app}\{#MyAppExeName}"; Tasks: desktopicon
-
-[Run]
-Filename: "{app}\{#MyAppExeName}"; Description: "{cm:LaunchProgram,{#MyAppName}}"; Flags: postinstall shellexec
-
-[Messages]
-BeveledLabel=Inno Setup
diff --git a/setup/plink.bat b/setup/plink.bat
deleted file mode 100644
index 3c159bb..0000000
--- a/setup/plink.bat
+++ /dev/null
@@ -1 +0,0 @@
-@plink %1 %2 %3 -v -load Unison "unison -server -contactquietly"
\ No newline at end of file
diff --git a/setup/postinstall.txt b/setup/postinstall.txt
deleted file mode 100644
index 84d307b..0000000
--- a/setup/postinstall.txt
+++ /dev/null
@@ -1 +0,0 @@
-Create a SSH configuration named "Unison" using Putty from the installation directory or edit "plink.bat" file and replace "Unison" by an existing configuration name.
\ No newline at end of file
diff --git a/src/.depend b/src/.depend
index 432a1f4..dc358a3 100644
--- a/src/.depend
+++ b/src/.depend
@@ -13,10 +13,13 @@ abort.cmx : \
abort.cmi : \
uutil.cmi
bytearray.cmo : \
+ ubase/umarshal.cmi \
bytearray.cmi
bytearray.cmx : \
+ ubase/umarshal.cmx \
bytearray.cmi
-bytearray.cmi :
+bytearray.cmi : \
+ ubase/umarshal.cmi
case.cmo : \
uutil.cmi \
ubase/util.cmi \
@@ -50,6 +53,7 @@ clroot.cmi :
common.cmo : \
uutil.cmi \
ubase/util.cmi \
+ ubase/umarshal.cmi \
ubase/safelist.cmi \
props.cmi \
path.cmi \
@@ -62,6 +66,7 @@ common.cmo : \
common.cmx : \
uutil.cmx \
ubase/util.cmx \
+ ubase/umarshal.cmx \
ubase/safelist.cmx \
props.cmx \
path.cmx \
@@ -73,6 +78,7 @@ common.cmx : \
common.cmi
common.cmi : \
uutil.cmi \
+ ubase/umarshal.cmi \
props.cmi \
path.cmi \
osx.cmi \
@@ -80,22 +86,12 @@ common.cmi : \
name.cmi \
fspath.cmi \
fileinfo.cmi
-compat402.cmo :
-compat402.cmx :
-compat403.cmo :
-compat403.cmx :
-compat408.cmo : \
- compat408.cmi
-compat408.cmx : \
- compat408.cmi
-compat408.cmi :
-configure.cmo :
-configure.cmx :
copy.cmo : \
xferhint.cmi \
uutil.cmi \
ubase/util.cmi \
update.cmi \
+ ubase/umarshal.cmi \
transfer.cmi \
ubase/trace.cmi \
ubase/safelist.cmi \
@@ -124,6 +120,7 @@ copy.cmx : \
uutil.cmx \
ubase/util.cmx \
update.cmx \
+ ubase/umarshal.cmx \
transfer.cmx \
ubase/trace.cmx \
ubase/safelist.cmx \
@@ -159,24 +156,36 @@ copy.cmi : \
common.cmi
external.cmo : \
ubase/util.cmi \
+ terminal.cmi \
system.cmi \
ubase/safelist.cmi \
+ remote.cmi \
lwt/lwt_util.cmi \
lwt/lwt_unix.cmi \
lwt/lwt.cmi \
external.cmi
external.cmx : \
ubase/util.cmx \
+ terminal.cmx \
system.cmx \
ubase/safelist.cmx \
+ remote.cmx \
lwt/lwt_util.cmx \
lwt/lwt_unix.cmx \
lwt/lwt.cmx \
external.cmi
external.cmi : \
lwt/lwt.cmi
+features.cmo : \
+ ubase/util.cmi \
+ features.cmi
+features.cmx : \
+ ubase/util.cmx \
+ features.cmi
+features.cmi :
fileinfo.cmo : \
ubase/util.cmi \
+ ubase/umarshal.cmi \
system.cmi \
props.cmi \
ubase/prefs.cmi \
@@ -188,6 +197,7 @@ fileinfo.cmo : \
fileinfo.cmi
fileinfo.cmx : \
ubase/util.cmx \
+ ubase/umarshal.cmx \
system.cmx \
props.cmx \
ubase/prefs.cmx \
@@ -198,7 +208,7 @@ fileinfo.cmx : \
fs.cmx \
fileinfo.cmi
fileinfo.cmi : \
- system.cmi \
+ ubase/umarshal.cmi \
props.cmi \
ubase/prefs.cmi \
path.cmi \
@@ -209,6 +219,7 @@ files.cmo : \
uutil.cmi \
ubase/util.cmi \
update.cmi \
+ ubase/umarshal.cmi \
ubase/trace.cmi \
system.cmi \
stasher.cmi \
@@ -239,6 +250,7 @@ files.cmx : \
uutil.cmx \
ubase/util.cmx \
update.cmx \
+ ubase/umarshal.cmx \
ubase/trace.cmx \
system.cmx \
stasher.cmx \
@@ -266,7 +278,6 @@ files.cmx : \
files.cmi
files.cmi : \
uutil.cmi \
- system.cmi \
props.cmi \
path.cmi \
lwt/lwt_util.cmi \
@@ -280,6 +291,7 @@ fileutil.cmi :
fingerprint.cmo : \
uutil.cmi \
ubase/util.cmi \
+ ubase/umarshal.cmi \
path.cmi \
fspath.cmi \
fs.cmi \
@@ -287,17 +299,20 @@ fingerprint.cmo : \
fingerprint.cmx : \
uutil.cmx \
ubase/util.cmx \
+ ubase/umarshal.cmx \
path.cmx \
fspath.cmx \
fs.cmx \
fingerprint.cmi
fingerprint.cmi : \
uutil.cmi \
+ ubase/umarshal.cmi \
path.cmi \
fspath.cmi
fpcache.cmo : \
uutil.cmi \
ubase/util.cmi \
+ ubase/umarshal.cmi \
ubase/trace.cmi \
system.cmi \
ubase/safelist.cmi \
@@ -312,6 +327,7 @@ fpcache.cmo : \
fpcache.cmx : \
uutil.cmx \
ubase/util.cmx \
+ ubase/umarshal.cmx \
ubase/trace.cmx \
system.cmx \
ubase/safelist.cmx \
@@ -324,7 +340,6 @@ fpcache.cmx : \
fileinfo.cmx \
fpcache.cmi
fpcache.cmi : \
- system.cmi \
props.cmi \
path.cmi \
osx.cmi \
@@ -332,9 +347,11 @@ fpcache.cmi : \
fspath.cmi \
fileinfo.cmi
fs.cmo : \
+ system.cmi \
fspath.cmi \
fs.cmi
fs.cmx : \
+ system.cmx \
fspath.cmx \
fs.cmi
fs.cmi : \
@@ -398,6 +415,7 @@ fsmonitor/windows/watcher.cmx : \
fspath.cmo : \
uutil.cmi \
ubase/util.cmi \
+ ubase/umarshal.cmi \
system.cmi \
ubase/rx.cmi \
path.cmi \
@@ -407,6 +425,7 @@ fspath.cmo : \
fspath.cmx : \
uutil.cmx \
ubase/util.cmx \
+ ubase/umarshal.cmx \
system.cmx \
ubase/rx.cmx \
path.cmx \
@@ -414,13 +433,14 @@ fspath.cmx : \
fileutil.cmx \
fspath.cmi
fspath.cmi : \
- system.cmi \
+ ubase/umarshal.cmi \
path.cmi \
name.cmi
fswatch.cmo : \
uutil.cmi \
ubase/util.cmi \
ubase/trace.cmi \
+ terminal.cmi \
system.cmi \
ubase/prefs.cmi \
path.cmi \
@@ -432,6 +452,7 @@ fswatch.cmx : \
uutil.cmx \
ubase/util.cmx \
ubase/trace.cmx \
+ terminal.cmx \
system.cmx \
ubase/prefs.cmx \
path.cmx \
@@ -478,6 +499,7 @@ fswatchold.cmi : \
fspath.cmi
globals.cmo : \
ubase/util.cmi \
+ ubase/umarshal.cmi \
ubase/trace.cmi \
ubase/safelist.cmi \
remote.cmi \
@@ -485,6 +507,7 @@ globals.cmo : \
pred.cmi \
path.cmi \
os.cmi \
+ negotiate.cmi \
name.cmi \
lwt/lwt_util.cmi \
lwt/lwt_unix.cmi \
@@ -494,6 +517,7 @@ globals.cmo : \
globals.cmi
globals.cmx : \
ubase/util.cmx \
+ ubase/umarshal.cmx \
ubase/trace.cmx \
ubase/safelist.cmx \
remote.cmx \
@@ -501,6 +525,7 @@ globals.cmx : \
pred.cmx \
path.cmx \
os.cmx \
+ negotiate.cmx \
name.cmx \
lwt/lwt_util.cmx \
lwt/lwt_unix.cmx \
@@ -509,20 +534,18 @@ globals.cmx : \
clroot.cmx \
globals.cmi
globals.cmi : \
+ terminal.cmi \
ubase/prefs.cmi \
pred.cmi \
path.cmi \
lwt/lwt.cmi \
- common.cmi
-linkgtk.cmo : \
- main.cmo
-linkgtk.cmx : \
- main.cmx
-linkgtk2.cmo : \
- uigtk2.cmi \
+ common.cmi \
+ clroot.cmi
+linkgtk3.cmo : \
+ uigtk3.cmi \
main.cmo
-linkgtk2.cmx : \
- uigtk2.cmx \
+linkgtk3.cmx : \
+ uigtk3.cmx \
main.cmx
linktext.cmo : \
uitext.cmi \
@@ -538,18 +561,7 @@ lock.cmx : \
ubase/util.cmx \
system.cmx \
lock.cmi
-lock.cmi : \
- system.cmi
-lwt/example/editor.cmo : \
- lwt/lwt_unix.cmi
-lwt/example/editor.cmx : \
- lwt/lwt_unix.cmx
-lwt/example/relay.cmo : \
- lwt/lwt_unix.cmi \
- lwt/lwt.cmi
-lwt/example/relay.cmx : \
- lwt/lwt_unix.cmx \
- lwt/lwt.cmx
+lock.cmi :
lwt/generic/lwt_unix_impl.cmo : \
lwt/pqueue.cmi \
lwt/lwt.cmi
@@ -581,9 +593,11 @@ lwt/pqueue.cmx : \
lwt/pqueue.cmi
lwt/pqueue.cmi :
lwt/win/lwt_unix_impl.cmo : \
+ system/system_win.cmo \
lwt/pqueue.cmi \
lwt/lwt.cmi
lwt/win/lwt_unix_impl.cmx : \
+ system/system_win.cmx \
lwt/pqueue.cmx \
lwt/lwt.cmx
lwt/win/lwt_win.cmo : \
@@ -597,6 +611,7 @@ main.cmo : \
ubase/util.cmi \
uitext.cmi \
uicommon.cmi \
+ system.cmi \
strings.cmi \
ubase/safelist.cmi \
remote.cmi \
@@ -607,6 +622,7 @@ main.cmx : \
ubase/util.cmx \
uitext.cmx \
uicommon.cmx \
+ system.cmx \
strings.cmx \
ubase/safelist.cmx \
remote.cmx \
@@ -614,17 +630,42 @@ main.cmx : \
os.cmx
name.cmo : \
ubase/util.cmi \
+ ubase/umarshal.cmi \
ubase/rx.cmi \
case.cmi \
name.cmi
name.cmx : \
ubase/util.cmx \
+ ubase/umarshal.cmx \
ubase/rx.cmx \
case.cmx \
name.cmi
-name.cmi :
+name.cmi : \
+ ubase/umarshal.cmi
+negotiate.cmo : \
+ ubase/util.cmi \
+ ubase/umarshal.cmi \
+ ubase/safelist.cmi \
+ remote.cmi \
+ lwt/lwt.cmi \
+ features.cmi \
+ common.cmi \
+ negotiate.cmi
+negotiate.cmx : \
+ ubase/util.cmx \
+ ubase/umarshal.cmx \
+ ubase/safelist.cmx \
+ remote.cmx \
+ lwt/lwt.cmx \
+ features.cmx \
+ common.cmx \
+ negotiate.cmi
+negotiate.cmi : \
+ lwt/lwt.cmi \
+ common.cmi
os.cmo : \
ubase/util.cmi \
+ ubase/umarshal.cmi \
ubase/trace.cmi \
system.cmi \
ubase/safelist.cmi \
@@ -641,6 +682,7 @@ os.cmo : \
os.cmi
os.cmx : \
ubase/util.cmx \
+ ubase/umarshal.cmx \
ubase/trace.cmx \
system.cmx \
ubase/safelist.cmx \
@@ -657,7 +699,7 @@ os.cmx : \
os.cmi
os.cmi : \
uutil.cmi \
- props.cmi \
+ ubase/umarshal.cmi \
path.cmi \
name.cmi \
fspath.cmi \
@@ -665,8 +707,8 @@ os.cmi : \
osx.cmo : \
uutil.cmi \
ubase/util.cmi \
+ ubase/umarshal.cmi \
ubase/trace.cmi \
- system.cmi \
ubase/safelist.cmi \
ubase/prefs.cmi \
path.cmi \
@@ -678,8 +720,8 @@ osx.cmo : \
osx.cmx : \
uutil.cmx \
ubase/util.cmx \
+ ubase/umarshal.cmx \
ubase/trace.cmx \
- system.cmx \
ubase/safelist.cmx \
ubase/prefs.cmx \
path.cmx \
@@ -690,12 +732,14 @@ osx.cmx : \
osx.cmi
osx.cmi : \
uutil.cmi \
+ ubase/umarshal.cmi \
ubase/prefs.cmi \
path.cmi \
fspath.cmi \
fingerprint.cmi
path.cmo : \
ubase/util.cmi \
+ ubase/umarshal.cmi \
ubase/safelist.cmi \
ubase/rx.cmi \
pred.cmi \
@@ -705,6 +749,7 @@ path.cmo : \
path.cmi
path.cmx : \
ubase/util.cmx \
+ ubase/umarshal.cmx \
ubase/safelist.cmx \
ubase/rx.cmx \
pred.cmx \
@@ -713,12 +758,14 @@ path.cmx : \
case.cmx \
path.cmi
path.cmi : \
+ ubase/umarshal.cmi \
pred.cmi \
name.cmi
pixmaps.cmo :
pixmaps.cmx :
pred.cmo : \
ubase/util.cmi \
+ ubase/umarshal.cmi \
ubase/safelist.cmi \
ubase/rx.cmi \
ubase/prefs.cmi \
@@ -726,40 +773,61 @@ pred.cmo : \
pred.cmi
pred.cmx : \
ubase/util.cmx \
+ ubase/umarshal.cmx \
ubase/safelist.cmx \
ubase/rx.cmx \
ubase/prefs.cmx \
case.cmx \
pred.cmi
-pred.cmi :
+pred.cmi : \
+ ubase/prefs.cmi
props.cmo : \
uutil.cmi \
ubase/util.cmi \
+ ubase/umarshal.cmi \
+ system.cmi \
+ ubase/safelist.cmi \
+ propsdata.cmi \
ubase/prefs.cmi \
+ pred.cmi \
path.cmi \
osx.cmi \
- lwt/lwt_unix.cmi \
fspath.cmi \
fs.cmi \
- external.cmi \
+ features.cmi \
props.cmi
props.cmx : \
uutil.cmx \
ubase/util.cmx \
+ ubase/umarshal.cmx \
+ system.cmx \
+ ubase/safelist.cmx \
+ propsdata.cmx \
ubase/prefs.cmx \
+ pred.cmx \
path.cmx \
osx.cmx \
- lwt/lwt_unix.cmx \
fspath.cmx \
fs.cmx \
- external.cmx \
+ features.cmx \
props.cmi
props.cmi : \
uutil.cmi \
+ ubase/umarshal.cmi \
ubase/prefs.cmi \
+ pred.cmi \
path.cmi \
osx.cmi \
fspath.cmi
+propsdata.cmo : \
+ ubase/util.cmi \
+ ubase/safelist.cmi \
+ propsdata.cmi
+propsdata.cmx : \
+ ubase/util.cmx \
+ ubase/safelist.cmx \
+ propsdata.cmi
+propsdata.cmi :
recon.cmo : \
uutil.cmi \
ubase/util.cmi \
@@ -776,6 +844,7 @@ recon.cmo : \
globals.cmi \
fileinfo.cmi \
common.cmi \
+ clroot.cmi \
recon.cmi
recon.cmx : \
uutil.cmx \
@@ -793,6 +862,7 @@ recon.cmx : \
globals.cmx \
fileinfo.cmx \
common.cmx \
+ clroot.cmx \
recon.cmi
recon.cmi : \
props.cmi \
@@ -801,6 +871,7 @@ recon.cmi : \
remote.cmo : \
uutil.cmi \
ubase/util.cmi \
+ ubase/umarshal.cmi \
ubase/trace.cmi \
terminal.cmi \
system.cmi \
@@ -811,15 +882,14 @@ remote.cmo : \
lwt/lwt_unix.cmi \
lwt/lwt.cmi \
fspath.cmi \
- fs.cmi \
common.cmi \
clroot.cmi \
- case.cmi \
bytearray.cmi \
remote.cmi
remote.cmx : \
uutil.cmx \
ubase/util.cmx \
+ ubase/umarshal.cmx \
ubase/trace.cmx \
terminal.cmx \
system.cmx \
@@ -830,14 +900,15 @@ remote.cmx : \
lwt/lwt_unix.cmx \
lwt/lwt.cmx \
fspath.cmx \
- fs.cmx \
common.cmx \
clroot.cmx \
- case.cmx \
bytearray.cmx \
remote.cmi
remote.cmi : \
+ ubase/umarshal.cmi \
+ terminal.cmi \
ubase/prefs.cmi \
+ lwt/lwt_util.cmi \
lwt/lwt.cmi \
fspath.cmi \
common.cmi \
@@ -865,6 +936,7 @@ stasher.cmo : \
xferhint.cmi \
ubase/util.cmi \
update.cmi \
+ ubase/umarshal.cmi \
system.cmi \
ubase/safelist.cmi \
remote.cmi \
@@ -888,6 +960,7 @@ stasher.cmx : \
xferhint.cmx \
ubase/util.cmx \
update.cmx \
+ ubase/umarshal.cmx \
system.cmx \
ubase/safelist.cmx \
remote.cmx \
@@ -928,42 +1001,46 @@ system/generic/system_impl.cmo : \
system/system_generic.cmo
system/generic/system_impl.cmx : \
system/system_generic.cmx
-system/system_generic.cmo :
-system/system_generic.cmx :
-system/system_intf.cmo :
-system/system_intf.cmx :
+system/system_generic.cmo : \
+ ubase/umarshal.cmi
+system/system_generic.cmx : \
+ ubase/umarshal.cmx
+system/system_intf.cmo : \
+ ubase/umarshal.cmi
+system/system_intf.cmx : \
+ ubase/umarshal.cmx
system/system_win.cmo : \
- unicode.cmi \
system/system_generic.cmo \
ubase/rx.cmi
system/system_win.cmx : \
- unicode.cmx \
system/system_generic.cmx \
ubase/rx.cmx
system/win/system_impl.cmo : \
- system/system_win.cmo \
- system/system_generic.cmo
+ system/system_win.cmo
system/win/system_impl.cmx : \
- system/system_win.cmx \
- system/system_generic.cmx
+ system/system_win.cmx
terminal.cmo : \
+ ubase/util.cmi \
system.cmi \
ubase/rx.cmi \
lwt/lwt_unix.cmi \
lwt/lwt.cmi \
terminal.cmi
terminal.cmx : \
+ ubase/util.cmx \
system.cmx \
ubase/rx.cmx \
lwt/lwt_unix.cmx \
lwt/lwt.cmx \
terminal.cmi
terminal.cmi : \
- lwt/lwt_unix.cmi
+ lwt/lwt_unix.cmi \
+ lwt/lwt.cmi
test.cmo : \
uutil.cmi \
ubase/util.cmi \
update.cmi \
+ ubase/umarshal.cmi \
uicommon.cmi \
transport.cmi \
ubase/trace.cmi \
@@ -987,6 +1064,7 @@ test.cmx : \
uutil.cmx \
ubase/util.cmx \
update.cmx \
+ ubase/umarshal.cmx \
uicommon.cmx \
transport.cmx \
ubase/trace.cmx \
@@ -1010,6 +1088,7 @@ test.cmi :
transfer.cmo : \
uutil.cmi \
ubase/util.cmi \
+ ubase/umarshal.cmi \
ubase/trace.cmi \
ubase/safelist.cmi \
lwt/lwt.cmi \
@@ -1019,6 +1098,7 @@ transfer.cmo : \
transfer.cmx : \
uutil.cmx \
ubase/util.cmx \
+ ubase/umarshal.cmx \
ubase/trace.cmx \
ubase/safelist.cmx \
lwt/lwt.cmx \
@@ -1027,6 +1107,7 @@ transfer.cmx : \
transfer.cmi
transfer.cmi : \
uutil.cmi \
+ ubase/umarshal.cmi \
lwt/lwt.cmi \
bytearray.cmi
transport.cmo : \
@@ -1066,41 +1147,52 @@ transport.cmi : \
lwt/lwt.cmi \
common.cmi
tree.cmo : \
+ ubase/umarshal.cmi \
ubase/safelist.cmi \
tree.cmi
tree.cmx : \
+ ubase/umarshal.cmx \
ubase/safelist.cmx \
tree.cmi
-tree.cmi :
+tree.cmi : \
+ ubase/umarshal.cmi
ubase/myMap.cmo : \
+ ubase/umarshal.cmi \
ubase/myMap.cmi
ubase/myMap.cmx : \
+ ubase/umarshal.cmx \
ubase/myMap.cmi
-ubase/myMap.cmi :
+ubase/myMap.cmi : \
+ ubase/umarshal.cmi
ubase/prefs.cmo : \
ubase/util.cmi \
+ ubase/umarshal.cmi \
ubase/uarg.cmi \
system.cmi \
ubase/safelist.cmi \
ubase/prefs.cmi
ubase/prefs.cmx : \
ubase/util.cmx \
+ ubase/umarshal.cmx \
ubase/uarg.cmx \
system.cmx \
ubase/safelist.cmx \
ubase/prefs.cmi
ubase/prefs.cmi : \
ubase/util.cmi \
- system.cmi
+ ubase/umarshal.cmi
ubase/projectInfo.cmo :
ubase/projectInfo.cmx :
ubase/proplist.cmo : \
ubase/util.cmi \
+ ubase/umarshal.cmi \
ubase/proplist.cmi
ubase/proplist.cmx : \
ubase/util.cmx \
+ ubase/umarshal.cmx \
ubase/proplist.cmi
-ubase/proplist.cmi :
+ubase/proplist.cmi : \
+ ubase/umarshal.cmi
ubase/rx.cmo : \
ubase/rx.cmi
ubase/rx.cmx : \
@@ -1113,17 +1205,20 @@ ubase/safelist.cmx : \
ubase/safelist.cmi :
ubase/trace.cmo : \
ubase/util.cmi \
+ ubase/umarshal.cmi \
system.cmi \
ubase/safelist.cmi \
ubase/prefs.cmi \
ubase/trace.cmi
ubase/trace.cmx : \
ubase/util.cmx \
+ ubase/umarshal.cmx \
system.cmx \
ubase/safelist.cmx \
ubase/prefs.cmx \
ubase/trace.cmi
ubase/trace.cmi : \
+ ubase/umarshal.cmi \
ubase/prefs.cmi
ubase/uarg.cmo : \
ubase/util.cmi \
@@ -1136,6 +1231,11 @@ ubase/uarg.cmx : \
ubase/safelist.cmx \
ubase/uarg.cmi
ubase/uarg.cmi :
+ubase/umarshal.cmo : \
+ ubase/umarshal.cmi
+ubase/umarshal.cmx : \
+ ubase/umarshal.cmi
+ubase/umarshal.cmi :
ubase/util.cmo : \
system.cmi \
ubase/safelist.cmi \
@@ -1146,14 +1246,15 @@ ubase/util.cmx : \
ubase/safelist.cmx \
ubase/projectInfo.cmx \
ubase/util.cmi
-ubase/util.cmi : \
- system.cmi
+ubase/util.cmi :
ui.cmi :
uicommon.cmo : \
xferhint.cmi \
uutil.cmi \
ubase/util.cmi \
update.cmi \
+ ubase/umarshal.cmi \
+ transport.cmi \
ubase/trace.cmi \
system.cmi \
stasher.cmi \
@@ -1174,15 +1275,19 @@ uicommon.cmo : \
fspath.cmi \
files.cmi \
fileinfo.cmi \
+ features.cmi \
common.cmi \
clroot.cmi \
case.cmi \
+ abort.cmi \
uicommon.cmi
uicommon.cmx : \
xferhint.cmx \
uutil.cmx \
ubase/util.cmx \
update.cmx \
+ ubase/umarshal.cmx \
+ transport.cmx \
ubase/trace.cmx \
system.cmx \
stasher.cmx \
@@ -1203,17 +1308,21 @@ uicommon.cmx : \
fspath.cmx \
files.cmx \
fileinfo.cmx \
+ features.cmx \
common.cmx \
clroot.cmx \
case.cmx \
+ abort.cmx \
uicommon.cmi
uicommon.cmi : \
uutil.cmi \
+ ubase/umarshal.cmi \
+ terminal.cmi \
ubase/prefs.cmi \
path.cmi \
lwt/lwt.cmi \
common.cmi
-uigtk2.cmo : \
+uigtk3.cmo : \
uutil.cmi \
ubase/util.cmi \
update.cmi \
@@ -1222,6 +1331,7 @@ uigtk2.cmo : \
uicommon.cmi \
transport.cmi \
ubase/trace.cmi \
+ terminal.cmi \
system.cmi \
strings.cmi \
sortri.cmi \
@@ -1231,16 +1341,15 @@ uigtk2.cmo : \
ubase/prefs.cmi \
pixmaps.cmo \
path.cmi \
- os.cmi \
- lwt/lwt_util.cmi \
lwt/lwt_unix.cmi \
lwt/lwt.cmi \
globals.cmi \
common.cmi \
clroot.cmi \
case.cmi \
- uigtk2.cmi
-uigtk2.cmx : \
+ abort.cmi \
+ uigtk3.cmi
+uigtk3.cmx : \
uutil.cmx \
ubase/util.cmx \
update.cmx \
@@ -1249,6 +1358,7 @@ uigtk2.cmx : \
uicommon.cmx \
transport.cmx \
ubase/trace.cmx \
+ terminal.cmx \
system.cmx \
strings.cmx \
sortri.cmx \
@@ -1258,70 +1368,17 @@ uigtk2.cmx : \
ubase/prefs.cmx \
pixmaps.cmx \
path.cmx \
- os.cmx \
- lwt/lwt_util.cmx \
lwt/lwt_unix.cmx \
lwt/lwt.cmx \
globals.cmx \
common.cmx \
clroot.cmx \
case.cmx \
- uigtk2.cmi
-uigtk2.cmi : \
+ abort.cmx \
+ uigtk3.cmi
+uigtk3.cmi : \
uicommon.cmi
uimacbridge.cmo : \
- xferhint.cmi \
- uutil.cmi \
- ubase/util.cmi \
- update.cmi \
- uicommon.cmi \
- transport.cmi \
- ubase/trace.cmi \
- terminal.cmi \
- system.cmi \
- stasher.cmi \
- ubase/safelist.cmi \
- remote.cmi \
- recon.cmi \
- ubase/prefs.cmi \
- path.cmi \
- os.cmi \
- main.cmo \
- lwt/lwt_util.cmi \
- lwt/lwt_unix.cmi \
- lwt/lwt.cmi \
- globals.cmi \
- fspath.cmi \
- files.cmi \
- common.cmi \
- clroot.cmi
-uimacbridge.cmx : \
- xferhint.cmx \
- uutil.cmx \
- ubase/util.cmx \
- update.cmx \
- uicommon.cmx \
- transport.cmx \
- ubase/trace.cmx \
- terminal.cmx \
- system.cmx \
- stasher.cmx \
- ubase/safelist.cmx \
- remote.cmx \
- recon.cmx \
- ubase/prefs.cmx \
- path.cmx \
- os.cmx \
- main.cmx \
- lwt/lwt_util.cmx \
- lwt/lwt_unix.cmx \
- lwt/lwt.cmx \
- globals.cmx \
- fspath.cmx \
- files.cmx \
- common.cmx \
- clroot.cmx
-uimacbridgenew.cmo : \
xferhint.cmi \
uutil.cmi \
ubase/util.cmi \
@@ -1340,7 +1397,6 @@ uimacbridgenew.cmo : \
path.cmi \
os.cmi \
main.cmo \
- lwt/lwt_util.cmi \
lwt/lwt_unix.cmi \
lwt/lwt.cmi \
globals.cmi \
@@ -1348,7 +1404,7 @@ uimacbridgenew.cmo : \
files.cmi \
common.cmi \
clroot.cmi
-uimacbridgenew.cmx : \
+uimacbridge.cmx : \
xferhint.cmx \
uutil.cmx \
ubase/util.cmx \
@@ -1367,7 +1423,6 @@ uimacbridgenew.cmx : \
path.cmx \
os.cmx \
main.cmx \
- lwt/lwt_util.cmx \
lwt/lwt_unix.cmx \
lwt/lwt.cmx \
globals.cmx \
@@ -1380,6 +1435,7 @@ uitext.cmo : \
ubase/util.cmi \
update.cmi \
unicode.cmi \
+ ubase/umarshal.cmi \
uicommon.cmi \
transport.cmi \
ubase/trace.cmi \
@@ -1390,18 +1446,20 @@ uitext.cmo : \
recon.cmi \
ubase/prefs.cmi \
path.cmi \
- lwt/lwt_util.cmi \
lwt/lwt_unix.cmi \
lwt/lwt.cmi \
globals.cmi \
fswatchold.cmi \
+ fspath.cmi \
common.cmi \
+ abort.cmi \
uitext.cmi
uitext.cmx : \
uutil.cmx \
ubase/util.cmx \
update.cmx \
unicode.cmx \
+ ubase/umarshal.cmx \
uicommon.cmx \
transport.cmx \
ubase/trace.cmx \
@@ -1412,12 +1470,13 @@ uitext.cmx : \
recon.cmx \
ubase/prefs.cmx \
path.cmx \
- lwt/lwt_util.cmx \
lwt/lwt_unix.cmx \
lwt/lwt.cmx \
globals.cmx \
fswatchold.cmx \
+ fspath.cmx \
common.cmx \
+ abort.cmx \
uitext.cmi
uitext.cmi : \
uicommon.cmi
@@ -1434,6 +1493,7 @@ update.cmo : \
xferhint.cmi \
uutil.cmi \
ubase/util.cmi \
+ ubase/umarshal.cmi \
tree.cmi \
ubase/trace.cmi \
system.cmi \
@@ -1458,6 +1518,7 @@ update.cmo : \
fpcache.cmi \
fingerprint.cmi \
fileinfo.cmi \
+ features.cmi \
common.cmi \
case.cmi \
update.cmi
@@ -1465,6 +1526,7 @@ update.cmx : \
xferhint.cmx \
uutil.cmx \
ubase/util.cmx \
+ ubase/umarshal.cmx \
tree.cmx \
ubase/trace.cmx \
system.cmx \
@@ -1489,11 +1551,13 @@ update.cmx : \
fpcache.cmx \
fingerprint.cmx \
fileinfo.cmx \
+ features.cmx \
common.cmx \
case.cmx \
update.cmi
update.cmi : \
uutil.cmi \
+ ubase/umarshal.cmi \
tree.cmi \
props.cmi \
path.cmi \
@@ -1507,15 +1571,18 @@ update.cmi : \
common.cmi
uutil.cmo : \
ubase/util.cmi \
+ ubase/umarshal.cmi \
ubase/trace.cmi \
ubase/projectInfo.cmo \
uutil.cmi
uutil.cmx : \
ubase/util.cmx \
+ ubase/umarshal.cmx \
ubase/trace.cmx \
ubase/projectInfo.cmx \
uutil.cmi
-uutil.cmi :
+uutil.cmi : \
+ ubase/umarshal.cmi
xferhint.cmo : \
ubase/util.cmi \
ubase/trace.cmi \
diff --git a/src/FEATURES.md b/src/FEATURES.md
new file mode 100644
index 0000000..67f7ed5
--- /dev/null
+++ b/src/FEATURES.md
@@ -0,0 +1,185 @@
+# Introduction and motivation
+
+"Features" is a set of feature names supported by a specific version of
+Unison implementation. Over time, each incompatible change -- whether
+mandatory or an optional add-on -- is assigned a unique feature name.
+
+Features allow a client to connect to and properly work with a server of
+different version, older or newer. When setting up the connection, both
+server and client negotiate a commonly supported set of features.
+
+Using features instead of a version makes the implementation agnostic of any
+versioning schemes, forks and third party implementations. It also allows
+for more flexible code changes over time, without the code being polluted by
+adding more and more conditionals for various version combinations, such as
+"if version < X then", "if version >= Y and version < Z then", and so on.
+
+# Negotiation
+
+Feature negotiation takes place immediately after the RPC connection has
+been fully set up. See `negotiate.ml`.
+
+1. Client sends its full feature set to the server.
+2. Server validates the intersection of its and client's feature sets.
+ - If error then server sends NOK to client. The client closes connection.
+3. If OK then server sends intersection of feature sets to the client.
+4. Client validates the intersection.
+ - If error then client closes connection.
+5. If OK then the negotiation is complete and both server and client will
+ use only features fully supported by both.
+
+## Feature registration
+
+A feature is added to the set by registering it. This can be done by any
+part of the code that "owns" a feature, similar to how user preferences are
+registered. See `features.mli` and `features.ml`.
+
+Registering a feature requires a unique feature name and an optional
+validation function.
+
+## Feature validation
+
+Each feature can provide a separate validation function. When validating
+the intersection of client's and server's feature sets, validation
+functions for each included feature are run in arbitrary sequence.
+
+A validation function will be able to see the entire intersection and can
+freely decide whether the intersection is ok or not. Examples of possible
+validation scenarios:
+
+- A mandatory feature is not in the intersection
+ - This typically means that counterparty is too old, but could also mean
+ that the counterparty is too new and the feature has been removed.
+- User preference enabled for a feature not in intersection
+ (the preferences have not been sent to the server yet, so this
+ validation is not carried out by the server)
+- A feature depends on another feature not in intersection
+
+Some features in the intersection can conflict with each other. This can
+happen for example when two different implementations of a function are
+both supported but must not be used simultaneously. All such conflicts
+are benign in nature and will not cause feature intersection validation
+to fail. (Since the intersection is a subset of the entire feature set
+then failing a conflict would mean that the set of features is conflicting
+to begin with.)
+
+# Development
+
+Every incompatible code change must result in a change to the set of
+features:
+
+- New code that is mandatory to use (effectively breaks compatibility
+ with older versions despite feature negotiation) ->
+ - Register a new feature with a validation function that rejects any
+ feature intersection that does not include this feature
+- New code that is optional to use ->
+ - Register a new feature
+- New code that replaces existing code ->
+ - Register a new feature and remove one or more features
+- Remove existing code ->
+ - Remove one or more features
+- Code is not removed but it can be deprecated ->
+ - Add or change a validation function to output a deprecation warning
+
+## User preferences
+
+User preferences are sent from client to server after establishing a
+connection. The server must know all preferences received from the client,
+otherwise the connection fails.
+
+When new preferences are created with a new feature, it is possible (and in
+most cases required) to add a guard function that determines if the
+preference is sent to the server or not. Typically, this guard function
+will take the form `fun () -> Features.enabled somefeature`, meaning that
+the preference is sent to server if and only if 'somefeature' is known by
+the server.
+
+## Code evolution, conflicting features
+
+With features, new code does not have to replace existing code even if
+they seemingly conflict. Both an existing feature and a new feature can
+co-exist. The code must be guarded by checking which features are enabled
+at runtime for each remote connection.
+
+For example:
+
+- Existing code implements feature hash-1.
+- New code implements a new hashing algorithm and adds feature hash-2.
+- Even though two different hashing algorithms must not be used at the
+ same time, both implementations can co-exist as in the following
+ pseudocode example.
+
+```
+function hash
+ if (feature hash-2 enabled) then
+ new algorithm
+ else if (feature hash-1 enabled) then
+ previous algorithm
+ end
+```
+
+- If both server and client support hash-2 then the new implementation
+ will always be used, even if both server and client also support hash-1
+ at the same time.
+- If either server or client does not support hash-2 then the feature
+ intersection will only contain hash-1 and the previous implementation
+ will be used.
+
+Now let's imagine that in addition to hashing algorithm changing with
+the new feature, also the result type changes. This is trickier to implement
+but clearly not impossible.
+
+There are multiple ways of handling parallel implementation of conflicting
+types. These are not the topic of this document, but a few possibilities
+are provided for inspiration:
+
+- Abstract types and type variables
+- Variant types (aka sum types)
+- Extensible variant types
+- First class modules
+- GADTs
+- Classes/objects
+
+### Archive file
+
+Most changes will ultimately result in type changes. This will directly
+impact data encoded in wire format and stored in archive file format.
+
+Data on the wire is transient. As both client and server have agreed on
+a common feature set, they know how to marshal and unmarshal data on the
+wire without any issues.
+
+Data in the archive file is persistent and could have been written while
+a different set of features was agreed upon. There are a couple of ways
+to read and write archive files in this scenario:
+
+- Not even attempt to read an incompatible archive file. The exact used
+ feature set is written into the archive file. As long as both client and
+ server keep negotiating the same feature set, they can read existing
+ archive files. When the negotiated feature set changes (due to upgrades),
+ the previous archive files can be ignored (requires a complete rescan).
+ This may be acceptable, as such upgrades are assumed to be quite rare.
+
+- A subset of the used feature set is written into the archive file. Only
+ features that change the data structures written in the archive file are
+ stored in the file. The reading can work in two ways. Either as a slightly
+ more forgiving variant of the point above, or actually reading and
+ unmarshaling the archive according to the features used to write it --
+ even if not all the same features are included in the currently negotiated
+ feature set. The latter is the currently chosen approach. It does require
+ types and code be tailored for this, the same as with the next point below,
+ but to a lesser degree.
+
+- The archive file on-disk format includes information about the types and
+ structure of the written data (you can think like a DB with a relatively
+ dynamic but still typed schema). The data can be read back selectively,
+ and even converted as necessary (for example, can read a stored int32 into
+ in-memory int64).
+ The selective reading can mean two things. First, the archive was written
+ with a feature that is no longer enabled. The data that was only relevant
+ to that feature is just skipped. Second, the archive was written without
+ a feature that is now enabled. For the newly-enabled feature there is no
+ data in the archive but this does not break reading the file, as long as
+ the new feature can deal with default or "empty" values for its data
+ structures.
+
diff --git a/src/INSTALL b/src/INSTALL
deleted file mode 100644
index 379c2e9..0000000
--- a/src/INSTALL
+++ /dev/null
@@ -1,2 +0,0 @@
-For installation instructions, see the the INSTALLATION section of the
-user manual.
diff --git a/src/INSTALL.gtk2 b/src/INSTALL.gtk2
deleted file mode 100644
index beaefa6..0000000
--- a/src/INSTALL.gtk2
+++ /dev/null
@@ -1,60 +0,0 @@
-[UPDATE 1/2019: The instructions below are rather old, and there may
-be simpler ways now. For example, on some systems, just doing "opam
-install lablgtk" seems to be enough to get all the support ibraries
-installed.]
-
-We are happy to announce a new version of Unison with a user interface
-based on Gtk 2.2, enabling display of filenames with any locale encoding.
-
-Installation instructions follow:
-
------------------------------
-LINUX (and maybe other Unixes):
-
-In order to use gtk2 with unison,
-
-1) install glib, pango, gtk (version >2.2)
- from http://www.gtk.org/
-
-2) install lablgtk2 (version >20030423)
- from http://wwwfun.kurims.kyoto-u.ac.jp/soft/olabl/lablgtk.html
-
-3) install unison (version >2.9.36)
- from http://www.cis.upenn.edu/~bcpierce/unison/
-
- Simply type 'make'.
-
- Makefile will detect the presence of lablgtk2 directory
- $(OCAMLLIBDIR)/lablgtk2 (such as /usr/local/lib/ocaml/lablgtk2/)
- and use UISTYLE=gtk2 by default. If absent, it falls back to
- lablgtk with UISTYLE=gtk, then back to UISTYLE=text.
-
- You can force the selection by
- make UISTYLE=gtk2
- or make UISTYLE=gtk
- or make UISTYLE=text
-
-4) setup your locale environment properly
- for example, export LANG=zh_HK.BIG5-HKSCS
-
- otherwise, you will get
- Uncaught exception Glib.GError("Invalid byte sequence in conversion input")
-5) enjoy unison with i18n!
-
------------------------------
-OS X:
-
-1) Install gtk2 using fink:
-
- sudo /sw/bin/fink install gtk+2
-
- Then proceed from step 2 above.
-
-In our tests, the linker generates lots of error messages, but appears
-to build a working executable. Also, we have not yet been able to get
-this build to work with 'STATIC=true'.
-
------------------------------
-WINDOWS:
-
-(Anybody want to contribute instructions??)
diff --git a/src/INSTALL.win32-msvc b/src/INSTALL.win32-msvc
index b7e1a61..7aa3eeb 100644
--- a/src/INSTALL.win32-msvc
+++ b/src/INSTALL.win32-msvc
@@ -218,7 +218,7 @@ above the 'lablgtk' directory.
The way from public Gtk/LablGtk sources to the provided Gtk/LablGtk
dynamic/static extension has been somehow perilous. We strongly
-recommand using the provided sources and patches as a base for your
+recommend using the provided sources and patches as a base for your
further enhancements.
To be exhaustive, here are the steps followed to create the provided
diff --git a/src/Makefile b/src/Makefile
index f109b93..b2e72c7 100644
--- a/src/Makefile
+++ b/src/Makefile
@@ -1,8 +1,6 @@
-#######################################################################
-# $I1: Unison file synchronizer: src/Makefile $
-# $I2: Last modified by bcpierce on Sun, 22 Aug 2004 22:29:04 -0400 $
-# $I3: Copyright 1999-2020 (see COPYING for details) $
-#######################################################################
+# Unison file synchronizer: src/Makefile
+# Copyright 1999-2022 (see ../LICENSE for terms).
+
## User Settings
# Set NATIVE=false if you are not using the native code compiler (ocamlopt)
@@ -24,27 +22,11 @@ NATIVE=true
######################################################################
# Building installation instructions
+.PHONY: all
all:: strings.ml buildexecutable
-all:: INSTALL
-
-.PHONY: all clean install doinstall installtext text \
- setupdemo-old setupdemo modifydemo demo \
- run runbatch runt rundebug runp runtext runsort runprefer \
- prefsdocs runtest repeattest \
- selftest selftestdebug selftestremote testmerge \
- checkin installremote
-
-.DELETE_ON_ERROR:
-# to avoid problems when something fails to run
-
-INSTALL: $(NAME)$(EXEC_EXT)
-# file isn't made for OS X, so check that it's there first
- (if [ -f $(NAME) ]; then ./$(NAME) -doc install > INSTALLATION; fi)
-
########################################################################
## Miscellaneous developer-only switches
-DEBUGGING=true
PROFILING=false
STATIC=false
@@ -57,164 +39,29 @@ STATIC=false
include Makefile.OCaml
######################################################################
-# Installation
-
-INSTALLDIR = $(HOME)/bin/
-
-# This has two names because on OSX the file INSTALL shadows the target 'install'!
-install: doinstall
-
-installtext:
- $(MAKE) -C .. installtext
-
-text:
- $(MAKE) -C .. text
-
-# Note that this is not needed (and doesn't work) for the OSX GUI version.
-# Just copy $(UIMACDIR)/build/Default/Unison.app to where you want it.
-doinstall: buildexecutable
- @if [ ! $(NAME) ]; then \
- echo "makefile variable NAME not bound"; \
- exit 1 \
- ; fi
- -mv $(INSTALLDIR)/$(NAME)$(EXEC_EXT) /tmp/$(NAME)-$(shell echo $$$$)
- cp $(NAME)$(EXEC_EXT) $(INSTALLDIR)
- cp $(NAME)$(EXEC_EXT) $(INSTALLDIR)$(NAME)-$(MAJORVERSION)$(EXEC_EXT)
-
-######################################################################
-# Demo
-
-setupdemo-old: all
- -mkdir alice.tmp bob.tmp
- -touch alice.tmp/letter alice.tmp/curriculum
- -mkdir bob.tmp/curriculum
- -touch bob.tmp/curriculum/french
- -touch bob.tmp/curriculum/german
- -mkdir bob.tmp/good_friends
- -mkdir bob.tmp/good_friends/addresses
- -mkdir alice.tmp/good_friends
- -touch alice.tmp/good_friends/addresses
- -touch bob.tmp/good_friends/addresses/alice
- -mkdir alice.tmp/book
- -mkdir bob.tmp/book
- echo "first name:alice \n 2234 Chesnut Street \n Philadelphia" \
- > bob.tmp/good_friends/addresses/alice
- echo "ADDRESS 1 : BOB \n firstName : bob \n 2233 Walnut Street" \
- > alice.tmp/good_friends/addresses
- echo "Born in Paris in 1976 ..." > alice.tmp/curriculum
- echo "Ne a Paris en 1976 ..." > bob.tmp/curriculum/french
- echo "Geboren in Paris im jahre 1976 ..." > bob.tmp/curriculum/german
- echo "Dear friend, I received your letter ..." > alice.tmp/letter
- echo "And then the big bad wolf" > bob.tmp/book/page3
- echo "Title : three little pigs" > alice.tmp/book/page1
- echo "there was upon a time ..." > alice.tmp/book/page2
-
-setupdemo:
- rm -rf a.tmp b.tmp
- mkdir a.tmp
- touch a.tmp/a a.tmp/b a.tmp/c
- mkdir a.tmp/d
- touch a.tmp/d/f
- touch a.tmp/d/g
- cp -r a.tmp b.tmp
-
-modifydemo:
- -rm a.tmp/a
- echo "Hello" > a.tmp/b
- echo "Hello" > b.tmp/b
- date > b.tmp/c
- echo "Hi there" > a.tmp/d/h
- echo "Hello there" > b.tmp/d/h
-
-demo: all setupdemo
- @$(MAKE) run
- @$(MAKE) modifydemo
- @$(MAKE) run
-
-run: all
- -mkdir a.tmp b.tmp
- -date > a.tmp/x
- -date > b.tmp/y
- ./$(NAME) default a.tmp b.tmp
-
-runbatch: all
- -mkdir a.tmp b.tmp
- -date > a.tmp/x
- -date > b.tmp/y
- ./$(NAME) default a.tmp b.tmp -batch
-
-runt: all
- -mkdir a.tmp b.tmp
- -date > a.tmp/x
- -date > b.tmp/y
- ./$(NAME) default a.tmp b.tmp -timers
-
-rundebug: all
- -date > a.tmp/x
- -date > b.tmp/y
- ./$(NAME) a.tmp b.tmp -debug all -ui text
-
-runp: all
- -echo cat > a.tmp/cat
- -echo cat > b.tmp/cat
- -chmod 765 a.tmp/cat
- -chmod 700 b.tmp/cat
- ./$(NAME) a.tmp b.tmp
-
-runtext: all
- -mkdir a.tmp b.tmp
- -date > a.tmp/x
- -date > b.tmp/y
- ./$(NAME) -ui text a.tmp b.tmp
-
-runsort: all
- -mkdir a.tmp b.tmp
- -date > a.tmp/b
- -date > b.tmp/m
- -date > b.tmp/z
- -date > b.tmp/f
- -date >> b.tmp/f
- -date > b.tmp/c.$(shell echo $$$$)
- -date > b.tmp/y.$(shell echo $$$$)
- ./$(NAME) default a.tmp b.tmp -debug sort
-
-runprefer: all
- -mkdir a.tmp b.tmp
- -date > a.tmp/b
- -date > b.tmp/m
- -date > b.tmp/z
- -echo Hello > a.tmp/z
- -date > b.tmp/f
- -date >> b.tmp/f
- -date > b.tmp/c.$(shell echo $$$$)
- -date > b.tmp/y.$(shell echo $$$$)
- ./$(NAME) default a.tmp b.tmp -force b.tmp
-
-prefsdocs: all
- ./$(NAME) -prefsdocs 2> prefsdocsjunk.tmp
- mv -f prefsdocsjunk.tmp prefsdocs.tmp
-
# For developers
-runtest:
- $(MAKE) NATIVE=false DEBUG=true text
- ./unison test
+.PHONY: repeattest
repeattest:
$(MAKE) all NATIVE=false DEBUG=true UISTYLE=text
./unison noprofile a.tmp b.tmp -repeat foo.tmp -debug ui
+.PHONY: selftest
selftest:
$(MAKE) all NATIVE=false DEBUG=true UISTYLE=text
./unison -selftest -ui text -batch
+.PHONY: selftestdebug
selftestdebug:
$(MAKE) all NATIVE=false DEBUG=true UISTYLE=text
./unison -selftest -ui text -batch -debug all
+.PHONY: selftestremote
selftestremote:
$(MAKE) all NATIVE=false DEBUG=true UISTYLE=text
./unison -selftest -ui text -batch test.tmp ssh://eniac.seas.upenn.edu/test.tmp
+.PHONY: testmerge
testmerge:
$(MAKE) all NATIVE=false UISTYLE=text
-rm -rf a.tmp b.tmp
@@ -324,13 +171,14 @@ testmerge:
######################################################################
# Tags
+ETAGS=etags
+
# In Windows, tags and TAGS are the same, so make tags stops working
# after the first invocation. The .PHONY declaration makes it work
# again.
.PHONY: tags
-
tags:
- -if [ -f "`which $(ETAGS)`" ]; then \
+ @-if command -v $(ETAGS) > /dev/null ; then \
$(ETAGS) *.mli */*.mli *.ml */*.ml */*.m *.c */*.c *.txt \
*Makefile* \
; fi
@@ -343,15 +191,12 @@ TAGS:
######################################################################
# Misc
+.PHONY: clean
clean::
-$(RM) *.log *.aux *.log *.dvi *.out *.bak
-$(RM) -r obsolete
-$(RM) $(NAME) $(NAME).exe
-$(RM) $(NAME)-blob.o
-
-clean::
- $(MAKE) -C ubase clean
- $(MAKE) -C lwt clean
$(MAKE) -C fsmonitor/windows clean
ifneq ($(strip $(UIMACDIR)),)
@@ -360,14 +205,6 @@ clean::
-(cd $(UIMACDIR); $(RM) -r build ExternalSettings.xcconfig)
endif
-checkin:
- $(MAKE) -C .. checkin
-
-installremote:
- $(MAKE) UISTYLE=text
- -unison eniac -path current/unison/trunk/src -batch
- ssh eniac.seas.upenn.edu make -C current/unison/trunk/src installtext
-
####################################################################
# Documentation strings
@@ -377,3 +214,4 @@ installremote:
strings.ml:
echo "(* Dummy strings.ml *)" > strings.ml
echo "let docs = []" >> strings.ml
+
diff --git a/src/Makefile.OCaml b/src/Makefile.OCaml
index 61a8b5e..1472b2d 100644
--- a/src/Makefile.OCaml
+++ b/src/Makefile.OCaml
@@ -1,3 +1,6 @@
+# Unison file synchronizer: src/Makefile.OCaml
+# See ../LICENSE for terms.
+
####################################################################
# Makefile rules for compiling ocaml programs #
####################################################################
@@ -7,48 +10,22 @@
ifeq (${OSCOMP},cygwingnuc) # Define this if compiling with Cygwin GNU C
OSARCH=win32gnuc
- ETAGS=/bin/etags
- buildexecutable:: win32rc/unison.res.lib
-else
-# Win32 system
-ifeq (${OSTYPE},cygwin32) # Cygwin Beta 19
- OSARCH=win32
- ETAGS=/bin/etags
- buildexecutable:: win32rc/unison.res.lib
-else
-ifeq (${OSTYPE},cygwin) # Cygwin Beta 20
- OSARCH=win32
- ETAGS=/bin/etags
- buildexecutable:: win32rc/unison.res.lib
-else
-
-# Unix system
-ifeq ($(shell uname),SunOS)
- OSARCH=solaris
-else
-ifeq ($(shell uname),Darwin)
- OSARCH=osx
-else
-ifeq ($(shell uname),OpenBSD)
- OSARCH=OpenBSD
-else
-ifeq ($(shell uname),NetBSD)
- OSARCH=NetBSD
-endif
-ifeq ($(shell uname),Linux)
- OSARCH=Linux
-endif
-endif
-endif
-endif
-ETAGS=etags
-endif
-endif
-endif
-
-ifeq (${OSCOMP},cross) # Cross-compilation under Linux
+else ifeq (${OSCOMP},cross) # Cross-compilation under Linux
OSARCH=win32gnuc
EXEC_PREFIX=i686-w64-mingw32-
+else ifeq (${OSTYPE},cygwin)
+ OSARCH=win32
+else
+ # := is not POSIX but GNU make < 4.0 does not support ::= which is POSIX,
+ # and macOS ships with really outdated GNU make (4.0 released 2013).
+ # Not a problem because the entire makefile is not POSIX compatible.
+ OSARCH:=$(shell uname)
+
+ ifeq ($(OSARCH),SunOS)
+ OSARCH=solaris
+ else ifeq ($(OSARCH),Darwin)
+ OSARCH=osx
+ endif
endif
# The OCaml lib dir is used by all versions
@@ -60,7 +37,9 @@ endif
# Better(?) version, June 2005:
# OCAMLLIBDIR=$(shell ocamlc -v | tail -1 | sed -e 's/.* //g' | sed -e 's/\\/\//g' | tr -d '\r')
# Another try, Feb 2011, suggested by Ron Isaacson
-OCAMLLIBDIR=$(shell ocamlc -v | tail -1 | sed -e 's/.* //g' | tr '\\' '/' | tr -d '\r')
+# OCAMLLIBDIR=$(shell ocamlc -v | tail -1 | sed -e 's/.* //g' | tr '\\' '/' | tr -d '\r')
+# 2023: "-where" has existed since OCaml 3.01 (2000)
+OCAMLLIBDIR=$(shell ocamlc -where)
## BCP (6/05) an alternative, but not quite working, version
## suggested by Nick Montfort:
@@ -69,32 +48,44 @@ OCAMLLIBDIR=$(shell ocamlc -v | tail -1 | sed -e 's/.* //g' | tr '\\' '/' | tr -
# User interface style:
# Legal values are
# UISTYLE=text
-# UISTYLE=gtk
-# UISTYLE=gtk2
+# UISTYLE=gtk3
# UISTYLE=mac
#
# This should be set to an appropriate value automatically, depending
# on whether the lablgtk library is available
-LABLGTKLIB=$(OCAMLLIBDIR)/lablgtk
-LABLGTK2LIB=$(OCAMLLIBDIR)/lablgtk2
-##BCP [3/2007]: Removed temporarily, since the OSX UI is not working well
-## at the moment and we don't want to confuse people by building it by default
+#
+# For Windows, an additional UI style modifier is available, `UI_WINOS`
+# Legal values are
+# UI_WINOS= # *default*; builds unison purely as a Windows console ('text') or GUI ('gtk3') application
+# UI_WINOS=hybrid # (with UISTYLE=gtk3) builds unison as a hybrid application (GUI application attached to a text console)
+# * ref: <https://github.com/bcpierce00/unison/issues/778>
+#
+LABLGTK3LIB=$(OCAMLLIBDIR)/lablgtk3
ifeq ($(OSARCH),osx)
UISTYLE=mac
else
- ifeq ($(wildcard $(LABLGTK2LIB)),$(LABLGTK2LIB))
- UISTYLE=gtk2
+ ifeq ($(wildcard $(LABLGTK3LIB)),$(LABLGTK3LIB))
+ UISTYLE=gtk3
else
- LABLGTK2LIB=$(abspath $(OCAMLLIBDIR)/../lablgtk2)
- ifeq ($(wildcard $(LABLGTK2LIB)),$(LABLGTK2LIB))
- UISTYLE=gtk2
+ LABLGTK3LIB=$(abspath $(OCAMLLIBDIR)/../lablgtk3)
+ ifeq ($(wildcard $(LABLGTK3LIB)),$(LABLGTK3LIB))
+ UISTYLE=gtk3
else
UISTYLE=text
endif
endif
endif
+ifeq ($(UISTYLE), gtk2)
+buildexecutable::
+ @echo
+ @echo "gtk2 GUI is no longer available. Use UISTYLE=gtk3 or don't specify any UISTYLE."
+ @echo
+ @exit 1
+endif
+
buildexecutable::
@echo UISTYLE = $(UISTYLE)
+ @echo UI_WINOS = $(UI_WINOS)
####################################################################
### Default parameters
@@ -102,6 +93,19 @@ buildexecutable::
# Generate backtrace information for exceptions
CAMLFLAGS+=-g
+ifneq ($(strip $(CFLAGS)),)
+ CAMLCFLAGS+=-ccopt '$(CFLAGS)'
+endif
+ifneq ($(strip $(CPPFLAGS)),)
+ CAMLCFLAGS+=-ccopt '$(CPPFLAGS)'
+endif
+ifneq ($(strip $(LDFLAGS)),)
+ CAMLLDFLAGS+=-cclib '$(LDFLAGS)'
+endif
+ifneq ($(strip $(LDLIBS)),)
+ CLIBS+=-cclib '$(LDLIBS)'
+endif
+
INCLFLAGS=-I lwt -I ubase -I system
DEP_INCLFLAGS=-I lwt -I ubase -I system
CAMLFLAGS+=$(INCLFLAGS)
@@ -110,14 +114,26 @@ CAMLFLAGS+=-I system/$(SYSTEM) -I lwt/$(SYSTEM)
ifeq ($(OSARCH),win32)
# Win32 system
EXEC_EXT=.exe
- OBJ_EXT=.o
- OUTPUT_SEL=-o
+ ifeq ($(shell ocamlc -config 2> /dev/null | grep ext_obj),ext_obj: .obj)
+ OBJ_EXT=.obj
+ else
+ OBJ_EXT=.o
+ endif
+ ifeq ($(shell ocamlc -config 2> /dev/null | grep ccomp_type),ccomp_type: msvc)
+ OUTPUT_SEL=-Fo
+ CLIBS+=-cclib shell32.lib -cclib user32.lib -cclib "-link win32rc/unison.res"
+ STATICLIBS+=-cclib "-link win32rc/unison.res"
+ buildexecutable:: win32rc/unison.res
+ else
+ OUTPUT_SEL=-o
+ CLIBS+=-cclib "-link win32rc/unison.res.lib"
+ STATICLIBS+=-cclib "-link win32rc/unison.res.lib"
+ buildexecutable:: win32rc/unison.res.lib
+ endif
CWD=.
COBJS+=system/system_win_stubs$(OBJ_EXT) lwt/lwt_unix_stubs$(OBJ_EXT)
WINOBJS=system/system_win.cmo
SYSTEM=win
- CLIBS+=-cclib "-link win32rc/unison.res.lib"
- STATICLIBS+=-cclib "-link win32rc/unison.res.lib"
buildexecutable::
@echo Building for Windows
else
@@ -132,7 +148,7 @@ else
SYSTEM=win
CLIBS+=-cclib win32rc/unison.res.lib
STATIC=false # Cygwin is not MinGW :-(
- buildexecutable::
+ buildexecutable:: win32rc/unison.res.lib
@echo Building for Windows with Cygwin GNU C
else
CWD=$(shell pwd)
@@ -145,20 +161,15 @@ else
CLIBS+=-cclib -lutil
endif
endif
+ ifeq ($(OSARCH),solaris)
+ # ACL functions
+ CLIBS+=-cclib -lsec
+ endif
buildexecutable::
@echo Building for Unix
endif
endif
-ifeq ($(NATIVE), true)
- COMPATCAMLFLAGS=$(subst .cmo,.cmx, $(shell ocaml $(CWD)/configure.ml))
- COMPATOCAMLOBJS=$(subst .cmo,.cmx, $(subst .cma,.cmxa, $(shell ocaml $(CWD)/configure.ml objs)))
-else
- COMPATCAMLFLAGS=$(shell ocaml $(CWD)/configure.ml)
- COMPATOCAMLOBJS=$(shell ocaml $(CWD)/configure.ml objs)
-endif
-OCAMLOBJS+=$(COMPATOCAMLOBJS)
-
.PHONY: buildexecutable
buildexecutable::
@echo NATIVE = $(NATIVE)
@@ -184,31 +195,35 @@ else
buildexecutable:: $(NAME)$(EXEC_EXT)
endif
-MINOSXVERSION=10.6
ifeq ($(OSARCH),osx)
- CAMLFLAGS+=-ccopt -mmacosx-version-min=$(MINOSXVERSION)
- XCODEFLAGS=-arch $(shell uname -m)
+ifeq ($(strip $(XCODEFLAGS)),)
+ XCODEFLAGS=-arch $(shell uname -m) ## Prevent Xcode from trying to build universal binaries by default
+endif
endif
.PHONY: macexecutable
macexecutable:
(cd $(UIMACDIR); $(RM) -f ExternalSettings.xcconfig ; echo MARKETING_VERSION = $(VERSION) > ExternalSettings.xcconfig ; echo OCAMLLIBDIR = $(OCAMLLIBDIR) >> ExternalSettings.xcconfig)
-ifeq ($(word 1,$(sort 4.08 $(shell ocamlc -version))),4.08)
- (cd $(UIMACDIR); echo LIB_BIGARRAY = >> ExternalSettings.xcconfig)
-else
- (cd $(UIMACDIR); echo LIB_BIGARRAY = -lbigarray >> ExternalSettings.xcconfig)
-endif
(cd $(UIMACDIR); xcodebuild $(XCODEFLAGS) SYMROOT=build)
- $(CC) $(CFLAGS) -mmacosx-version-min=$(MINOSXVERSION) $(UIMACDIR)/cltool.c -o $(UIMACDIR)/build/Default/Unison.app/Contents/MacOS/cltool -framework Carbon
+ $(CC) $(CFLAGS) $(UIMACDIR)/cltool.c -o $(UIMACDIR)/build/Default/Unison.app/Contents/MacOS/cltool -framework Carbon
+ codesign --remove-signature $(UIMACDIR)/build/Default/Unison.app
+ codesign --force --sign - $(UIMACDIR)/build/Default/Unison.app/Contents/MacOS/cltool
+ codesign --force --sign - --entitlements $(UIMACDIR)/build/uimac*.build/Default/uimac.build/Unison.app.xcent $(UIMACDIR)/build/Default/Unison.app
+ codesign --verify --deep --strict $(UIMACDIR)/build/Default/Unison.app
+# cltool was added into the .app after it was signed, so the signature is now
+# broken. It must be removed, cltool separately signed, and then the entire
+# .app (re-)signed.
+
# OCaml objects for the bytecode version
# File extensions will be substituted for the native code version
OCAMLOBJS += \
+ ubase/umarshal.cmo \
ubase/rx.cmo \
\
unicode_tables.cmo unicode.cmo bytearray.cmo \
- $(WINOBJS) system/system_generic.cmo \
+ system/system_generic.cmo $(WINOBJS) \
system/$(SYSTEM)/system_impl.cmo \
system.cmo \
\
@@ -219,12 +234,12 @@ OCAMLOBJS += \
lwt/pqueue.cmo lwt/lwt.cmo lwt/lwt_util.cmo \
lwt/$(SYSTEM)/lwt_unix_impl.cmo lwt/lwt_unix.cmo \
\
- uutil.cmo case.cmo pred.cmo \
+ features.cmo uutil.cmo case.cmo pred.cmo terminal.cmo \
fileutil.cmo name.cmo path.cmo fspath.cmo fs.cmo fingerprint.cmo \
- abort.cmo osx.cmo external.cmo fswatch.cmo \
+ abort.cmo osx.cmo fswatch.cmo propsdata.cmo \
props.cmo fileinfo.cmo os.cmo lock.cmo clroot.cmo common.cmo \
- tree.cmo checksum.cmo terminal.cmo \
- transfer.cmo xferhint.cmo remote.cmo globals.cmo fswatchold.cmo \
+ tree.cmo checksum.cmo transfer.cmo xferhint.cmo \
+ remote.cmo external.cmo negotiate.cmo globals.cmo fswatchold.cmo \
fpcache.cmo update.cmo copy.cmo stasher.cmo \
files.cmo sortri.cmo recon.cmo transport.cmo \
strings.cmo uicommon.cmo uitext.cmo test.cmo
@@ -233,9 +248,10 @@ OCAMLOBJS+=main.cmo
# OCaml libraries for the bytecode version
# File extensions will be substituted for the native code version
-OCAMLLIBS+=unix.cma str.cma bigarray.cma
+OCAMLLIBS+=unix.cma str.cma
+INCLFLAGS+=-I +unix -I +str
-COBJS+=osxsupport$(OBJ_EXT) pty$(OBJ_EXT) bytearray_stubs$(OBJ_EXT) hash_compat$(OBJ_EXT)
+COBJS+=osxsupport$(OBJ_EXT) pty$(OBJ_EXT) bytearray_stubs$(OBJ_EXT) hash_compat$(OBJ_EXT) props_xattr$(OBJ_EXT) props_acl$(OBJ_EXT)
########################################################################
### User Interface setup
@@ -245,11 +261,11 @@ ifeq ($(UISTYLE), text)
OCAMLOBJS+=linktext.cmo
endif
-## New Mac UI, 2014 version
+## Mac UI
ifeq ($(UISTYLE),mac)
- OCAMLOBJS+=uimacbridgenew.cmo
+ OCAMLOBJS+=uimacbridge.cmo
OCAMLLIBS+=threads.cma
- INCLFLAGS+=-thread
+ INCLFLAGS+=-I +threads
endif
## Graphic UI
@@ -268,29 +284,25 @@ endif
# console when click-started
ifeq ($(OSARCH), win32)
ifneq ($(UISTYLE), text)
-# COBJS+=winmain.c
- CFLAGS+=-ccopt "-link -Wl,--subsystem,windows"
+ ifneq ($(UI_WINOS), hybrid)
+ # COBJS+=winmain.c
+ CAMLLDFLAGS+=-cclib "-link -Wl,--subsystem,windows"
+ endif
endif
endif
-# Gtk GUI
-ifeq ($(UISTYLE), gtk)
- CAMLFLAGS+=-I +lablgtk
- OCAMLOBJS+=pixmaps.cmo uigtk.cmo linkgtk.cmo
- OCAMLLIBS+=lablgtk.cma
-endif
-
-# Gtk2 GUI
+# Gtk3 GUI
OCAMLFIND := $(shell command -v ocamlfind 2> /dev/null)
-ifeq ($(UISTYLE), gtk2)
+ifeq ($(UISTYLE), gtk3)
ifndef OCAMLFIND
- CAMLFLAGS+=-I +lablgtk2
+ CAMLFLAGS+=-I +lablgtk3 -I +cairo2
else
- CAMLFLAGS+=$(shell $(OCAMLFIND) query -i-format lablgtk2 )
+ CAMLFLAGS+=$(shell $(OCAMLFIND) query -i-format lablgtk3 )
+ CAMLFLAGS+=$(shell $(OCAMLFIND) query -i-format cairo2 )
endif
- OCAMLOBJS+=pixmaps.cmo uigtk2.cmo linkgtk2.cmo
- OCAMLLIBS+=lablgtk.cma
+ OCAMLOBJS+=pixmaps.cmo uigtk3.cmo linkgtk3.cmo
+ OCAMLLIBS+=lablgtk3.cma cairo.cma
endif
########################################################################
@@ -322,64 +334,41 @@ DEP_INCLFLAGS+=-I fsmonitor -I fsmonitor/linux -I fsmonitor/solaris -I fsmonitor
### Static build setup
ifeq ($(STATIC), true)
- CFLAGS+=-cclib -static
+ CAMLLDFLAGS+=-cclib -static
endif
####################################################################
### Dependencies
# Include an automatically generated list of dependencies
-include .depend
-# Additional dependencied depending on the system
+-include .depend
+# Additional dependencies depending on the system
system.cmo fspath.cmo fs.cmo: system/$(SYSTEM)/system_impl.cmo
system.cmx fspath.cmx fs.cmx: system/$(SYSTEM)/system_impl.cmx
lwt/lwt_unix.cmo: lwt/$(SYSTEM)/lwt_unix_impl.cmo
lwt/lwt_unix.cmx: lwt/$(SYSTEM)/lwt_unix_impl.cmx
-ifeq ($(OSARCH), OpenBSD)
- ifeq ($(shell echo type ocamldot | ksh), file)
- OCAMLDOT=true
- endif
-else
- ifeq ($(shell echo type -t ocamldot | bash), file)
- OCAMLDOT=true
- endif
-endif
-
-ifeq ($(OSARCH), NetBSD)
- OCAMLDOT=false
-endif
-
-# Rebuild dependencies (must be invoked manually)
.PHONY: depend
depend::
- ocamldep $(DEP_INCLFLAGS) *.mli *.ml */*.ml */*.mli */*/*.ml */*/*.mli > .depend
-ifdef OCAMLDOT
- echo 'digraph G {' > dot.tmp
+ ocamlc -depend $(DEP_INCLFLAGS) *.mli *.ml */*.ml */*.mli */*/*.ml */*/*.mli > .depend
+
+.PHONY: dependgraph
+dependgraph: depend
+ echo 'digraph G {' > .depend.dot.tmp
echo '{ rank = same; "Fileinfo"; "Props"; "Fspath"; "Os"; "Path"; }'\
- >>dot.tmp
- echo '{ rank = same; "Uitext"; "Uigtk"; }'>>dot.tmp
+ >>.depend.dot.tmp
+ echo '{ rank = same; "Uitext"; "Uigtk"; }'>>.depend.dot.tmp
echo '{ rank = same; "Recon"; "Update"; "Transport"; "Files"; }'\
- >>dot.tmp
- echo '{ rank = same; "Tree"; "Safelist"; }'>>dot.tmp
- echo '{ rank = same; "Uarg"; "Prefs"; }'>>dot.tmp
- ocamldot .depend | tail -n +2 >> dot.tmp
- -dot -Tps -o DEPENDENCIES.ps dot.tmp
-endif
+ >>.depend.dot.tmp
+ echo '{ rank = same; "Tree"; "Safelist"; }'>>.depend.dot.tmp
+ echo '{ rank = same; "Uarg"; "Prefs"; }'>>.depend.dot.tmp
+ echo 'Attempting to use ocamldot and dot to produce a dependency graph:'
+ -ocamldot .depend | tail -n +2 >> .depend.dot.tmp
+ -dot -Tps -o DEPENDENCIES.ps .depend.dot.tmp
####################################################################
### Compilation boilerplate
-ifeq ($(DEBUGGING), false)
- ifneq ($(OSARCH), win32)
- ifneq ($(OSARCH), osx)
- # Strip the binary (does not work with MS compiler; might not work
- # under OSX)
- CFLAGS+=-cclib -Wl,-s
- endif
- endif
-endif
-
ifeq ($(PROFILING), true)
OCAMLC=$(EXEC_PREFIX)ocamlcp
else
@@ -395,7 +384,6 @@ ifeq ($(NATIVE), true)
CAMLFLAGS+=-p
CLIBS+=-cclib -ldl
endif
- CAMLLDFLAGS=
CAMLOBJS=$(subst .cmo,.cmx, $(subst .cma,.cmxa, $(OCAMLOBJS)))
CAMLLIBS=$(subst .cma,.cmxa, $(OCAMLLIBS))
@@ -404,10 +392,13 @@ else
## Set up for bytecode compilation
CAMLC=$(OCAMLC)
- ifeq ($(DEBUGGING), true)
- CAMLFLAGS+=-g
+ _COMPLETE_EXE=$(shell ocamlc -output-complete-exe 2>&1)
+ # -output-complete-exe is available since OCaml 4.10
+ ifneq ($(strip $(_COMPLETE_EXE)),)
+ CAMLLDFLAGS+=-custom
+ else
+ CAMLLDFLAGS+=-output-complete-exe # can safely strip the binary
endif
- CAMLLDFLAGS=-custom
CAMLOBJS=$(OCAMLOBJS)
CAMLLIBS=$(OCAMLLIBS)
@@ -418,9 +409,10 @@ WINDRES := $(or ${EXEC_PREFIX},$(filter i686-w64-mingw32- x86_64-w64-mingw32-,$(
##$(info windres='${WINDRES}')
win32rc/unison.res: win32rc/unison.rc win32rc/U.ico
- $(WINDRES) win32rc/unison.rc win32rc/unison.res
+ rc win32rc/unison.rc
-win32rc/unison.res.lib: win32rc/unison.res
+win32rc/unison.res.lib: win32rc/unison.rc win32rc/U.ico
+ $(WINDRES) win32rc/unison.rc win32rc/unison.res
$(WINDRES) win32rc/unison.res win32rc/unison.res.lib
%.ml: %.mll
@@ -429,53 +421,32 @@ win32rc/unison.res.lib: win32rc/unison.res
%.cmi : %.mli
@echo "$(CAMLC): $< ---> $@"
- $(CAMLC) $(CAMLFLAGS) $(COMPATCAMLFLAGS) -c $(CWD)/$<
-
-fswatch.cmi : ubase/prefs.cmi
+ $(CAMLC) $(CAMLFLAGS) -c $(CWD)/$<
-compat%.cmo: compat%.ml
+%.cmo: %.ml
@echo "$(OCAMLC): $< ---> $@"
- $(OCAMLC) $(COMPATCAMLFLAGS) -c $(CWD)/$<
+ $(OCAMLC) $(CAMLFLAGS) -c $(CWD)/$<
-%.cmo: %.ml $(COMPATOCAMLOBJS)
- @echo "$(OCAMLC): $< ---> $@"
- $(OCAMLC) $(CAMLFLAGS) $(COMPATCAMLFLAGS) -c $(CWD)/$<
-
-compat%.cmx: compat%.ml
+%.cmx: %.ml
@echo "$(OCAMLOPT): $< ---> $@"
- $(OCAMLOPT) $(COMPATCAMLFLAGS) -c $(CWD)/$<
-
-%.cmx: %.ml $(COMPATOCAMLOBJS)
- @echo "$(OCAMLOPT): $< ---> $@"
- $(OCAMLOPT) $(CAMLFLAGS) $(COMPATCAMLFLAGS) -c $(CWD)/$<
+ $(OCAMLOPT) $(CAMLFLAGS) -c $(CWD)/$<
%.o %.obj: %.c
@echo "$(CAMLC): $< ---> $@"
- $(CAMLC) $(CAMLFLAGS) -ccopt $(OUTPUT_SEL)$(CWD)/$@ -c $(CWD)/$<
+ $(CAMLC) $(CAMLFLAGS) $(CAMLCFLAGS) -ccopt $(OUTPUT_SEL)$(CWD)/$@ -c $(CWD)/$<
$(NAME)$(EXEC_EXT): $(CAMLOBJS) $(COBJS)
@echo Linking $@
- $(CAMLC) -verbose $(CAMLFLAGS) $(CAMLLDFLAGS) -o $@ $(CFLAGS) $(CAMLLIBS) $^ $(CLIBS)
+ $(CAMLC) -verbose $(CAMLFLAGS) $(CAMLLDFLAGS) -o $@ $(CAMLCFLAGS) $(CAMLLIBS) $^ $(CLIBS)
# Unfortunately -output-obj does not put .o files into the output, only .cmx
# files, so we have to use $(LD) to take care of COBJS.
$(NAME)-blob.o: $(CAMLOBJS) $(COBJS)
@echo Linking $@
- $(CAMLC) -dstartup -output-obj -verbose -cclib -keep_private_externs $(CAMLFLAGS) -o u-b.o $(CFLAGS) $(CAMLLIBS) $(CLIBS) $(CAMLOBJS)
+ $(CAMLC) -dstartup -output-obj -verbose -cclib -keep_private_externs $(CAMLFLAGS) -o u-b.o $(CAMLCFLAGS) $(CAMLLDFLAGS) $(CAMLLIBS) $(CLIBS) $(CAMLOBJS)
$(LD) -r -keep_private_externs -o $@ u-b.o $(COBJS)
$(RM) u-b.o
-
-# Original:
-# $(NAME)-blob.o: $(CAMLOBJS) $(COBJS)
-# @echo Linking $@
-# $(CAMLC) -output-obj -verbose $(CAMLFLAGS) -o u-b.o $(CFLAGS) $(CAMLLIBS) $(CLIBS) $(CAMLOBJS)
-# $(LD) -r -o $@ u-b.o $(COBJS)
-# $(RM) u-b.o
-
-%$(EXEC_EXT): %.ml
- $(OCAMLC) -verbose -o $@ $^
-
######################################################################
### Misc
@@ -484,10 +455,15 @@ clean::
-$(RM) -r *.o core gmon.out *~ .*~
-$(RM) -r *.obj *.lib *.exp
-$(RM) -r *.tmp *.bak?.tmp .*.bak?.tmp
- -$(RM) system/*.cm[iox] system/*.{o,obj} system/win/*~
- -$(RM) system/generic/*.cm[iox] system/generic/*.{o,obj} system/generic/*~
- -$(RM) system/win/*.cm[iox] system/win/*.{o,obj} system/win/*~
- -$(RM) fsmonitor/*.cm[iox] fsmonitor/*.{o,obj}
+ -$(RM) system/*.cm[iox] system/*.o system/*.obj system/win/*~
+ -$(RM) system/generic/*.cm[iox] system/generic/*.o system/generic/*.obj system/generic/*~
+ -$(RM) system/win/*.cm[iox] system/win/*.o system/win/*.obj system/win/*~
+ -$(RM) fsmonitor/*.cm[iox] fsmonitor/*.o fsmonitor/*.obj
+ -$(RM) .depend.dot.tmp DEPENDENCIES.ps
+ -$(RM) ubase/*.cm[ioxa] ubase/*.cmxa ubase/*.a ubase/*.o ubase/*~ ubase/*.bak
+ -$(RM) lwt/*.cm[ioxa] lwt/*.cmxa lwt/*.a lwt/*.o lwt/*.obj lwt/*~ lwt/*.bak
+ -$(RM) lwt/generic/*.cm[ioxa] lwt/generic/*.cmxa lwt/generic/*.a lwt/generic/*.o lwt/generic/*.obj lwt/generic/*~ lwt/generic/*.bak
+ -$(RM) lwt/win/*.cm[ioxa] lwt/win/*.cmxa lwt/win/*.a lwt/win/*.o lwt/win/*.obj lwt/win/*~ lwt/win/*.bak
.PHONY: paths
paths:
diff --git a/src/Makefile.ProjectInfo b/src/Makefile.ProjectInfo
index 7924ab0..5542191 100644
--- a/src/Makefile.ProjectInfo
+++ b/src/Makefile.ProjectInfo
@@ -1,5 +1,5 @@
-MAJORVERSION=2.51
+MAJORVERSION=2.53
-VERSION=2.51.5
+VERSION=2.53.3
NAME=unison
diff --git a/src/ROADMAP.txt b/src/ROADMAP.txt
index 4ca198e..6c13bdb 100644
--- a/src/ROADMAP.txt
+++ b/src/ROADMAP.txt
@@ -30,7 +30,7 @@ look next. Here's a summary of the most interesting modules:
The files linktext.ml and linkgtk.ml contain linking commands for
assembling unision with either a textual or a graphical user interface.
-(The Main module, which takes the UI as a paramter, is the only part of
+(The Main module, which takes the UI as a parameter, is the only part of
the program that is functorized.)
The module Remote handles RPC communication between clients and remote
diff --git a/src/TODO.txt b/src/TODO.txt
index b91dbbc..807e604 100644
--- a/src/TODO.txt
+++ b/src/TODO.txt
@@ -25,7 +25,7 @@ promise that anybody is going to implement it!)
- sort the list
- if there are any adjacent pairs where the first is a prefix of the
second, drop the second and mark the first as deep
- - go through the list and drop any item for whioch any PREFIX of
+ - go through the list and drop any item for which any PREFIX of
its path matches 'ignore' and doesn't match 'ignorenot'
- bulletproof, handling fatal errors and restarting completely from
scratch if necessary
@@ -83,12 +83,6 @@ It would be nice if Unison could have the "power" to copy write-protected
*** See if we can get rid of some Osx.XXX stuff (e.g. ressLength!?)
-*** Overlapping paths
- If one -path argument is a prefix of another, the same files will get
- scanned twice, found to need transferring twice, and transferred twice, but
- the first transfer messes up the second. The fix would be to throw
- away -path arguments that are suffixes of other ones.
-
* There is no way of selecting files with wildchar. I had to use
ignorenot = Name opt/root/.unison/*.prf
ignore = Name opt/root/.unison/*
@@ -100,7 +94,7 @@ It would be nice if Unison could have the "power" to copy write-protected
* If a directory does not exist in one of the host, unison (for
security reasons, which I like) pops up a window and Quit is the only
option. I would expect a message stating mere clearly on which host and
- direcory and an option to create that directory. I had recently to make
+ directory and an option to create that directory. I had recently to make
a lot of reinstalls and new pendrives and it took a long time to create
all those dirs. Someone in the list even made a script to do the job!!!
@@ -196,10 +190,6 @@ should strip symbols from binary files in 'make exportnative'
* DOCUMENTATION
* =============
-** Put a little more order on the flags and preferences -- e.g.,
- organize them into "basic preferences", "advanced preferences,"
- "expert preferences," etc. Requires hacking the Uarg module.
-
** Add something to docs about how to use 'rootalias'. Include an
explanation of the semantics, a couple of examples, and a suggestion
for how to debug what it's doing by turning on appropriate debugging
@@ -265,13 +255,6 @@ should strip symbols from binary files in 'make exportnative'
- otherwise, put them in a central place if one is given
- Update.incrVersionsOfBackups should not be externally visible
-*** Consider altering the socket method, so the server accepts connections
- only on a particular address? This would be very useful, because many people
- tunnel unison over an OpenVPN Link, and this software works with virtual
- devices and additional IP addresses on it. If unison would accept
- connections only on the virtual device, the security would be enhanced,
- because the OpenVPN key should be unavailable for the black hats.
-
*** unison -help doesn't go to stdout so it's hard to pipe it into less
===> Probably *all* output should go to stdout, not stderr (but maybe
we need a switch to recover the current behavior)
@@ -282,7 +265,7 @@ should strip symbols from binary files in 'make exportnative'
*** If a root resides on a `host' with an ever and unpredictably changing
host name (like a public login cluster with dozens of machines and a
shared file system), listing each possible host name for this root is
- not feasible. The ability of specifing patterns in rootaliases would
+ not feasible. The ability of specifying patterns in rootaliases would
help a lot in this case. I'm thinking of something like this:
rootalias = //.*//afs/cern.ch/user/n/nagya ->
//cern.ch//afs/cern.ch/user/n/nagya [NAGY Andras <nagya@inf.elte.hu>,
@@ -302,14 +285,6 @@ should strip symbols from binary files in 'make exportnative'
offer to delete them *for* the user, rather than forcing the user to
delete them manually.
-*** A switch to include NTFS ACE/ACL file permissions to be copied when
- copying from one NTFS location to another NTFS location. As I
- mentioned this is less generic, but of fundamental usefullness in
- Windows usage, as NTFS permissions are absolutely essential in many
- backup/replication situations in Windows systems. Robocopy has the
- /SEC switch, but Unison is a far better tool, and I was hoping in that
- light that Unison could implement the rights/permissions stuff also.
-
*** There is no command-line argument to tell Unison where the .unison
directory is; Unison finds it in the environment or not at all. I was
able to workaround this with a symbolic link to put .unison where it was
@@ -401,7 +376,7 @@ should strip symbols from binary files in 'make exportnative'
specify a user (and similarly a group) to unison. It would be
interpreted in a special way: if a file is owned by this user, unison
will rather consider that the owner of the file is undefined. So, when
- a file owned by an unkown user is synchronized, the file owner is set
+ a file owned by an unknown user is synchronized, the file owner is set
to the default user. Then, on the next synchronizations, unison will
consider that the owner has not been propagated and try again. [Should
be easy once the reconciler is made more modular]
@@ -418,13 +393,6 @@ should strip symbols from binary files in 'make exportnative'
start up the GUI from the command line (I would argue that people using the
GUI regularly will start it anyway by double clicking the app)
-Would be nice to have the Unison log file relative to my home directory,
- like this
- logfile = ~/.unision/log
- or
- logfile = $HOME/.unision/log
- (We should do this for *all* files that the user specifies.)
-
add a switch '-logerrors' that makes unison log error messages to a
separate file in addition to the standard logfile
@@ -533,9 +501,6 @@ If the connection to the server goes away and then comes back up, it
would be nice if Unison would transparently re-establish it (at least,
when this makes sense!)
-maybe put backup files somewhere other than in the replica (e.g. in
- $HOME/tmp, or controlled by preference)
-
Better documentation of the -backups flag, and a way to expire old backups
Add a preference that makes the reconciler ignore prefs-only differences
@@ -577,13 +542,6 @@ the local host and which side the remote host is.
* USER INTERFACE
* ==============
-** In menu Actions
- - show Diff applies to the current line, while
- - revert to unision's recommandation applies to all lines
- Should be clearer and/or homogeneous behavior.
- I would also like to have "revert to unision's recommandation" for the
- current line.
-
** in gtk ui, display green checkmark next to finished items even if their
direction indicates a conflict; do not list such items as "skipped" at
the end
@@ -663,12 +621,6 @@ the local host and which side the remote host is.
This might be a good use for "tool tips," if I knew how to make them work
using lablGTK.
-* After clicking "Create new profile" in the initial profile window and
- giving a name for the new profile, it is confusing to get dumped back
- into the profile window again and have to explicitly select the new
- profile. Would be better to skip this step and go straight into
- filling in its fields.
-
* The menu help for left/right arrow both said `transfer local to local'.
Not helpful. The items in question are pathnames, which you might not
have to abbreviate. To save space one might consider replacing any
@@ -691,10 +643,6 @@ the local host and which side the remote host is.
* [Jamey Leifer] I think "unison -doc" should be mapped to "unison
-doc topics" and the error message for the former eliminated.
-* [Jamey Leifer] Typing "unison" results in the Profiles box
- ("Select an existing profile..."). I think the help topics should be
- available here.
-
Unison's gui offers an `Actions' menu with a variety of features
regarding preferences. I would love to see an action with the following
semantics: if the two files differ only in their modification time,
@@ -747,9 +695,6 @@ If I have a change I look at the detail window. It would be nice to be
Also, it would be nice to highlight in the detailed window the
elements that have changed.
-Make it possible to select a bunch of conflicts at the same time and
- override them all together
-
The UI window should display the current roots somewhere.
There should be a -geometry command-line interface, following the usual X
@@ -787,9 +732,6 @@ It would be nice if the initial 'usage' message were not so long. Maybe
The UI for the diff functionality needs some polishing. (Also, it should
be merged with the new "merge" functionality.)
-consider separating switches into 'ordinary' and 'expert' categories,
- documented in separate sections
-
would be nice to be able to "Proceed" just the selected line
might be nice if the GUI would beep when finished syncing (needs to be
@@ -839,10 +781,6 @@ Rewrite recon.ml in a more modular way. Probably, have for each property
replicas, and returning in what the synchronization operation should be
(nothing, left, right, conflict); a combinator then merge the results.
-It would be good to have a graphical interface allowing management and
- editing of profiles, ignore patterns, etc. Or, less ambitiously, just
- have UI options for all command-line options (killServer)
-
How about a facility so that you can specify more than one pair of
file systems for a single invocation of Unison? This would be like
calling Unison multiple times, except that it would ask all the
diff --git a/src/abort.ml b/src/abort.ml
index 8e0e1f1..2d8e8e0 100644
--- a/src/abort.ml
+++ b/src/abort.ml
@@ -21,7 +21,8 @@ let debug = Trace.debug "abort"
let maxerrors =
Prefs.createInt "maxerrors" 1
- "!maximum number of errors before a directory transfer is aborted"
+ ~category:(`Advanced `General)
+ "maximum number of errors before a directory transfer is aborted"
"This preference controls after how many errors Unison aborts a \
directory transfer. Setting it to a large number allows Unison \
to transfer most of a directory even when some files fail to be \
@@ -59,12 +60,20 @@ let all () = abortAll := true
(****)
+let isAll () = !abortAll
+
+let checkAll () =
+ if !abortAll then raise (Util.Transient "Aborted by user request")
+
let check id =
debug (fun() -> Util.msg "Checking line %s\n" (Uutil.File.toString id));
- if !abortAll || errorCount id >= Prefs.read maxerrors then begin
+ checkAll ();
+ if errorCount id >= Prefs.read maxerrors then begin
debug (fun() ->
Util.msg "Abort failure for line %s\n" (Uutil.File.toString id));
raise (Util.Transient "Aborted")
end
-let testException e = (e = Util.Transient "Aborted")
+let testException e =
+ (e = Util.Transient "Aborted") ||
+ (e = Util.Transient "Aborted by user request")
diff --git a/src/abort.mli b/src/abort.mli
index eca5ed4..f63d7ef 100644
--- a/src/abort.mli
+++ b/src/abort.mli
@@ -7,9 +7,13 @@ val reset : unit -> unit
val file : Uutil.File.t -> unit
val all : unit -> unit
+(* Check whether stop of all transfers has been requested. *)
+val isAll : unit -> bool
+val checkAll : unit -> unit (* Raises a transient exception *)
+
(* Check whether an item is being aborted. A transient exception is
raised if this is the case. *)
val check : Uutil.File.t -> unit
-(* Test whether the exeption is an abort exception. *)
+(* Test whether the exception is an abort exception. *)
val testException : exn -> bool
diff --git a/src/bytearray.ml b/src/bytearray.ml
index c355175..eb3cee1 100644
--- a/src/bytearray.ml
+++ b/src/bytearray.ml
@@ -19,6 +19,8 @@ open Bigarray
type t = (char, int8_unsigned_elt, c_layout) Array1.t
+let m = Umarshal.bytearray
+
let length = Bigarray.Array1.dim
let create l = Bigarray.Array1.create Bigarray.char Bigarray.c_layout l
@@ -36,13 +38,13 @@ let unsafe_blit_to_string a i s j l =
*)
external unsafe_blit_from_string : string -> int -> t -> int -> int -> unit
- = "ml_blit_string_to_bigarray" "noalloc"
+ = "ml_blit_string_to_bigarray" [@@noalloc]
external unsafe_blit_from_bytes : bytes -> int -> t -> int -> int -> unit
- = "ml_blit_bytes_to_bigarray" "noalloc"
+ = "ml_blit_bytes_to_bigarray" [@@noalloc]
external unsafe_blit_to_bytes : t -> int -> bytes -> int -> int -> unit
- = "ml_blit_bigarray_to_bytes" "noalloc"
+ = "ml_blit_bigarray_to_bytes" [@@noalloc]
let to_string a =
let l = length a in
diff --git a/src/bytearray.mli b/src/bytearray.mli
index 8bd5528..a76c0be 100644
--- a/src/bytearray.mli
+++ b/src/bytearray.mli
@@ -4,6 +4,8 @@
type t =
(char, Bigarray.int8_unsigned_elt, Bigarray.c_layout) Bigarray.Array1.t
+val m : t Umarshal.t
+
val create : int -> t
val length : t -> int
diff --git a/src/bytearray_stubs.c b/src/bytearray_stubs.c
index 66c64ee..d2a8ffc 100644
--- a/src/bytearray_stubs.c
+++ b/src/bytearray_stubs.c
@@ -3,60 +3,55 @@
#include <string.h>
-#include "caml/intext.h"
-#include "caml/bigarray.h"
-#include "caml/memory.h"
+#include <caml/intext.h>
+#include <caml/bigarray.h>
+#include <caml/memory.h>
CAMLprim value ml_marshal_to_bigarray(value v, value flags)
{
+ CAMLparam2(v, flags);
char *buf;
intnat len;
- output_value_to_malloc(v, flags, &buf, &len);
- return alloc_bigarray(BIGARRAY_UINT8 | BIGARRAY_C_LAYOUT | BIGARRAY_MANAGED,
- 1, buf, &len);
+ caml_output_value_to_malloc(v, flags, &buf, &len);
+ CAMLreturn(
+ caml_ba_alloc_dims(CAML_BA_UINT8 | CAML_BA_C_LAYOUT | CAML_BA_MANAGED,
+ 1, buf, len));
}
-#define Array_data(a, i) (((char *) a->data) + Long_val(i))
-
-#ifndef Bytes_val
-#define Bytes_val(x) ((unsigned char *) Bp_val(x))
-#endif
-
+#define Array_data(a, i) (((char *) Caml_ba_data_val(a)) + Long_val(i))
CAMLprim value ml_unmarshal_from_bigarray(value b, value ofs)
{
- CAMLparam1(b); /* Holds [b] live until unmarshalling completes. */
- value result;
- struct caml_bigarray *b_arr = Bigarray_val(b);
- result = input_value_from_block (Array_data (b_arr, ofs),
- b_arr->dim[0] - Long_val(ofs));
+ CAMLparam2(b, ofs);
+ CAMLlocal1(result);
+ result = caml_input_value_from_block(Array_data(b, ofs),
+ Caml_ba_array_val(b)->dim[0] - Long_val(ofs));
CAMLreturn(result);
}
-CAMLprim value ml_blit_string_to_bigarray
+CAMLprim value ml_blit_bytes_to_bigarray
(value s, value i, value a, value j, value l)
{
- const char *src = String_val(s) + Long_val(i);
- char *dest = Array_data(Bigarray_val(a), j);
+ CAMLparam5(s, i, a, j, l);
+ unsigned char *src = Bytes_val(s) + Long_val(i);
+ char *dest = Array_data(a, j);
memcpy(dest, src, Long_val(l));
- return Val_unit;
+ CAMLreturn(Val_unit);
}
-CAMLprim value ml_blit_bytes_to_bigarray
+CAMLprim value ml_blit_string_to_bigarray
(value s, value i, value a, value j, value l)
{
- unsigned char *src = Bytes_val(s) + Long_val(i);
- char *dest = Array_data(Bigarray_val(a), j);
- memcpy(dest, src, Long_val(l));
- return Val_unit;
+ return ml_blit_bytes_to_bigarray(s, i, a, j, l);
}
CAMLprim value ml_blit_bigarray_to_bytes
(value a, value i, value s, value j, value l)
{
- char *src = Array_data(Bigarray_val(a), i);
+ CAMLparam5(a, i, s, j, l);
+ char *src = Array_data(a, i);
unsigned char *dest = Bytes_val(s) + Long_val(j);
memcpy(dest, src, Long_val(l));
- return Val_unit;
+ CAMLreturn(Val_unit);
}
diff --git a/src/case.ml b/src/case.ml
index aa7ddef..36f70f7 100644
--- a/src/case.ml
+++ b/src/case.ml
@@ -22,7 +22,8 @@
(* the hosts is case insensitive. *)
let caseInsensitiveMode =
Prefs.createBoolWithDefault "ignorecase"
- "!identify upper/lowercase filenames (true/false/default)"
+ ~category:(`Advanced `Sync)
+ "identify upper/lowercase filenames (true/false/default)"
("When set to {\\tt true}, this flag causes Unison to treat "
^ "filenames as case insensitive---i.e., files in the two "
^ "replicas whose names differ in (upper- and lower-case) `spelling' "
@@ -37,33 +38,37 @@ let caseInsensitiveMode =
to the other host during initialization *)
let someHostIsInsensitive =
Prefs.createBool "someHostIsInsensitive" false
+ ~category:(`Internal `Pseudo)
"*Pseudo-preference for internal use only" ""
let unicode =
Prefs.createBoolWithDefault "unicode"
- "!assume Unicode encoding in case insensitive mode"
+ ~category:(`Advanced `General)
+ "assume Unicode encoding in case insensitive mode"
"When set to {\\tt true}, this flag causes Unison to perform \
case insensitive file comparisons assuming Unicode encoding. \
This is the default. When the flag is set to {\\tt false}, \
- a Latin 1 encoding is assumed. When Unison runs in case sensitive \
- mode, this flag only makes a difference if one host is running \
- Windows or Mac OS X. Under Windows, the flag selects between using \
- the Unicode or 8bit Windows API for accessing the filesystem. \
+ Latin 1 encoding is assumed (this means that all bytes that are \
+ not letters in Latin 1 encoding will be compared byte-for-byte, \
+ even if they may be valid characters in some other encoding). \
+ When Unison runs in case sensitive mode, this flag only makes \
+ a difference if one host is running Mac OS X. \
Under Mac OS X, it selects whether comparing the filenames up to \
decomposition, or byte-for-byte."
let unicodeEncoding =
Prefs.createBool "unicodeEnc" false
+ ~category:(`Internal `Pseudo)
"*Pseudo-preference for internal use only" ""
let useUnicode () =
let pref = Prefs.read unicode in
pref = `True || pref = `Default
-let useUnicodeAPI = useUnicode
-
let unicodeCaseSensitive =
- Prefs.createBool "unicodeCS" ~local:true false
+ Prefs.createBool "unicodeCS" false
+ ~category:(`Internal `Pseudo)
+ ~local:true
"*Pseudo-preference for internal use only" ""
(* During startup the client determines the case sensitivity of each root. *)
diff --git a/src/case.mli b/src/case.mli
index 8db5621..919dba6 100644
--- a/src/case.mli
+++ b/src/case.mli
@@ -3,7 +3,6 @@
val caseInsensitiveMode : [`True|`False|`Default] Prefs.t
val unicodeEncoding : bool Prefs.t
-val useUnicodeAPI : unit -> bool
type mode = Sensitive | Insensitive | UnicodeSensitive | UnicodeInsensitive
diff --git a/src/clroot.ml b/src/clroot.ml
index 1672e7d..1008dbf 100644
--- a/src/clroot.ml
+++ b/src/clroot.ml
@@ -27,11 +27,14 @@
protocol ::= file
| socket
| ssh
- | rsh
user ::= [-_a-zA-Z0-9]+
host ::= [-_a-zA-Z0-9.]+
+ | \[ [a-f0-9:.]+ zone? \] IPv6 literals (no future format).
+ | { [^}]+ } For Unix domain sockets only.
+
+ zone ::= %[-_a-zA-Z0-9~%.]+
port ::= [0-9]+
@@ -44,7 +47,7 @@ type clroot =
ConnectLocal of
string option (* root *)
| ConnectByShell of
- string (* shell = "rsh" or "ssh" *)
+ string (* shell = "ssh" *)
* string (* name of host *)
* string option (* user name to log in as *)
* string option (* port *)
@@ -55,7 +58,7 @@ type clroot =
* string option (* root of replica in host fs *)
(* Internal datatypes used in parsing command-line roots *)
-type protocol = File | Rsh | Socket | Ssh
+type protocol = File | Socket | Ssh
type uri = protocol (* - a protocol *)
* string option (* - an optional user *)
* string option (* - an optional host *)
@@ -77,15 +80,17 @@ let getProtocolSlashSlash s =
let protocol =
match protocolName with
"file" -> File
- | "rsh" -> Rsh
+ | "rsh" ->
+ raise (Invalid_argument
+ (Printf.sprintf "protocol rsh has been deprecated, use ssh instead (optionally specifying a different sshcmd preference)"))
| "socket" -> Socket
| "ssh" -> Ssh
| "unison" ->
raise(Invalid_argument
- (Printf.sprintf "protocol unison has been deprecated, use file, ssh, rsh, or socket instead" ))
+ (Printf.sprintf "protocol unison has been deprecated, use file, ssh, or socket instead" ))
| _ ->
raise(Invalid_argument
- (Printf.sprintf "unrecognized protocol %s" protocolName)) in
+ (Printf.sprintf "\"%s\": unrecognized protocol %s" s protocolName)) in
Some(protocol,remainder)
else if Str.string_match slashSlashRegexp s 0
then Some(File,String.sub s 2 (String.length s - 2))
@@ -93,10 +98,10 @@ let getProtocolSlashSlash s =
then
let matched = Str.matched_string s in
match matched with
- "file:" | "ssh:" | "rsh:" | "socket:" ->
+ "file:" | "ssh:" | "socket:" ->
raise(Util.Fatal
(Printf.sprintf
- "ill-formed root specification %s (%s must be followed by //)"
+ "ill-formed root specification \"%s\" (%s must be followed by //)"
s matched))
| _ -> None
else None
@@ -112,23 +117,17 @@ let getUser s =
(Some beforeAt,afterAt)
else (None,s)
-(*ipv6 support*)
-let hostWithBracketsRegexp = Str.regexp "\\[.*\\]"
-let hostRegexp = Str.regexp "[-_a-zA-Z0-9.]+"
+let ipv6Regexp = "[a-f0-9:.]+\\(%[-_a-zA-Z0-9~%.]+\\)?"
+(* Hostname, IP or Unix domain socket path *)
+let hostRegexp = Str.regexp ("[-_a-zA-Z0-9%.]+\\|{[^}]+}\\|\\[\\(" ^ ipv6Regexp ^ "\\)\\]")
let getHost s =
- if Str.string_match hostWithBracketsRegexp s 0
- then
- let host' = Str.matched_string s in
- let s' = Str.string_after s (String.length host') in
- let host = String.sub host' 1 ((String.length host')-2) in
- (Some host,s')
- else if Str.string_match hostRegexp s 0
+ if Str.string_match hostRegexp s 0
then
let host = Str.matched_string s in
+ let host' = try Str.matched_group 1 s with Not_found -> host in
let s' = Str.string_after s (String.length host) in
- (Some host,s')
- else
- (None,s)
+ (Some host', s')
+ else (None,s)
let colonPortRegexp = Str.regexp ":[^/]+"
let getPort s =
@@ -152,6 +151,7 @@ let getPort s =
and path is guaranteed to be non-empty
*)
let parseUri s =
+ let s = Util.trimWhitespace s in
match getProtocolSlashSlash s with
None ->
(File,None,None,None,Some s)
@@ -170,13 +170,21 @@ let parseUri s =
(Printf.sprintf "ill-formed root specification %s" s)) in
(protocol,userOpt,hostOpt,portOpt,pathOpt)
+let parseHostPort s =
+ let (hostOpt, s1) = getHost s in
+ let (portOpt, s2) = getPort s1 in
+ if String.length s2 > 0 then
+ raise (Util.Transient
+ (Printf.sprintf "ill-formed host specification %s" s));
+ ((match hostOpt with Some h -> h | None -> ""), portOpt)
+
(* These should succeed *)
let t1 = "socket://tjim@saul.cis.upenn.edu:4040/hello/world"
let t2 = "ssh://tjim@saul/hello/world"
-let t3 = "rsh://saul:4040/hello/world"
+(*let t3 = "rsh://saul:4040/hello/world"
let t4 = "rsh://saul/hello/world"
let t5 = "rsh://saul"
-let t6 = "rsh:///hello/world"
+let t6 = "rsh:///hello/world"*)
let t7 = "///hello/world"
let t8 = "//raptor/usr/local/bin"
let t9 = "file://raptor/usr/local/bin"
@@ -189,11 +197,11 @@ let b2 = "RSH://saul/hello"
let b3 = "rsh:/saul/hello"
let b4 = "//s%aul/hello"
-let cannotAbbrevFileRx = Rx.rx "(file:|ssh:|rsh:|socket:).*"
+let cannotAbbrevFileRx = Rx.rx "(file:|ssh:|socket:).*"
let networkNameRx = Rx.rx "//.*"
(* Main external printing function *)
let clroot2string = function
- ConnectLocal None -> "."
+| ConnectLocal None | ConnectLocal (Some "") -> "."
| ConnectLocal(Some s) ->
if Rx.match_string cannotAbbrevFileRx s
then if Rx.match_string networkNameRx s
@@ -201,38 +209,45 @@ let clroot2string = function
else Printf.sprintf "file:///%s" s
else s
| ConnectBySocket(h,p,s) ->
- Printf.sprintf "socket://%s:%s/%s" h p
+ let p = if p <> "" then ":" ^ p else p in
+ let h = if String.contains h ':' && h.[0] <> '{' then "[" ^ h ^ "]" else h in
+ Printf.sprintf "socket://%s%s/%s" h p
(match s with None -> "" | Some x -> x)
| ConnectByShell(sh,h,u,p,s) ->
let user = match u with None -> "" | Some x -> x^"@" in
let port = match p with None -> "" | Some x -> ":"^x in
let path = match s with None -> "" | Some x -> x in
+ let h = if String.contains h ':' then "[" ^ h ^ "]" else h in
Printf.sprintf "%s://%s%s%s/%s" sh user h port path
-let sshversion = Prefs.createString "sshversion" ""
- "*optional version suffix for ssh command [1 or 2]"
- ("This preference can be used to control which version "
- ^ "of ssh should be used to connect to the server. Legal values are "
- ^ "1 and 2, which will cause unison to try to use \\verb|ssh1| or"
- ^ "\\verb|ssh2| instead of just \\verb|ssh| to invoke ssh. "
- ^ "The default value is empty, which will make unison use whatever "
- ^ "version of ssh is installed as the default `ssh' command.")
+(* Pref sshversion removed since 2.52 *)
+let () = Prefs.markRemoved "sshversion"
+
+let fixHost = function
+ | ConnectLocal _ as r -> r
+ | ConnectBySocket (h, "", s) ->
+ (match parseHostPort h with
+ | h, Some p -> ConnectBySocket (h, p, s)
+ | h, None -> ConnectBySocket (h, "", s))
+ | ConnectBySocket _ as r -> r
+ | ConnectByShell (sh, h, u, None, s) ->
+ let (h, p) = parseHostPort h in
+ ConnectByShell (sh, h, u, p, s)
+ | ConnectByShell _ as r -> r
(* Main external function *)
let parseRoot string =
let illegal2 s = raise(Prefs.IllegalValue
(Printf.sprintf
- "%s: %s" string s)) in
+ "\"%s\": %s" string s)) in
let (protocol,user,host,port,path) = parseUri string in
let clroot =
match protocol,user,host,port with
| _,_,None,Some _
| _,Some _,None,None
- | Rsh,_,None,_
+ | Socket, _, None, None
| Ssh,_,None,_ ->
illegal2 "missing host"
- | Rsh,_,_,Some _ ->
- illegal2 "ill-formed (cannot use a port number with rsh)"
| File,_,_,Some _ ->
illegal2 "ill-formed (cannot use a port number with file)"
| File,_,Some h,None ->
@@ -242,14 +257,16 @@ let parseRoot string =
| Some p -> ConnectLocal(Some(prefix^p)))
| File,None,None,None ->
ConnectLocal(path)
- | Socket,None,Some h,Some p ->
+ | Socket, None, Some h, Some p when h.[0] <> '{' ->
ConnectBySocket(h,p,path)
+ | Socket, None, Some h, None when h.[0] = '{' ->
+ ConnectBySocket (h, "", path)
| Socket,Some _,_,_ ->
illegal2 "ill-formed (cannot use a user with socket)"
| Socket,_,_,None ->
illegal2 "ill-formed (must give a port number with socket)"
- | Rsh,_,Some h,_ ->
- ConnectByShell("rsh",h,user,port,path)
+ | Socket, _, Some _, Some _ ->
+ illegal2 "ill-formed (must not give a port number with Unix domain socket)"
| Ssh,_,Some h,_ ->
- ConnectByShell("ssh"^(Prefs.read sshversion),h,user,port,path) in
+ ConnectByShell("ssh",h,user,port,path) in
clroot
diff --git a/src/clroot.mli b/src/clroot.mli
index bd11540..db93eeb 100644
--- a/src/clroot.mli
+++ b/src/clroot.mli
@@ -6,7 +6,7 @@ type clroot =
ConnectLocal of
string option (* root *)
| ConnectByShell of
- string (* shell = "rsh" or "ssh" *)
+ string (* shell = "ssh" *)
* string (* name of host *)
* string option (* user name to log in as *)
* string option (* port *)
@@ -19,3 +19,7 @@ type clroot =
val clroot2string : clroot -> string
val parseRoot : string -> clroot
+
+(* Parse a clroot with manually constructed host
+ which may or may not include the port number *)
+val fixHost : clroot -> clroot
diff --git a/src/common.ml b/src/common.ml
index 17bbaf4..a3df301 100644
--- a/src/common.ml
+++ b/src/common.ml
@@ -68,16 +68,89 @@ let sortRoots rootList = Safelist.sort compareRoots rootList
(* ---------------------------------------------------------------------- *)
+(* IMPORTANT!
+ This is the 2.51-compatible version of type [Common.prevState]. It must
+ always remain exactly the same as the type [Common.prevState] in version
+ 2.51.5. This means that if any of the types it is composed of changes then
+ for each changed type also a 2.51-compatible version must be created. *)
+type prevState251 =
+ Previous of Fileinfo.typ * Props.t251 * Os.fullfingerprint * Osx.ressStamp
+ | New
+
type prevState =
Previous of Fileinfo.typ * Props.t * Os.fullfingerprint * Osx.ressStamp
| New
+let mprevState = Umarshal.(sum2
+ (prod4 Fileinfo.mtyp Props.m Os.mfullfingerprint Osx.mressStamp id id)
+ unit
+ (function
+ | Previous (a, b, c, d) -> I21 (a, b, c, d)
+ | New -> I22 ())
+ (function
+ | I21 (a, b, c, d) -> Previous (a, b, c, d)
+ | I22 () -> New))
+
+(* IMPORTANT!
+ This is the 2.51-compatible version of type [Common.contentschange]. It
+ must always remain exactly the same as the type [Common.contentschange]
+ in version 2.51.5. This means that if any of the types it is composed of
+ changes then for each changed type also a 2.51-compatible version must be
+ created. *)
+type contentschange251 =
+ ContentsSame
+ | ContentsUpdated of Os.fullfingerprint * Fileinfo.stamp251 * Osx.ressStamp
+
type contentschange =
ContentsSame
| ContentsUpdated of Os.fullfingerprint * Fileinfo.stamp * Osx.ressStamp
+let mcontentschange = Umarshal.(sum2 unit (prod3 Os.mfullfingerprint Fileinfo.mstamp Osx.mressStamp id id)
+ (function
+ | ContentsSame -> I21 ()
+ | ContentsUpdated (a, b, c) -> I22 (a, b, c))
+ (function
+ | I21 () -> ContentsSame
+ | I22 (a, b, c) -> ContentsUpdated (a, b, c)))
+
type permchange = PropsSame | PropsUpdated
+let mpermchange = Umarshal.(sum2 unit unit
+ (function
+ | PropsSame -> I21 ()
+ | PropsUpdated -> I22 ())
+ (function
+ | I21 () -> PropsSame
+ | I22 () -> PropsUpdated))
+
+(* IMPORTANT!
+ These are the 2.51-compatible versions of types [Common.updateItem] and
+ [Common.updateContent]. They must always remain exactly the same as the
+ types [Common.updateItem] and [Common.updateContent] in version 2.51.5.
+ This means that if any of the types they are composed of changes then
+ for each changed type also a 2.51-compatible version must be created. *)
+type updateItem251 =
+ NoUpdates (* Path not changed *)
+ | Updates (* Path changed in this replica *)
+ of updateContent251 (* - new state *)
+ * prevState251 (* - summary of old state *)
+ | Error (* Error while detecting updates *)
+ of string (* - description of error *)
+
+and updateContent251 =
+ Absent (* Path refers to nothing *)
+ | File (* Path refers to an ordinary file *)
+ of Props.t251 (* - summary of current state *)
+ * contentschange251 (* - hint to transport agent *)
+ | Dir (* Path refers to a directory *)
+ of Props.t251 (* - summary of current state *)
+ * (Name.t * updateItem251) list(* - children;
+ MUST KEEP SORTED for recon *)
+ * permchange (* - did permissions change? *)
+ * bool (* - is the directory now empty? *)
+ | Symlink (* Path refers to a symbolic link *)
+ of string (* - link text *)
+
type updateItem =
NoUpdates (* Path not changed *)
| Updates (* Path changed in this replica *)
@@ -100,6 +173,99 @@ and updateContent =
| Symlink (* Path refers to a symbolic link *)
of string (* - link text *)
+let mupdateItem_rec mupdateContent =
+ Umarshal.(sum3 unit (prod2 mupdateContent mprevState id id) string
+ (function
+ | NoUpdates -> I31 ()
+ | Updates (a, b) -> I32 (a, b)
+ | Error a -> I33 a)
+ (function
+ | I31 () -> NoUpdates
+ | I32 (a, b) -> Updates (a, b)
+ | I33 a -> Error a))
+
+let mupdateContent_rec mupdateItem =
+ Umarshal.(sum4
+ unit
+ (prod2 Props.m mcontentschange id id)
+ (prod4 Props.m (list (prod2 Name.m mupdateItem id id)) mpermchange bool id id)
+ string
+ (function
+ | Absent -> I41 ()
+ | File (a, b) -> I42 (a, b)
+ | Dir (a, b, c, d) -> I43 (a, b, c, d)
+ | Symlink a -> I44 a)
+ (function
+ | I41 () -> Absent
+ | I42 (a, b) -> File (a, b)
+ | I43 (a, b, c, d) -> Dir (a, b, c, d)
+ | I44 a -> Symlink a))
+
+let mupdateContent, mupdateItem =
+ Umarshal.rec2 mupdateItem_rec mupdateContent_rec
+
+(* Compatibility conversion functions *)
+
+let prev_to_compat251 (prev : prevState) : prevState251 =
+ match prev with
+ | Previous (typ, props, fp, ress) ->
+ Previous (typ, Props.to_compat251 props, fp, ress)
+ | New -> New
+
+let prev_of_compat251 (prev : prevState251) : prevState =
+ match prev with
+ | Previous (typ, props, fp, ress) ->
+ Previous (typ, Props.of_compat251 props, fp, ress)
+ | New -> New
+
+let change_to_compat251 (c : contentschange) : contentschange251 =
+ match c with
+ | ContentsSame -> ContentsSame
+ | ContentsUpdated (fp, stamp, ress) ->
+ ContentsUpdated (fp, Fileinfo.stamp_to_compat251 stamp, ress)
+
+let change_of_compat251 (c : contentschange251) : contentschange =
+ match c with
+ | ContentsSame -> ContentsSame
+ | ContentsUpdated (fp, stamp, ress) ->
+ ContentsUpdated (fp, Fileinfo.stamp_of_compat251 stamp, ress)
+
+let rec ui_to_compat251 (ui : updateItem) : updateItem251 =
+ match ui with
+ | NoUpdates -> NoUpdates
+ | Updates (uc, prev) -> Updates (uc_to_compat251 uc, prev_to_compat251 prev)
+ | Error s -> Error s
+
+and ui_of_compat251 (ui : updateItem251) : updateItem =
+ match ui with
+ | NoUpdates -> NoUpdates
+ | Updates (uc, prev) -> Updates (uc_of_compat251 uc, prev_of_compat251 prev)
+ | Error s -> Error s
+
+and children_to_compat251 l =
+ Safelist.map (fun (n, ui) -> (n, ui_to_compat251 ui)) l
+
+and children_of_compat251 l =
+ Safelist.map (fun (n, ui) -> (n, ui_of_compat251 ui)) l
+
+and uc_to_compat251 (uc : updateContent) : updateContent251 =
+ match uc with
+ | Absent -> Absent
+ | File (props, change) ->
+ File (Props.to_compat251 props, change_to_compat251 change)
+ | Dir (props, ch, perm, empty) ->
+ Dir (Props.to_compat251 props, children_to_compat251 ch, perm, empty)
+ | Symlink s -> Symlink s
+
+and uc_of_compat251 (uc : updateContent251) : updateContent =
+ match uc with
+ | Absent -> Absent
+ | File (props, change) ->
+ File (Props.of_compat251 props, change_of_compat251 change)
+ | Dir (props, ch, perm, empty) ->
+ Dir (Props.of_compat251 props, children_of_compat251 ch, perm, empty)
+ | Symlink s -> Symlink s
+
(* ------------------------------------------------------------------------- *)
type status =
diff --git a/src/common.mli b/src/common.mli
index a18bda3..8065ace 100644
--- a/src/common.mli
+++ b/src/common.mli
@@ -41,6 +41,39 @@ type 'a oneperpath = ONEPERPATH of 'a list
filesystem below a given path and the state recorded in the archive below
that path. The other types are helpers. *)
+type prevState251 =
+ Previous of Fileinfo.typ * Props.t251 * Os.fullfingerprint * Osx.ressStamp
+ | New
+
+type contentschange251 =
+ ContentsSame
+ | ContentsUpdated of Os.fullfingerprint * Fileinfo.stamp251 * Osx.ressStamp
+type permchange = PropsSame | PropsUpdated
+
+(* Variable name prefix: "ui" *)
+type updateItem251 =
+ NoUpdates (* Path not changed *)
+ | Updates (* Path changed in this replica *)
+ of updateContent251 (* - new state *)
+ * prevState251 (* - summary of old state *)
+ | Error (* Error while detecting updates *)
+ of string (* - description of error *)
+
+(* Variable name prefix: "uc" *)
+and updateContent251 =
+ Absent (* Path refers to nothing *)
+ | File (* Path refers to an ordinary file *)
+ of Props.t251 (* - summary of current state *)
+ * contentschange251 (* - hint to transport agent *)
+ | Dir (* Path refers to a directory *)
+ of Props.t251 (* - summary of current state *)
+ * (Name.t * updateItem251) list(* - children
+ MUST KEEP SORTED for recon *)
+ * permchange (* - did permissions change? *)
+ * bool (* - is the directory now empty? *)
+ | Symlink (* Path refers to a symbolic link *)
+ of string (* - link text *)
+
type prevState =
Previous of Fileinfo.typ * Props.t * Os.fullfingerprint * Osx.ressStamp
| New
@@ -48,7 +81,6 @@ type prevState =
type contentschange =
ContentsSame
| ContentsUpdated of Os.fullfingerprint * Fileinfo.stamp * Osx.ressStamp
-type permchange = PropsSame | PropsUpdated
(* Variable name prefix: "ui" *)
type updateItem =
@@ -74,6 +106,13 @@ and updateContent =
| Symlink (* Path refers to a symbolic link *)
of string (* - link text *)
+val mupdateItem : updateItem Umarshal.t
+val mupdateContent : updateContent Umarshal.t
+
+val ui_to_compat251 : updateItem -> updateItem251
+val ui_of_compat251 : updateItem251 -> updateItem
+val uc_to_compat251 : updateContent -> updateContent251
+val uc_of_compat251 : updateContent251 -> updateContent
(*****************************************************************************)
(* COMMON TYPES SHARED BY RECONCILER AND TRANSPORT AGENT *)
diff --git a/src/compat402.ml b/src/compat402.ml
deleted file mode 100644
index 3bb56c6..0000000
--- a/src/compat402.ml
+++ /dev/null
@@ -1,40 +0,0 @@
-(* Functions added in OCaml 4.02 *)
-
-type bytes = string
-
-let output_bytes = output_string
-let output_substring = output
-
-module Bytes = struct
- include String
-
- let of_string x = x
- let to_string x = x
-
- let sub_string = sub
-end
-
-module Buffer = struct
- include Buffer
-
- let add_subbytes = add_substring
-end
-
-module Digest = struct
- include Digest
-
- let bytes = string
- let subbytes = substring
-end
-
-module Marshal = struct
- include Marshal
-
- let from_bytes = from_string
-end
-
-module Unix = struct
- include Unix
-
- let write_substring = write
-end
diff --git a/src/compat403.ml b/src/compat403.ml
deleted file mode 100644
index 64713c7..0000000
--- a/src/compat403.ml
+++ /dev/null
@@ -1,20 +0,0 @@
-(* Functions added in OCaml 4.03 *)
-
-module String = struct
- include String
-
- let lowercase_ascii = lowercase
- let capitalize_ascii = capitalize
-end
-
-module Unix = struct
- include Unix
-
- let has_symlink () = not Sys.win32
-end
-
-module Sys = struct
- include Sys
-
- let int_size = word_size - 1
-end
diff --git a/src/compat408.ml b/src/compat408.ml
deleted file mode 100644
index ead989d..0000000
--- a/src/compat408.ml
+++ /dev/null
@@ -1,102 +0,0 @@
-module Bytes = struct
-
-include Bytes
-
-(* The following code is taken from OCaml sources.
- Authors of the code snippet: Alain Frisch and Daniel Bünzli *)
-
-(**************************************************************************)
-(* *)
-(* OCaml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. *)
-(* *)
-(* All rights reserved. This file is distributed under the terms of *)
-(* the GNU Lesser General Public License version 2.1, with the *)
-(* special exception on linking described in the file LICENSE. *)
-(* *)
-(**************************************************************************)
-
-(** {6 Binary encoding/decoding of integers} *)
-
-external get_uint8 : bytes -> int -> int = "%string_safe_get"
-external get_uint16_ne : bytes -> int -> int = "%caml_string_get16"
-external get_int32_ne : bytes -> int -> int32 = "%caml_string_get32"
-external get_int64_ne : bytes -> int -> int64 = "%caml_string_get64"
-external set_int8 : bytes -> int -> int -> unit = "%string_safe_set"
-external set_int16_ne : bytes -> int -> int -> unit = "%caml_string_set16"
-external set_int32_ne : bytes -> int -> int32 -> unit = "%caml_string_set32"
-external set_int64_ne : bytes -> int -> int64 -> unit = "%caml_string_set64"
-external swap16 : int -> int = "%bswap16"
-external swap32 : int32 -> int32 = "%bswap_int32"
-external swap64 : int64 -> int64 = "%bswap_int64"
-
-let get_int8 b i =
- ((get_uint8 b i) lsl (Sys.int_size - 8)) asr (Sys.int_size - 8)
-
-let get_uint16_le b i =
- if Sys.big_endian then swap16 (get_uint16_ne b i)
- else get_uint16_ne b i
-
-let get_uint16_be b i =
- if not Sys.big_endian then swap16 (get_uint16_ne b i)
- else get_uint16_ne b i
-
-let get_int16_ne b i =
- ((get_uint16_ne b i) lsl (Sys.int_size - 16)) asr (Sys.int_size - 16)
-
-let get_int16_le b i =
- ((get_uint16_le b i) lsl (Sys.int_size - 16)) asr (Sys.int_size - 16)
-
-let get_int16_be b i =
- ((get_uint16_be b i) lsl (Sys.int_size - 16)) asr (Sys.int_size - 16)
-
-let get_int32_le b i =
- if Sys.big_endian then swap32 (get_int32_ne b i)
- else get_int32_ne b i
-
-let get_int32_be b i =
- if not Sys.big_endian then swap32 (get_int32_ne b i)
- else get_int32_ne b i
-
-let get_int64_le b i =
- if Sys.big_endian then swap64 (get_int64_ne b i)
- else get_int64_ne b i
-
-let get_int64_be b i =
- if not Sys.big_endian then swap64 (get_int64_ne b i)
- else get_int64_ne b i
-
-let set_int16_le b i x =
- if Sys.big_endian then set_int16_ne b i (swap16 x)
- else set_int16_ne b i x
-
-let set_int16_be b i x =
- if not Sys.big_endian then set_int16_ne b i (swap16 x)
- else set_int16_ne b i x
-
-let set_int32_le b i x =
- if Sys.big_endian then set_int32_ne b i (swap32 x)
- else set_int32_ne b i x
-
-let set_int32_be b i x =
- if not Sys.big_endian then set_int32_ne b i (swap32 x)
- else set_int32_ne b i x
-
-let set_int64_le b i x =
- if Sys.big_endian then set_int64_ne b i (swap64 x)
- else set_int64_ne b i x
-
-let set_int64_be b i x =
- if not Sys.big_endian then set_int64_ne b i (swap64 x)
- else set_int64_ne b i x
-
-let set_uint8 = set_int8
-let set_uint16_ne = set_int16_ne
-let set_uint16_be = set_int16_be
-let set_uint16_le = set_int16_le
-
-end
diff --git a/src/compat408.mli b/src/compat408.mli
deleted file mode 100644
index 64a4eb2..0000000
--- a/src/compat408.mli
+++ /dev/null
@@ -1,214 +0,0 @@
-module Bytes : sig
-
-include module type of Bytes
-
-(* The following code is taken from OCaml sources.
- Authors of the code snippet: Alain Frisch and Daniel Bünzli *)
-
-(**************************************************************************)
-(* *)
-(* OCaml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. *)
-(* *)
-(* All rights reserved. This file is distributed under the terms of *)
-(* the GNU Lesser General Public License version 2.1, with the *)
-(* special exception on linking described in the file LICENSE. *)
-(* *)
-(**************************************************************************)
-
-(** {1 Binary encoding/decoding of integers} *)
-
-(** The functions in this section binary encode and decode integers to
- and from byte sequences.
- All following functions raise [Invalid_argument] if the space
- needed at index [i] to decode or encode the integer is not
- available.
- Little-endian (resp. big-endian) encoding means that least
- (resp. most) significant bytes are stored first. Big-endian is
- also known as network byte order. Native-endian encoding is
- either little-endian or big-endian depending on {!Sys.big_endian}.
- 32-bit and 64-bit integers are represented by the [int32] and
- [int64] types, which can be interpreted either as signed or
- unsigned numbers.
- 8-bit and 16-bit integers are represented by the [int] type,
- which has more bits than the binary encoding. These extra bits
- are handled as follows: {ul
- {- Functions that decode signed (resp. unsigned) 8-bit or 16-bit
- integers represented by [int] values sign-extend
- (resp. zero-extend) their result.}
- {- Functions that encode 8-bit or 16-bit integers represented by
- [int] values truncate their input to their least significant
- bytes.}}
-*)
-
-val get_uint8 : bytes -> int -> int
-(** [get_uint8 b i] is [b]'s unsigned 8-bit integer starting at byte index [i].
- @since 4.08
-*)
-
-val get_int8 : bytes -> int -> int
-(** [get_int8 b i] is [b]'s signed 8-bit integer starting at byte index [i].
- @since 4.08
-*)
-
-val get_uint16_ne : bytes -> int -> int
-(** [get_uint16_ne b i] is [b]'s native-endian unsigned 16-bit integer
- starting at byte index [i].
- @since 4.08
-*)
-
-val get_uint16_be : bytes -> int -> int
-(** [get_uint16_be b i] is [b]'s big-endian unsigned 16-bit integer
- starting at byte index [i].
- @since 4.08
-*)
-
-val get_uint16_le : bytes -> int -> int
-(** [get_uint16_le b i] is [b]'s little-endian unsigned 16-bit integer
- starting at byte index [i].
- @since 4.08
-*)
-
-val get_int16_ne : bytes -> int -> int
-(** [get_int16_ne b i] is [b]'s native-endian signed 16-bit integer
- starting at byte index [i].
- @since 4.08
-*)
-
-val get_int16_be : bytes -> int -> int
-(** [get_int16_be b i] is [b]'s big-endian signed 16-bit integer
- starting at byte index [i].
- @since 4.08
-*)
-
-val get_int16_le : bytes -> int -> int
-(** [get_int16_le b i] is [b]'s little-endian signed 16-bit integer
- starting at byte index [i].
- @since 4.08
-*)
-
-val get_int32_ne : bytes -> int -> int32
-(** [get_int32_ne b i] is [b]'s native-endian 32-bit integer
- starting at byte index [i].
- @since 4.08
-*)
-
-val get_int32_be : bytes -> int -> int32
-(** [get_int32_be b i] is [b]'s big-endian 32-bit integer
- starting at byte index [i].
- @since 4.08
-*)
-
-val get_int32_le : bytes -> int -> int32
-(** [get_int32_le b i] is [b]'s little-endian 32-bit integer
- starting at byte index [i].
- @since 4.08
-*)
-
-val get_int64_ne : bytes -> int -> int64
-(** [get_int64_ne b i] is [b]'s native-endian 64-bit integer
- starting at byte index [i].
- @since 4.08
-*)
-
-val get_int64_be : bytes -> int -> int64
-(** [get_int64_be b i] is [b]'s big-endian 64-bit integer
- starting at byte index [i].
- @since 4.08
-*)
-
-val get_int64_le : bytes -> int -> int64
-(** [get_int64_le b i] is [b]'s little-endian 64-bit integer
- starting at byte index [i].
- @since 4.08
-*)
-
-val set_uint8 : bytes -> int -> int -> unit
-(** [set_uint8 b i v] sets [b]'s unsigned 8-bit integer starting at byte index
- [i] to [v].
- @since 4.08
-*)
-
-val set_int8 : bytes -> int -> int -> unit
-(** [set_int8 b i v] sets [b]'s signed 8-bit integer starting at byte index
- [i] to [v].
- @since 4.08
-*)
-
-val set_uint16_ne : bytes -> int -> int -> unit
-(** [set_uint16_ne b i v] sets [b]'s native-endian unsigned 16-bit integer
- starting at byte index [i] to [v].
- @since 4.08
-*)
-
-val set_uint16_be : bytes -> int -> int -> unit
-(** [set_uint16_be b i v] sets [b]'s big-endian unsigned 16-bit integer
- starting at byte index [i] to [v].
- @since 4.08
-*)
-
-val set_uint16_le : bytes -> int -> int -> unit
-(** [set_uint16_le b i v] sets [b]'s little-endian unsigned 16-bit integer
- starting at byte index [i] to [v].
- @since 4.08
-*)
-
-val set_int16_ne : bytes -> int -> int -> unit
-(** [set_int16_ne b i v] sets [b]'s native-endian signed 16-bit integer
- starting at byte index [i] to [v].
- @since 4.08
-*)
-
-val set_int16_be : bytes -> int -> int -> unit
-(** [set_int16_be b i v] sets [b]'s big-endian signed 16-bit integer
- starting at byte index [i] to [v].
- @since 4.08
-*)
-
-val set_int16_le : bytes -> int -> int -> unit
-(** [set_int16_le b i v] sets [b]'s little-endian signed 16-bit integer
- starting at byte index [i] to [v].
- @since 4.08
-*)
-
-val set_int32_ne : bytes -> int -> int32 -> unit
-(** [set_int32_ne b i v] sets [b]'s native-endian 32-bit integer
- starting at byte index [i] to [v].
- @since 4.08
-*)
-
-val set_int32_be : bytes -> int -> int32 -> unit
-(** [set_int32_be b i v] sets [b]'s big-endian 32-bit integer
- starting at byte index [i] to [v].
- @since 4.08
-*)
-
-val set_int32_le : bytes -> int -> int32 -> unit
-(** [set_int32_le b i v] sets [b]'s little-endian 32-bit integer
- starting at byte index [i] to [v].
- @since 4.08
-*)
-
-val set_int64_ne : bytes -> int -> int64 -> unit
-(** [set_int64_ne b i v] sets [b]'s native-endian 64-bit integer
- starting at byte index [i] to [v].
- @since 4.08
-*)
-
-val set_int64_be : bytes -> int -> int64 -> unit
-(** [set_int64_be b i v] sets [b]'s big-endian 64-bit integer
- starting at byte index [i] to [v].
- @since 4.08
-*)
-
-val set_int64_le : bytes -> int -> int64 -> unit
-(** [set_int64_le b i v] sets [b]'s little-endian 64-bit integer
- starting at byte index [i] to [v].
- @since 4.08
-*)
-
-end
diff --git a/src/configure.ml b/src/configure.ml
deleted file mode 100644
index f4701dd..0000000
--- a/src/configure.ml
+++ /dev/null
@@ -1,55 +0,0 @@
-let (major, minor, patch) =
- Scanf.sscanf Sys.ocaml_version "%d.%d.%d" (fun x y z -> (x, y, z))
-
-let compat4pred v = major < 4 || major = 4 && minor < v
-
-let compat4 =
- [
- compat4pred 2, "Compat402", "compat402.cmo";
- compat4pred 3, "Compat403", "compat403.cmo";
- compat4pred 8, "Compat408", "compat408.cmo" ]
-
-let objects =
- List.fold_left (fun acc (p, _, n) -> if p then acc ^ " " ^ n else acc) ""
-
-let (flags, objs) =
- match objects compat4 with
- | "" -> ("", "")
- | objs -> ("-pp \"ocaml " ^ Sys.argv.(0) ^ " pp\"", objs)
-
-(* Compat for OCaml < 4.02 *)
-external string_create : int -> string = "caml_create_string"
-external input : in_channel -> string -> int -> int -> int = "caml_ml_input"
-external output : out_channel -> string -> int -> int -> unit = "caml_ml_output"
-
-let len = 65536
-
-let output_file name =
- let () = set_binary_mode_out stdout true in
- let f = open_in_bin name in
- let s = string_create len in
- let rec loop () =
- match input f s 0 len with
- | 0 -> close_in_noerr f
- | l -> output stdout s 0 l; loop ()
- in loop ()
-
-let same_file n1 n2 =
- String.length n1 > 10 && String.sub n1 0 10 = String.sub n2 0 10
-
-let do_pp filen =
- let fn = Filename.basename filen in
- let stop = ref false in
- List.iter (fun (c, n1, n2) -> if c && not !stop then
- if same_file fn n2 then stop := true
- else print_endline ("open " ^ n1)) compat4;
- print_endline ("# 1 \"" ^ filen ^ "\" 1");
- output_file filen
-
-let () =
- if Array.length Sys.argv > 1 then begin
- match Sys.argv.(1) with
- | "objs" -> print_string objs
- | "pp" -> do_pp Sys.argv.(2)
- | _ -> ()
- end else print_string flags
diff --git a/src/copy.ml b/src/copy.ml
index 60a0511..21e2274 100644
--- a/src/copy.ml
+++ b/src/copy.ml
@@ -24,19 +24,14 @@ let debug = Trace.debug "copy"
let protect f g =
try
f ()
- with Sys_error _ | Unix.Unix_error _ | Util.Transient _ as e ->
+ with e ->
begin try g () with Sys_error _ | Unix.Unix_error _ -> () end;
raise e
let lwt_protect f g =
Lwt.catch f
(fun e ->
- begin match e with
- Sys_error _ | Unix.Unix_error _ | Util.Transient _ ->
- begin try g () with Sys_error _ | Unix.Unix_error _ -> () end
- | _ ->
- ()
- end;
+ begin try g () with Sys_error _ | Unix.Unix_error _ -> () end;
Lwt.fail e)
(****)
@@ -47,13 +42,14 @@ let lwt_protect f g =
let checkForChangesToSourceLocal
fspathFrom pathFrom archDesc archFp archStamp archRess newFpOpt paranoid =
(* Retrieve attributes of current source file *)
- let sourceInfo = Fileinfo.get true fspathFrom pathFrom in
+ let sourceInfo = Fileinfo.getBasicWithRess true fspathFrom pathFrom in
+ let sourceType = sourceInfo.Fileinfo.typ in
match newFpOpt with
None ->
(* no newfp provided: so we need to compare the archive with the
current source *)
let clearlyChanged =
- sourceInfo.Fileinfo.typ <> `FILE
+ sourceType <> `FILE
|| Props.length sourceInfo.Fileinfo.desc <> Props.length archDesc
|| Osx.ressLength sourceInfo.Fileinfo.osX.Osx.ressInfo <>
Osx.ressLength archRess in
@@ -63,7 +59,8 @@ let checkForChangesToSourceLocal
&& not (Fpcache.excelFile pathFrom)
&& match archStamp with
Some (Fileinfo.InodeStamp inode) -> sourceInfo.Fileinfo.inode = inode
- | Some (Fileinfo.CtimeStamp ctime) -> true
+ | Some (Fileinfo.NoStamp) -> true
+ | Some (Fileinfo.RescanStamp) -> false
| None -> false in
let ressClearlyUnchanged =
not clearlyChanged
@@ -71,7 +68,7 @@ let checkForChangesToSourceLocal
None dataClearlyUnchanged in
if dataClearlyUnchanged && ressClearlyUnchanged then begin
if paranoid && not (Os.isPseudoFingerprint archFp) then begin
- let newFp = Os.fingerprint fspathFrom pathFrom sourceInfo in
+ let newFp = Os.fingerprint fspathFrom pathFrom sourceType in
if archFp <> newFp then begin
Update.markPossiblyUpdated fspathFrom pathFrom;
raise (Util.Transient (Printf.sprintf
@@ -84,7 +81,7 @@ let checkForChangesToSourceLocal
end
end else if
clearlyChanged
- || archFp <> Os.fingerprint fspathFrom pathFrom sourceInfo
+ || archFp <> Os.fingerprint fspathFrom pathFrom sourceType
then
raise (Util.Transient (Printf.sprintf
"The source file %s\nhas been modified during synchronization. \
@@ -95,17 +92,44 @@ let checkForChangesToSourceLocal
assert (Os.isPseudoFingerprint archFp);
(* ... so we can't compare the archive with the source; instead we
need to compare the current source to the new fingerprint: *)
- if newfp <> Os.fingerprint fspathFrom pathFrom sourceInfo then
+ if newfp <> Os.fingerprint fspathFrom pathFrom sourceType then
raise (Util.Transient (Printf.sprintf
"Current source file %s\n not same as transferred file. \
Transfer aborted."
(Fspath.toPrintString (Fspath.concat fspathFrom pathFrom))))
+let mcheckForChangesToSource =
+ Umarshal.(prod2
+ (prod4 Path.mlocal Props.m Os.mfullfingerprint (option Fileinfo.mstamp) id id)
+ (prod3 Osx.mressStamp (option Os.mfullfingerprint) bool id id)
+ id id)
+
+let archStamp_to_compat251 = function
+ | Some stamp -> Some (Fileinfo.stamp_to_compat251 stamp)
+ | None -> None
+
+let archStamp_of_compat251 = function
+ | Some stamp -> Some (Fileinfo.stamp_of_compat251 stamp)
+ | None -> None
+
+let convV0 = Remote.makeConvV0FunArg
+ (fun (fspathFrom,
+ ((pathFrom, archDesc, archFp, archStamp), (archRess, newFpOpt, paranoid))) ->
+ (fspathFrom,
+ (pathFrom, Props.to_compat251 archDesc, archFp,
+ archStamp_to_compat251 archStamp, archRess, newFpOpt, paranoid)))
+ (fun (fspathFrom,
+ (pathFrom, archDesc, archFp, archStamp, archRess, newFpOpt, paranoid)) ->
+ (fspathFrom,
+ ((pathFrom, Props.of_compat251 archDesc, archFp,
+ archStamp_of_compat251 archStamp), (archRess, newFpOpt, paranoid))))
+
let checkForChangesToSourceOnRoot =
Remote.registerRootCmd
- "checkForChangesToSource"
+ "checkForChangesToSource" ~convV0
+ mcheckForChangesToSource Umarshal.unit
(fun (fspathFrom,
- (pathFrom, archDesc, archFp, archStamp, archRess, newFpOpt, paranoid)) ->
+ ((pathFrom, archDesc, archFp, archStamp), (archRess, newFpOpt, paranoid))) ->
checkForChangesToSourceLocal
fspathFrom pathFrom archDesc archFp archStamp archRess newFpOpt paranoid;
Lwt.return ())
@@ -113,13 +137,13 @@ let checkForChangesToSourceOnRoot =
let checkForChangesToSource
root pathFrom archDesc archFp archStamp archRess newFpOpt paranoid =
checkForChangesToSourceOnRoot
- root (pathFrom, archDesc, archFp, archStamp, archRess, newFpOpt, paranoid)
+ root ((pathFrom, archDesc, archFp, archStamp), (archRess, newFpOpt, paranoid))
(****)
let fileIsTransferred fspathTo pathTo desc fp ress =
- let info = Fileinfo.get false fspathTo pathTo in
- (info,
+ let info = Fileinfo.getBasicWithRess false fspathTo pathTo in
+ (Fileinfo.basic info,
info.Fileinfo.typ = `FILE
&&
Props.length info.Fileinfo.desc = Props.length desc
@@ -127,7 +151,7 @@ let fileIsTransferred fspathTo pathTo desc fp ress =
Osx.ressLength info.Fileinfo.osX.Osx.ressInfo =
Osx.ressLength ress
&&
- let fp' = Os.fingerprint fspathTo pathTo info in
+ let fp' = Os.fingerprint fspathTo pathTo info.Fileinfo.typ in
fp' = fp)
(* We slice the files in 1GB chunks because that's the limit for
@@ -146,6 +170,8 @@ let rec fingerprintPrefix fspath path offset len accu =
let fingerprintPrefixRemotely =
Remote.registerServerCmd
"fingerprintSubfile"
+ Umarshal.(prod3 Fspath.m Path.mlocal Uutil.Filesize.m id id)
+ Umarshal.(list Fingerprint.m)
(fun _ (fspath, path, len) ->
Lwt.return (fingerprintPrefix fspath path 0L len []))
@@ -168,11 +194,48 @@ let validFilePrefix connFrom fspathFrom pathFrom fspathTo pathTo info desc =
end else
Lwt.return None
+(* IMPORTANT!
+ This is the 2.51-compatible version of type [transferStatus]. It must always
+ remain exactly the same as the type [transferStatus] in version 2.51.5. This
+ means that if any of the types it is composed of changes then for each
+ changed type also a 2.51-compatible version must be created. *)
+type transferStatus251 =
+ TransferSucceeded of Fileinfo.t251
+ | TransferNeedsDoubleCheckAgainstCurrentSource of Fileinfo.t251 * Os.fullfingerprint
+ | TransferFailed of string
+
type transferStatus =
- TransferSucceeded of Fileinfo.t
- | TransferNeedsDoubleCheckAgainstCurrentSource of Fileinfo.t * Os.fullfingerprint
+ TransferSucceeded of Fileinfo.basic
+ | TransferNeedsDoubleCheckAgainstCurrentSource of Fileinfo.basic * Os.fullfingerprint
| TransferFailed of string
+let mtransferStatus = Umarshal.(sum3
+ Fileinfo.mbasic
+ (prod2 Fileinfo.mbasic Os.mfullfingerprint id id)
+ string
+ (function
+ | TransferSucceeded a -> I31 a
+ | TransferNeedsDoubleCheckAgainstCurrentSource (a, b) -> I32 (a, b)
+ | TransferFailed a -> I33 a)
+ (function
+ | I31 a -> TransferSucceeded a
+ | I32 (a, b) -> TransferNeedsDoubleCheckAgainstCurrentSource (a, b)
+ | I33 a -> TransferFailed a))
+
+let transferStatus_to_compat251 (st : transferStatus) : transferStatus251 =
+ match st with
+ | TransferSucceeded info -> TransferSucceeded (Fileinfo.to_compat251 info)
+ | TransferNeedsDoubleCheckAgainstCurrentSource (info, fp) ->
+ TransferNeedsDoubleCheckAgainstCurrentSource (Fileinfo.to_compat251 info, fp)
+ | TransferFailed s -> TransferFailed s
+
+let transferStatus_of_compat251 (st : transferStatus251) : transferStatus =
+ match st with
+ | TransferSucceeded info -> TransferSucceeded (Fileinfo.of_compat251 info)
+ | TransferNeedsDoubleCheckAgainstCurrentSource (info, fp) ->
+ TransferNeedsDoubleCheckAgainstCurrentSource (Fileinfo.of_compat251 info, fp)
+ | TransferFailed s -> TransferFailed s
+
(* Paranoid check: recompute the transferred file's fingerprint to match it
with the archive's. If the old
fingerprint was a pseudo-fingerprint, we can't tell just from looking at the
@@ -182,8 +245,8 @@ type transferStatus =
calculated the current source fingerprint.
*)
let paranoidCheck fspathTo pathTo realPathTo desc fp ress =
- let info = Fileinfo.get false fspathTo pathTo in
- let fp' = Os.fingerprint fspathTo pathTo info in
+ let info = Fileinfo.getBasic false fspathTo pathTo in
+ let fp' = Os.fingerprint fspathTo pathTo info.Fileinfo.typ in
if Os.isPseudoFingerprint fp then begin
Lwt.return (TransferNeedsDoubleCheckAgainstCurrentSource (info,fp'))
end else if fp' <> fp then begin
@@ -218,7 +281,9 @@ let saveTempFileLocal (fspathTo, (pathTo, realPathTo, reason)) =
(Fspath.toDebugString (Fspath.concat fspathTo savepath))))
let saveTempFileOnRoot =
- Remote.registerRootCmd "saveTempFile" saveTempFileLocal
+ Remote.registerRootCmd "saveTempFile"
+ Umarshal.(prod3 Path.mlocal Path.mlocal string id id) Umarshal.unit
+ saveTempFileLocal
(****)
@@ -229,7 +294,18 @@ let removeOldTempFile fspathTo pathTo =
Os.delete fspathTo pathTo
end
-let openFileIn fspath path kind =
+(* There is an issue that not all threads are immediately cancelled when there
+ is a connection error. A waiting thread (in this case probably a thread in
+ one of the Lwt regions) may have been started and could open an fd but may
+ never be able to complete. [protect], [lwt_protect] and any other cleanup
+ code may never be triggered in this scenario because the thread just stops
+ (as eventually the connection cleanup kicks in and all threads are stopped).
+ As a hacky(?) solution, keep track of all open fds and close them when the
+ connection breaks. *)
+let inFdResource = Remote.resourceWithConnCleanup close_in close_in_noerr
+let outFdResource = Remote.resourceWithConnCleanup close_out close_out_noerr
+
+let openFileIn' fspath path kind =
match kind with
`DATA ->
Fs.open_in_bin (Fspath.concat fspath path)
@@ -240,12 +316,19 @@ let openFileIn fspath path kind =
| `RESS ->
Osx.openRessIn fspath path
-let openFileOut fspath path kind len =
+let openFileIn fspath path kind =
+ inFdResource.register (openFileIn' fspath path kind)
+
+let closeFileIn = inFdResource.release
+
+let closeFileInNoErr = inFdResource.release_noerr
+
+let openFileOut' fspath path kind len =
match kind with
`DATA ->
let fullpath = Fspath.concat fspath path in
- let flags = [Unix.O_WRONLY;Unix.O_CREAT] in
- let perm = 0o600 in
+ let flags = [Unix.O_WRONLY; Unix.O_CREAT; Unix.O_CLOEXEC] in
+ let perm = if Prefs.read Props.dontChmod then Props.perms Props.fileDefault else 0o600 in
begin match Util.osType with
`Win32 ->
Fs.open_out_gen
@@ -265,7 +348,7 @@ let openFileOut fspath path kind len =
end
| `DATA_APPEND len ->
let fullpath = Fspath.concat fspath path in
- let perm = 0o600 in
+ let perm = if Prefs.read Props.dontChmod then Props.perms Props.fileDefault else 0o600 in
let ch = Fs.open_out_gen [Open_wronly; Open_binary] perm fullpath in
if not (Prefs.read Props.dontChmod) then Fs.chmod fullpath perm;
LargeFile.seek_out ch (Uutil.Filesize.toInt64 len);
@@ -273,6 +356,13 @@ let openFileOut fspath path kind len =
| `RESS ->
Osx.openRessOut fspath path len
+let openFileOut fspath path kind len =
+ outFdResource.register (openFileOut' fspath path kind len)
+
+let closeFileOut = outFdResource.release
+
+let closeFileOutNoErr = outFdResource.release_noerr
+
let setFileinfo fspathTo pathTo realPathTo update desc =
match update with
`Update _ -> Fileinfo.set fspathTo pathTo (`Copy realPathTo) desc
@@ -280,6 +370,57 @@ let setFileinfo fspathTo pathTo realPathTo update desc =
(****)
+(* This unfortunate complexity is here to reduce network round-trips
+ and calls to [Update.translatePath], primarily in [Files.setProp]. *)
+let mxpath = Umarshal.(sum2 Path.mlocal Path.m)
+ (function `Local p -> I21 p | `Global p -> I22 p)
+ (function I21 p -> `Local p | I22 p -> `Global p)
+
+let loadPropsExtDataLocal (fspath, path, desc) =
+ let localPath = match path with
+ | `Local p -> p
+ | `Global p -> Update.translatePathLocal fspath p in
+ (Some localPath, Props.loadExtData fspath localPath desc)
+
+let loadPropsExtDataOnServer = Remote.registerServerCmd "propsExtData"
+ Umarshal.(prod3 Fspath.m mxpath Props.m id id)
+ Umarshal.(prod2 (option Path.mlocal) Props.mx id id)
+ (fun connFrom args -> Lwt.return (loadPropsExtDataLocal args))
+
+let propsWithExtDataLocal fspath path desc =
+ try (None, Props.withExtData desc)
+ with Not_found -> loadPropsExtDataLocal (fspath, path, desc)
+
+let propsWithExtDataConn connFrom fspath path desc =
+ try Lwt.return (None, Props.withExtData desc)
+ with Not_found -> loadPropsExtDataOnServer connFrom (fspath, path, desc)
+
+let propsExtDataOnRoot root path desc =
+ match root with
+ | (Common.Local, fspath) ->
+ Lwt.return (propsWithExtDataLocal fspath path desc)
+ | (Remote _, fspath) ->
+ propsWithExtDataConn (Remote.connectionOfRoot root) fspath path desc
+
+let propsWithExtData connFrom fspath path desc =
+ propsWithExtDataConn connFrom fspath (`Local path) desc >>= fun x ->
+ Lwt.return (snd x)
+
+let readPropsExtData root path desc =
+ propsExtDataOnRoot root (`Local path) desc >>= fun x ->
+ Lwt.return (snd x)
+
+let readPropsExtDataG root path desc =
+ propsExtDataOnRoot root (`Global path) desc
+
+(****)
+
+(* The fds opened in this function normally shouldn't be tracked for extra
+ cleanup at connection close because this is sequential non-Lwt code. Yet,
+ there is a risk that code called by [Uutil.showProgress] may include Lwt
+ code. For this reason only, it is better to include the fds in this
+ function in the fd cleanup scheme (done automatically by [openFile*] and
+ [closeFile*] functions). *)
let copyContents fspathFrom pathFrom fspathTo pathTo fileKind fileLength ido =
let use_id f = match ido with Some id -> f id | None -> () in
let inFd = openFileIn fspathFrom pathFrom fileKind in
@@ -292,16 +433,16 @@ let copyContents fspathFrom pathFrom fspathTo pathTo fileKind fileLength ido =
(fun l ->
use_id (fun id ->
(* (Util.msg "Copied file %s (%d bytes)\n" (Path.toString pathFrom) l); *)
+ if fileKind <> `RESS then Abort.checkAll ();
Uutil.showProgress id (Uutil.Filesize.ofInt l) "l"));
- close_in inFd;
- close_out outFd;
+ closeFileIn inFd;
+ closeFileOut outFd;
(* ignore (Sys.command ("ls -l " ^ (Fspath.toString (Fspath.concat fspathTo pathTo)))) *)
)
- (fun () -> close_out_noerr outFd))
- (fun () -> close_in_noerr inFd)
+ (fun () -> closeFileOutNoErr outFd))
+ (fun () -> closeFileInNoErr inFd)
-let localFile
- fspathFrom pathFrom fspathTo pathTo realPathTo update desc ressLength ido =
+let localFileContents fspathFrom pathFrom fspathTo pathTo desc ressLength ido =
Util.convertUnixErrorsToTransient
"copying locally"
(fun () ->
@@ -314,19 +455,26 @@ let localFile
fspathFrom pathFrom fspathTo pathTo `DATA (Props.length desc) ido;
if ressLength > Uutil.Filesize.zero then
copyContents
- fspathFrom pathFrom fspathTo pathTo `RESS ressLength ido;
- setFileinfo fspathTo pathTo realPathTo update desc)
+ fspathFrom pathFrom fspathTo pathTo `RESS ressLength ido)
+
+let localFile
+ fspathFrom pathFrom fspathTo pathTo realPathTo update desc ressLength ido =
+ Util.convertUnixErrorsToTransient "copying locally" (fun () ->
+ localFileContents fspathFrom pathFrom fspathTo pathTo desc ressLength ido;
+ let (_, desc) = propsWithExtDataLocal fspathFrom (`Local pathFrom) desc in
+ setFileinfo fspathTo pathTo realPathTo update desc)
(****)
-let tryCopyMovedFile fspathTo pathTo realPathTo update desc fp ress id =
- if not (Prefs.read Xferhint.xferbycopying) then None else
+let tryCopyMovedFile connFrom fspathFrom pathFrom fspathTo pathTo realPathTo
+ update desc fp ress id =
+ if not (Prefs.read Xferhint.xferbycopying) then Lwt.return None else
Util.convertUnixErrorsToTransient "tryCopyMovedFile" (fun() ->
debug (fun () -> Util.msg "tryCopyMovedFile: -> %s /%s/\n"
(Path.toString pathTo) (Os.fullfingerprint_to_string fp));
match Xferhint.lookup fp with
None ->
- None
+ Lwt.return None
| Some (candidateFspath, candidatePath, hintHandle) ->
debug (fun () ->
Util.msg
@@ -338,14 +486,15 @@ let tryCopyMovedFile fspathTo pathTo realPathTo update desc fp ress id =
[true] is correct. Otherwise, we don't expect to point
to a symlink, and therefore we still get the correct
result. *)
- let info = Fileinfo.get true candidateFspath candidatePath in
+ let info = Fileinfo.getBasic true candidateFspath candidatePath in
if
info.Fileinfo.typ <> `ABSENT &&
Props.length info.Fileinfo.desc = Props.length desc
then begin
- localFile
- candidateFspath candidatePath fspathTo pathTo realPathTo
- update desc (Osx.ressLength ress) (Some id);
+ localFileContents candidateFspath candidatePath fspathTo pathTo desc
+ (Osx.ressLength ress) (Some id);
+ propsWithExtData connFrom fspathFrom pathFrom desc >>= fun desc ->
+ setFileinfo fspathTo pathTo realPathTo update desc;
let (info, isTransferred) =
fileIsTransferred fspathTo pathTo desc fp ress in
if isTransferred then begin
@@ -358,29 +507,29 @@ let tryCopyMovedFile fspathTo pathTo realPathTo update desc fp ress id =
(Fspath.toPrintString candidateFspath)
(Path.toString candidatePath)
in
- Some (info, msg)
+ Lwt.return (Some (info, msg))
end else begin
debug (fun () ->
Util.msg "tryCopyMoveFile: candidate file %s modified!\n"
(Path.toString candidatePath));
Xferhint.deleteEntry hintHandle;
- None
+ Lwt.return None
end
end else begin
debug (fun () ->
Util.msg "tryCopyMoveFile: candidate file %s disappeared!\n"
(Path.toString candidatePath));
Xferhint.deleteEntry hintHandle;
- None
+ Lwt.return None
end
with
Util.Transient s ->
debug (fun () ->
Util.msg
- "tryCopyMovedFile: local copy from %s didn't work [%s]"
+ "tryCopyMovedFile: local copy from %s didn't work [%s]\n"
(Path.toString candidatePath) s);
Xferhint.deleteEntry hintHandle;
- None)
+ Lwt.return None)
(****)
@@ -391,7 +540,8 @@ let tryCopyMovedFile fspathTo pathTo realPathTo update desc fp ress id =
let rsyncActivated =
Prefs.createBool "rsync" true
- "!activate the rsync transfer mode"
+ ~category:(`Advanced `Remote)
+ "activate the rsync transfer mode"
("Unison uses the 'rsync algorithm' for 'diffs-only' transfer "
^ "of updates to large files. Setting this flag to false makes Unison "
^ "use whole-file transfers instead. Under normal circumstances, "
@@ -401,17 +551,21 @@ let rsyncActivated =
let decompressor = ref Remote.MsgIdMap.empty
+let resetDecompressorState () =
+ decompressor := Remote.MsgIdMap.empty
+let () = Remote.at_conn_close resetDecompressorState
+
let processTransferInstruction conn (file_id, ti) =
Util.convertUnixErrorsToTransient
"processing a transfer instruction"
(fun () ->
- ignore (Remote.MsgIdMap.find file_id !decompressor ti))
+ ignore ((fst (Remote.MsgIdMap.find file_id !decompressor)) ti))
let marshalTransferInstruction =
- (fun (file_id, (data, pos, len)) rem ->
+ (fun _ (file_id, (data, pos, len)) rem ->
(Remote.encodeInt file_id :: (data, pos, len) :: rem,
len + Remote.intSize)),
- (fun buf pos ->
+ (fun _ buf pos ->
let len = Bytearray.length buf - pos - Remote.intSize in
(Remote.decodeInt buf pos, (buf, pos + Remote.intSize, len)))
@@ -426,7 +580,7 @@ let showPrefixProgress id kind =
| _ -> ()
let compress conn
- (biOpt, fspathFrom, pathFrom, fileKind, sizeFrom, id, file_id) =
+ ((biOpt, fspathFrom, pathFrom, fileKind), (sizeFrom, id, file_id)) =
Lwt.catch
(fun () ->
streamTransferInstruction conn
@@ -439,6 +593,7 @@ let compress conn
(fun () ->
showPrefixProgress id fileKind;
let showProgress count =
+ if fileKind <> `RESS then Abort.checkAll ();
Uutil.showProgress id (Uutil.Filesize.ofInt count) "r" in
let compr =
match biOpt with
@@ -451,38 +606,60 @@ let compress conn
compr
(fun ti -> processTransferInstructionRemotely (file_id, ti))
>>= fun () ->
- close_in infd;
+ closeFileIn infd;
Lwt.return ())
(fun () ->
- close_in_noerr infd)))
+ closeFileInNoErr infd)))
(fun e ->
(* We cannot wrap the code above with the handler below,
as the code is executed asynchronously. *)
Util.convertUnixErrorsToTransient "transferring file contents"
(fun () -> raise e))
-let compressRemotely = Remote.registerServerCmd "compress" compress
+let mdata = Umarshal.(sum3 unit Uutil.Filesize.m unit
+ (function
+ | `DATA -> I31 ()
+ | `DATA_APPEND a -> I32 a
+ | `RESS -> I33 ())
+ (function
+ | I31 () -> `DATA
+ | I32 a -> `DATA_APPEND a
+ | I33 () -> `RESS))
+
+let mcompress = Umarshal.(prod2
+ (prod4 (option Transfer.Rsync.mrsync_block_info) Fspath.m Path.mlocal mdata id id)
+ (prod3 Uutil.Filesize.m Uutil.File.m int id id)
+ id id)
+
+let convV0 = Remote.makeConvV0FunArg
+ (fun ((biOpt, fspathFrom, pathFrom, fileKind), (sizeFrom, id, file_id)) ->
+ (biOpt, fspathFrom, pathFrom, fileKind, sizeFrom, id, file_id))
+ (fun (biOpt, fspathFrom, pathFrom, fileKind, sizeFrom, id, file_id) ->
+ ((biOpt, fspathFrom, pathFrom, fileKind), (sizeFrom, id, file_id)))
+
+let compressRemotely =
+ Remote.registerServerCmd "compress" ~convV0 mcompress Umarshal.unit compress
let close_all infd outfd =
Util.convertUnixErrorsToTransient
"closing files"
(fun () ->
begin match !infd with
- Some fd -> close_in fd; infd := None
+ Some fd -> closeFileIn fd; infd := None
| None -> ()
end;
begin match !outfd with
- Some fd -> close_out fd; outfd := None
+ Some fd -> closeFileOut fd; outfd := None
| None -> ()
end)
let close_all_no_error infd outfd =
begin match !infd with
- Some fd -> close_in_noerr fd
+ Some fd -> closeFileInNoErr fd
| None -> ()
end;
begin match !outfd with
- Some fd -> close_out_noerr fd
+ Some fd -> closeFileOutNoErr fd
| None -> ()
end
@@ -510,11 +687,12 @@ let referenceFd fspath path kind infd =
| Some fd ->
fd
-let rsyncReg = Lwt_util.make_region (40 * 1024)
+let rsyncReg = Remote.lwtRegionWithConnCleanup (40 * 1024)
+
let rsyncThrottle useRsync srcFileSize destFileSize f =
if not useRsync then f () else
let l = Transfer.Rsync.memoryFootprint srcFileSize destFileSize in
- Lwt_util.run_in_region rsyncReg l f
+ Lwt_util.run_in_region !rsyncReg l f
let transferFileContents
connFrom fspathFrom pathFrom fspathTo pathTo realPathTo update
@@ -525,6 +703,7 @@ let transferFileContents
let outfd = ref None in
let infd = ref None in
let showProgress count =
+ if fileKind <> `RESS then Abort.checkAll ();
Uutil.showProgress id (Uutil.Filesize.ofInt count) "r" in
let destFileSize =
@@ -554,7 +733,7 @@ let transferFileContents
protect
(fun () -> Transfer.Rsync.rsyncPreprocess
ifd srcFileSize destFileSize)
- (fun () -> close_in_noerr ifd)
+ (fun () -> closeFileInNoErr ifd)
in
close_all infd outfd;
(Some bi,
@@ -581,9 +760,9 @@ let transferFileContents
Lwt.catch
(fun () ->
debug (fun () -> Util.msg "Starting the actual transfer\n");
- decompressor := Remote.MsgIdMap.add file_id decompr !decompressor;
+ decompressor := Remote.MsgIdMap.add file_id (decompr, (infd, outfd)) !decompressor;
compressRemotely connFrom
- (bi, fspathFrom, pathFrom, fileKind, srcFileSize, id, file_id)
+ ((bi, fspathFrom, pathFrom, fileKind), (srcFileSize, id, file_id))
>>= fun () ->
decompressor :=
Remote.MsgIdMap.remove file_id !decompressor; (* For GC *)
@@ -614,6 +793,7 @@ let transferResourceForkAndSetFileinfo
end else
Lwt.return ()
end >>= fun () ->
+ propsWithExtData connFrom fspathFrom pathFrom desc >>= fun desc ->
setFileinfo fspathTo pathTo realPathTo update desc;
debug (fun() -> Util.msg "Resource fork transferred for %s; doing last paranoid check\n"
(Path.toString realPathTo));
@@ -650,6 +830,11 @@ let reallyTransferFile
let filesBeingTransferred = Hashtbl.create 17
+let resetFileTransferState () =
+ (* The waiting threads should be collected by GC *)
+ Hashtbl.clear filesBeingTransferred
+let () = Remote.at_conn_close resetFileTransferState
+
let wakeupNextTransfer fp =
match
try
@@ -692,7 +877,8 @@ let rec registerFileTransfer pathTo fp f =
let copyprog =
Prefs.createString "copyprog" "rsync --partial --inplace --compress"
- "!external program for copying large files"
+ ~category:(`Advanced `General)
+ "external program for copying large files"
("A string giving the name of an "
^ "external program that can be used to copy large files efficiently "
^ "(plus command-line switches telling it to copy files in-place). "
@@ -702,7 +888,8 @@ let copyprog =
let copyprogrest =
Prefs.createString
"copyprogrest" "rsync --partial --append-verify --compress"
- "!variant of copyprog for resuming partial transfers"
+ ~category:(`Advanced `General)
+ "variant of copyprog for resuming partial transfers"
("A variant of {\\tt copyprog} that names an external program "
^ "that should be used to continue the transfer of a large file "
^ "that has already been partially transferred. Typically, "
@@ -713,7 +900,8 @@ let copyprogrest =
let copythreshold =
Prefs.createInt "copythreshold" (-1)
- "!use copyprog on files bigger than this (if >=0, in Kb)"
+ ~category:(`Advanced `General)
+ "use copyprog on files bigger than this (if >=0, in Kb)"
("A number indicating above what filesize (in kilobytes) Unison should "
^ "use the external "
^ "copying utility specified by {\\tt copyprog}. Specifying 0 will cause "
@@ -723,20 +911,13 @@ let copythreshold =
^ "See \\sectionref{speeding}{Making Unison Faster on Large Files} "
^ "for more information.")
-let copyquoterem =
- Prefs.createBoolWithDefault "copyquoterem"
- "!add quotes to remote file name for copyprog (true/false/default)"
- ("When set to {\\tt true}, this flag causes Unison to add an extra layer "
- ^ "of quotes to the remote path passed to the external copy program. "
- ^ "This is needed by rsync, for example, which internally uses an ssh "
- ^ "connection requiring an extra level of quoting for paths containing "
- ^ "spaces. When this flag is set to {\\tt default}, extra quotes are "
- ^ "added if the value of {\\tt copyprog} contains the string "
- ^ "{\\tt rsync}.")
+(* Pref copyquoterem removed since 2.53.3 *)
+let () = Prefs.markRemoved "copyquoterem"
let copymax =
Prefs.createInt "copymax" 1
- "!maximum number of simultaneous copyprog transfers"
+ ~category:(`Advanced `General)
+ "maximum number of simultaneous copyprog transfers"
("A number indicating how many instances of the external copying utility \
Unison is allowed to run simultaneously (default to 1).")
@@ -747,7 +928,7 @@ let formatConnectionInfo root =
(* Find the (unique) nonlocal root *)
match
Safelist.find (function Clroot.ConnectLocal _ -> false | _ -> true)
- (Safelist.map Clroot.parseRoot (Globals.rawRoots()))
+ (Globals.parsedClRawRoots ())
with
Clroot.ConnectByShell (_,rawhost,uo,_,_) ->
(match uo with None -> "" | Some u -> u ^ "@")
@@ -771,7 +952,7 @@ let shouldUseExternalCopyprog update desc =
&& update = `Copy
let prepareExternalTransfer fspathTo pathTo =
- let info = Fileinfo.get false fspathTo pathTo in
+ let info = Fileinfo.getBasic false fspathTo pathTo in
match info.Fileinfo.typ with
`FILE when Props.length info.Fileinfo.desc > Uutil.Filesize.zero ->
let perms = Props.perms info.Fileinfo.desc in
@@ -789,9 +970,9 @@ let prepareExternalTransfer fspathTo pathTo =
false
let finishExternalTransferLocal connFrom
- (fspathFrom, pathFrom, fspathTo, pathTo, realPathTo,
- update, desc, fp, ress, id) =
- let info = Fileinfo.get false fspathTo pathTo in
+ ((fspathFrom, pathFrom, fspathTo, pathTo, realPathTo),
+ (update, desc, fp, ress, id)) =
+ let info = Fileinfo.getBasic false fspathTo pathTo in
if
info.Fileinfo.typ <> `FILE ||
Props.length info.Fileinfo.desc <> Props.length desc
@@ -805,44 +986,61 @@ let finishExternalTransferLocal connFrom
Xferhint.insertEntry fspathTo pathTo fp;
Lwt.return res
+let convV0 = Remote.makeConvV0Funs
+ (fun ((fspathFrom, pathFrom, fspathTo, pathTo, realPathTo),
+ (update, desc, fp, ress, id)) ->
+ (fspathFrom, pathFrom, fspathTo, pathTo, realPathTo,
+ update, Props.to_compat251 desc, fp, ress, id))
+ (fun (fspathFrom, pathFrom, fspathTo, pathTo, realPathTo,
+ update, desc, fp, ress, id) ->
+ ((fspathFrom, pathFrom, fspathTo, pathTo, realPathTo),
+ (update, Props.of_compat251 desc, fp, ress, id)))
+ transferStatus_to_compat251
+ transferStatus_of_compat251
+
+let mcopyOrUpdate = Umarshal.(sum2 unit (prod2 Uutil.Filesize.m Uutil.Filesize.m id id)
+ (function
+ | `Copy -> I21 ()
+ | `Update (a, b) -> I22 (a, b))
+ (function
+ | I21 () -> `Copy
+ | I22 (a, b) -> `Update (a, b)))
+
+let mfinishExternalTransfer = Umarshal.(prod2
+ (prod5 Fspath.m Path.mlocal Fspath.m Path.mlocal Path.mlocal id id)
+ (prod5 mcopyOrUpdate Props.m Os.mfullfingerprint Osx.mressStamp Uutil.File.m id id)
+ id id)
+
let finishExternalTransferOnRoot =
Remote.registerRootCmdWithConnection
- "finishExternalTransfer" finishExternalTransferLocal
+ "finishExternalTransfer" ~convV0
+ mfinishExternalTransfer mtransferStatus finishExternalTransferLocal
-let copyprogReg = Lwt_util.make_region 1
+let copyprogReg = Remote.lwtRegionWithConnCleanup 1
let transferFileUsingExternalCopyprog
rootFrom pathFrom rootTo fspathTo pathTo realPathTo
update desc fp ress id useExistingTarget =
Uutil.showProgress id Uutil.Filesize.zero "ext";
- let prog =
+ let progWithArgs =
if useExistingTarget then
Prefs.read copyprogrest
else
Prefs.read copyprog
in
- let extraquotes = Prefs.read copyquoterem = `True
- || ( Prefs.read copyquoterem = `Default
- && Util.findsubstring "rsync" prog <> None) in
- let addquotes root s =
- match root with
- | Common.Local, _ -> s
- | Common.Remote _, _ -> if extraquotes then Uutil.quotes s else s in
let fromSpec =
(formatConnectionInfo rootFrom)
- ^ (addquotes rootFrom
- (Fspath.toString (Fspath.concat (snd rootFrom) pathFrom))) in
+ ^ (Fspath.toString (Fspath.concat (snd rootFrom) pathFrom)) in
let toSpec =
(formatConnectionInfo rootTo)
- ^ (addquotes rootTo
- (Fspath.toString (Fspath.concat fspathTo pathTo))) in
- let cmd = prog ^ " "
- ^ (Uutil.quotes fromSpec) ^ " "
- ^ (Uutil.quotes toSpec) in
- Trace.log (Printf.sprintf "%s\n" cmd);
- Lwt_util.resize_region copyprogReg (Prefs.read copymax);
- Lwt_util.run_in_region copyprogReg 1
- (fun () -> External.runExternalProgram cmd) >>= fun (_, log) ->
+ ^ (Fspath.toString (Fspath.concat fspathTo pathTo)) in
+ Trace.log (progWithArgs ^ " " ^ fromSpec ^ " " ^ toSpec ^ "\n");
+ Lwt_util.resize_region !copyprogReg (Prefs.read copymax);
+ let args = Str.split (Str.regexp "[ \t]+") progWithArgs in
+ let prog = match args with [] -> assert false | h :: _ -> h in
+ Lwt_util.run_in_region !copyprogReg 1
+ (fun () -> External.runExternalProgramArgs prog
+ (Array.of_list (args @ [fromSpec; toSpec]))) >>= fun (_, log) ->
debug (fun() ->
let l = Util.trimWhitespace log in
Util.msg "transferFileUsingExternalCopyprog %s: returned...\n%s%s"
@@ -850,14 +1048,14 @@ let transferFileUsingExternalCopyprog
l (if l="" then "" else "\n"));
Uutil.showProgress id (Props.length desc) "ext";
finishExternalTransferOnRoot rootTo rootFrom
- (snd rootFrom, pathFrom, fspathTo, pathTo, realPathTo,
- update, desc, fp, ress, id)
+ ((snd rootFrom, pathFrom, fspathTo, pathTo, realPathTo),
+ (update, desc, fp, ress, id))
(****)
let transferFileLocal connFrom
- (fspathFrom, pathFrom, fspathTo, pathTo, realPathTo,
- update, desc, fp, ress, id) =
+ ((fspathFrom, pathFrom, fspathTo, pathTo, realPathTo),
+ (update, desc, fp, ress, id)) =
let (tempInfo, isTransferred) =
fileIsTransferred fspathTo pathTo desc fp ress in
if isTransferred then begin
@@ -869,16 +1067,16 @@ let transferFileLocal connFrom
(Fspath.toDebugString fspathTo) (Path.toString realPathTo) in
let len = Uutil.Filesize.add (Props.length desc) (Osx.ressLength ress) in
Uutil.showProgress id len "alr";
+ propsWithExtData connFrom fspathFrom pathFrom desc >>= fun desc ->
setFileinfo fspathTo pathTo realPathTo update desc;
Xferhint.insertEntry fspathTo pathTo fp;
Lwt.return (`DONE (TransferSucceeded tempInfo, Some msg))
end else
registerFileTransfer pathTo fp
(fun () ->
- match
- tryCopyMovedFile fspathTo pathTo realPathTo update desc fp ress id
- with
- Some (info, msg) ->
+ tryCopyMovedFile connFrom fspathFrom pathFrom
+ fspathTo pathTo realPathTo update desc fp ress id >>= function
+ | Some (info, msg) ->
(* Transfer was performed by copying *)
Xferhint.insertEntry fspathTo pathTo fp;
Lwt.return (`DONE (TransferSucceeded info, Some msg))
@@ -894,12 +1092,37 @@ let transferFileLocal connFrom
Lwt.return (`DONE (status, None))
end)
+let convV0 = Remote.makeConvV0Funs
+ (fun ((fspathFrom, pathFrom, fspathTo, pathTo, realPathTo),
+ (update, desc, fp, ress, id)) ->
+ (fspathFrom, pathFrom, fspathTo, pathTo, realPathTo,
+ update, Props.to_compat251 desc, fp, ress, id))
+ (fun (fspathFrom, pathFrom, fspathTo, pathTo, realPathTo,
+ update, desc, fp, ress, id) ->
+ ((fspathFrom, pathFrom, fspathTo, pathTo, realPathTo),
+ (update, Props.of_compat251 desc, fp, ress, id)))
+ (function
+ | `DONE (a, b) -> `DONE (transferStatus_to_compat251 a, b)
+ | `EXTERNAL a -> `EXTERNAL a)
+ (function
+ | `DONE (a, b) -> `DONE (transferStatus_of_compat251 a, b)
+ | `EXTERNAL a -> `EXTERNAL a)
+
+let mtransferFile = Umarshal.(sum2 (prod2 mtransferStatus (option string) id id) bool
+ (function
+ | `DONE (a, b) -> I21 (a, b)
+ | `EXTERNAL a -> I22 a)
+ (function
+ | I21 (a, b) -> `DONE (a, b)
+ | I22 a -> `EXTERNAL a))
+
let transferFileOnRoot =
- Remote.registerRootCmdWithConnection "transferFile" transferFileLocal
+ Remote.registerRootCmdWithConnection "transferFile" ~convV0
+ mfinishExternalTransfer mtransferFile transferFileLocal
(* We limit the size of the output buffers to about 512 KB
(we cannot go above the limit below plus 64) *)
-let transferFileReg = Lwt_util.make_region 440
+let transferFileReg = Remote.lwtRegionWithConnCleanup 440
let bufferSize sz =
(* Token queue *)
@@ -914,8 +1137,8 @@ let transferFile
let f () =
Abort.check id;
transferFileOnRoot rootTo rootFrom
- (snd rootFrom, pathFrom, fspathTo, pathTo, realPathTo,
- update, desc, fp, ress, id) >>= fun status ->
+ ((snd rootFrom, pathFrom, fspathTo, pathTo, realPathTo),
+ (update, desc, fp, ress, id)) >>= fun status ->
match status with
`DONE (status, msg) ->
begin match msg with
@@ -945,7 +1168,7 @@ let transferFile
f ()
else
let bufSz = bufferSize (max (Props.length desc) (Osx.ressLength ress)) in
- Lwt_util.run_in_region transferFileReg bufSz f
+ Lwt_util.run_in_region !transferFileReg bufSz f
(****)
@@ -991,7 +1214,8 @@ let file rootFrom pathFrom rootTo fspathTo pathTo realPathTo
checkForChangesToSource rootFrom pathFrom desc fp stamp ress None true
>>= fun () ->
(* This function never returns (it is supposed to fail) *)
- saveTempFileOnRoot rootTo (pathTo, realPathTo, reason)
+ saveTempFileOnRoot rootTo (pathTo, realPathTo, reason) >>= fun () ->
+ assert false
(****)
@@ -1015,7 +1239,7 @@ let recursively fspathFrom pathFrom fspathTo pathTo =
debug (fun () -> Util.msg " Copying directory %s / %s to %s / %s\n"
(Fspath.toDebugString fspathFrom) (Path.toString pFrom)
(Fspath.toDebugString fspathTo) (Path.toString pTo));
- Os.createDir fspathTo pTo info.Fileinfo.desc;
+ Os.createDir fspathTo pTo (Props.perms info.Fileinfo.desc);
let ch = Os.childrenOf fspathFrom pFrom in
Safelist.iter
(fun n -> copy (Path.child pFrom n) (Path.child pTo n)) ch
diff --git a/src/copy.mli b/src/copy.mli
index d9e7f2b..c5b8572 100644
--- a/src/copy.mli
+++ b/src/copy.mli
@@ -13,7 +13,7 @@ val file :
-> Fileinfo.stamp option (* source file stamp, if available *)
-> Osx.ressStamp (* resource info of file *)
-> Uutil.File.t (* file's index in UI (for progress bars) *)
- -> Fileinfo.t Lwt.t (* information regarding the transferred file *)
+ -> Fileinfo.basic Lwt.t (* information regarding the transferred file *)
val localFile :
Fspath.t (* fspath of source *)
@@ -33,3 +33,16 @@ val recursively :
-> Fspath.t (* fspath of target *)
-> Path.local (* path of target *)
-> unit
+
+val readPropsExtData :
+ Common.root (* root of source *)
+ -> Path.local (* path of source *)
+ -> Props.t (* props of source *)
+ -> Props.x Lwt.t (* props with all ext data included *)
+
+val readPropsExtDataG :
+ Common.root (* root of source *)
+ -> Path.t (* path of source *)
+ -> Props.t (* props of source *)
+ -> (Path.local option * Props.x) Lwt.t (* props with all ext data included
+ and path translated to local path *)
diff --git a/src/dune b/src/dune
index e5cd45a..1968ba2 100644
--- a/src/dune
+++ b/src/dune
@@ -1,7 +1,7 @@
(library
(name unison_lib)
(wrapped false)
- (modules :standard \ linktext linkgtk linkgtk2 uigtk2 uimacbridge uimacbridgenew test)
+ (modules :standard \ linktext linkgtk3 uigtk3 uimacbridge test)
(modules_without_implementation ui)
(flags :standard
-w -3-6-9-10-26-27-32-34-35-38-39-50-52
@@ -9,7 +9,7 @@
-no-strict-sequence)
(foreign_stubs
(language c)
- (names bytearray_stubs osxsupport pty hash_compat))
+ (names bytearray_stubs osxsupport pty hash_compat props_xattr props_acl))
(c_library_flags -lutil)
(libraries str unix lwt_lib bigarray))
@@ -18,12 +18,14 @@
(executable
(name linktext)
(public_name unison)
+ (package unison)
(modules linktext)
(libraries unison_lib))
(executable
- (name linkgtk2)
- (public_name unison-gtk2)
+ (name linkgtk3)
+ (public_name unison-gui)
+ (package unison-gui)
(flags :standard -w -3-6-9-27-32-52)
- (modules linkgtk2 uigtk2)
- (libraries threads unison_lib lablgtk2))
+ (modules linkgtk3 uigtk3)
+ (libraries threads unison_lib lablgtk3))
diff --git a/src/external.ml b/src/external.ml
index 71f8bbf..f133682 100644
--- a/src/external.ml
+++ b/src/external.ml
@@ -25,6 +25,58 @@ let debug = Util.debug "external"
let (>>=) = Lwt.bind
open Lwt
+(* For backwards compatibility with OCaml < 4.12 *)
+let path =
+ try
+ Str.split (Str.regexp (if Util.osType = `Win32 then ";" else ":"))
+ (Sys.getenv "PATH")
+ with Not_found ->
+ []
+
+let search_in_path ?(path = path) name =
+ if String.contains name '/' then name else
+ Filename.concat
+ (List.find (fun dir ->
+ let p = Filename.concat dir name in
+ let found = System.file_exists p in
+ debug (fun () -> Util.msg "'%s' ...%s\n" p
+ (match found with true -> "found" | false -> "not found"));
+ found)
+ path)
+ name
+
+(* Make sure external process resources are collected and zombie processes
+ reaped when the Lwt thread calling the external program is stopped
+ suddenly due to remote connection being closed. *)
+let close_process_noerr close pid x =
+ let pid = pid x in
+ begin try
+ Unix.kill pid (if Sys.os_type = "Win32" then Sys.sigkill else Sys.sigterm)
+ with Unix.Unix_error _ -> () end;
+ begin try ignore (Terminal.safe_waitpid pid) with Unix.Unix_error _ -> () end;
+ try ignore (close x) with Sys_error _ | Unix.Unix_error _ -> ()
+
+let inProcRes =
+ Remote.resourceWithConnCleanup System.close_process_in
+ (close_process_noerr System.close_process_in System.process_in_pid)
+let fullProcRes =
+ Remote.resourceWithConnCleanup System.close_process_full
+ (close_process_noerr System.close_process_full System.process_full_pid)
+
+let openProcessIn cmd = inProcRes.register (System.open_process_in cmd)
+let closeProcessIn = inProcRes.release
+
+(* Remove call to search_in_path once we require OCaml >= 4.12. *)
+let openProcessArgsIn cmd args = inProcRes.register (System.open_process_args_in (search_in_path cmd) args)
+let closeProcessArgsIn = inProcRes.release
+
+let openProcessFull cmd = fullProcRes.register (System.open_process_full cmd)
+let closeProcessFull = fullProcRes.release
+
+(* Remove call to search_in_path once we require OCaml >= 4.12. *)
+let openProcessArgsFull cmd args = fullProcRes.register (System.open_process_args_full (search_in_path cmd) args)
+let closeProcessArgsFull = fullProcRes.release
+
let readChannelTillEof c =
let lst = ref [] in
let rec loop () =
@@ -56,12 +108,13 @@ let readChannelsTillEof l =
>>= (fun res -> return (String.concat "\n" (Safelist.rev res))))
l
-let runExternalProgram cmd =
+
+let runExternalProgramAux ~winProc ~posixProc =
if Util.osType = `Win32 && not Util.isCygwin then begin
debug (fun()-> Util.msg "Executing external program windows-style\n");
- let c = System.open_process_in ("\"" ^ cmd ^ "\"") in
+ let c = winProc () in
let log = Util.trimWhitespace (readChannelTillEof c) in
- let returnValue = System.close_process_in c in
+ let returnValue = closeProcessIn c in
let resultLog =
(*cmd ^
(if log <> "" then "\n\n" ^*) log (*else "")*) ^
@@ -71,12 +124,12 @@ let runExternalProgram cmd =
"") in
Lwt.return (returnValue, resultLog)
end else
- let (out, ipt, err) as desc = System.open_process_full cmd in
+ let (out, ipt, err) as desc = posixProc () in
let out = Lwt_unix.intern_in_channel out in
let err = Lwt_unix.intern_in_channel err in
readChannelsTillEof [out;err]
>>= (function [logOut;logErr] ->
- let returnValue = System.close_process_full desc in
+ let returnValue = closeProcessFull desc in
let logOut = Util.trimWhitespace logOut in
let logErr = Util.trimWhitespace logErr in
return (returnValue, (
@@ -90,3 +143,13 @@ let runExternalProgram cmd =
else "\n\n" ^ Util.process_status_to_string returnValue)))
(* Stop typechechecker from complaining about non-exhaustive pattern above *)
| _ -> assert false)
+
+let runExternalProgram cmd =
+ runExternalProgramAux
+ ~winProc:(fun () -> openProcessIn ("\"" ^ cmd ^ "\""))
+ ~posixProc:(fun () -> openProcessFull cmd)
+
+let runExternalProgramArgs cmd args =
+ runExternalProgramAux
+ ~winProc:(fun () -> openProcessArgsIn cmd args)
+ ~posixProc:(fun () -> openProcessArgsFull cmd args)
diff --git a/src/external.mli b/src/external.mli
index 30d2dbd..d2d0bae 100644
--- a/src/external.mli
+++ b/src/external.mli
@@ -2,4 +2,5 @@
(* Copyright 1999-2020, Benjamin C. Pierce (see COPYING for details) *)
val runExternalProgram : string -> (Unix.process_status * string) Lwt.t
+val runExternalProgramArgs : string -> string array -> (Unix.process_status * string) Lwt.t
val readChannelTillEof : in_channel -> string
diff --git a/src/features.ml b/src/features.ml
new file mode 100644
index 0000000..407561b
--- /dev/null
+++ b/src/features.ml
@@ -0,0 +1,85 @@
+(* Unison file synchronizer: src/features.ml *)
+(* Copyright 2021, Tõivo Leedjärv
+
+ This program is free software: you can redistribute it and/or modify
+ it under the terms of the GNU General Public License as published by
+ the Free Software Foundation, either version 3 of the License, or
+ (at your option) any later version.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with this program. If not, see <http://www.gnu.org/licenses/>.
+*)
+
+type id = string
+
+type t = { mutable enabled : bool;
+ arcFormatChange : bool;
+ validator : (id list -> bool -> string option) option }
+
+let allFeatures = Hashtbl.create 8
+let allNames = ref []
+
+let all () = !allNames
+
+let mem = List.mem
+
+let empty = []
+
+let changingArchiveFormat () =
+ let enabledArch name t accu =
+ if t.enabled && t.arcFormatChange then name :: accu else accu
+ in
+ Hashtbl.fold enabledArch allFeatures []
+
+let inter a b = List.filter (fun name -> mem name a) b
+
+let getEnabled () =
+ let enabled name t accu = if t.enabled then name :: accu else accu in
+ Hashtbl.fold enabled allFeatures []
+
+let setEnabled features =
+ Hashtbl.iter (fun name t -> t.enabled <- mem name features) allFeatures
+
+let resetEnabled () = setEnabled empty
+
+(***************)
+
+let validate features =
+ let aux name t =
+ let failed = match t.validator with
+ | Some fn -> fn features (mem name features)
+ | None -> None
+ in
+ match failed with
+ | None -> ()
+ | Some e ->
+ raise (Util.Fatal
+ ("Client and server are incompatible. Setting up feature \""
+ ^ name ^ "\" failed with error\n\"" ^ e ^ "\".\n\n"
+ ^ "It may be possible to rectify this by changing the user "
+ ^ "preferences.\nUltimately, it may require upgrading either "
+ ^ "the server or the client."))
+ in
+ Hashtbl.iter aux allFeatures
+
+let validateEnabled () = validate (getEnabled ())
+
+(***************)
+
+let enabled feature = feature.enabled
+
+let dummy = { enabled = false; arcFormatChange = false; validator = None }
+
+let register name ?(arcFormatChange = false) validatefn =
+ if Hashtbl.mem allFeatures name then
+ raise (Util.Fatal ("Feature " ^ name ^ " registered twice"));
+ let v = { enabled = false; arcFormatChange; validator = validatefn } in
+ Hashtbl.add allFeatures name v;
+ allNames := name :: !allNames;
+ v
+
diff --git a/src/features.mli b/src/features.mli
new file mode 100644
index 0000000..3001ab4
--- /dev/null
+++ b/src/features.mli
@@ -0,0 +1,87 @@
+(* Unison file synchronizer: src/features.mli *)
+(* Copyright 2021, Tõivo Leedjärv
+
+ This program is free software: you can redistribute it and/or modify
+ it under the terms of the GNU General Public License as published by
+ the Free Software Foundation, either version 3 of the License, or
+ (at your option) any later version.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with this program. If not, see <http://www.gnu.org/licenses/>.
+*)
+
+type t
+(** The type of a feature. *)
+
+type id = string
+(** The type of feature's identifier. Features are identified by their name. *)
+
+val enabled : t -> bool
+(** Test whether a feature is currently enabled (included in the current
+ set of enabled features).
+
+ Feature negotiation must have been completed to get the correct result. *)
+
+val register : string -> ?arcFormatChange:bool ->
+ (id list -> bool -> string option) option -> t
+(** [register n f] registers a supported feature with a unique identifier [n].
+
+ [f] is an optional validation function that will be called during feature
+ negotiation. [f] will receive as the first argument the feature set to be
+ enabled as a result of negotiation and as the second argument a boolean
+ indicating whether the tested feature is included in the negotiated set.
+ [f] must return [Some msg] if the negotiation result must be rejected with
+ the error message [msg], otherwise it must return [None].
+
+ [archFormatChange] is an optional argument which indicates whether the
+ feature, if enabled, changes the archive format that is stored on disk.
+ In other words, it indicates if the archive stored while this feature was
+ enabled requires the existence of this feature to be read back in.
+
+ @return feature value that can be tested by {!Features.enabled} function.
+ @raise {!Util.Fatal} if [n] is not unique. *)
+
+val dummy : t
+(** A feature value that will never be included in feature negotiation or
+ the set of enabled features. *)
+
+val all : unit -> id list
+(** Set of all supported features registered by {!Features.register}. *)
+
+val empty : id list
+(** Empty set of features. *)
+
+val changingArchiveFormat : unit -> id list
+(** Set of all currently enabled features that impact the on-disk archive
+ format. The same features must exist in order to read in the archive. *)
+
+val mem : id -> id list -> bool
+(** [mem n s] tests whether feature with id [n] belongs to feature set [s]. *)
+
+val inter : id list -> id list -> id list
+(** Feature set intersection. *)
+
+val validate : id list -> unit
+(** [validate s] calls validation functions associated with each registered
+ feature in arbitrary order, with only features in [s] considered enabled.
+
+ @raise {!Util.Fatal} at first failed validation. *)
+
+val getEnabled : unit -> id list
+(** Set of enabled features. *)
+
+val resetEnabled : unit -> unit
+(** Make the set of enabled features empty. Can be used to reset the results
+ of previous feature negotiation. *)
+
+val setEnabled : id list -> unit
+(** [setEnabled s] makes [s] the set of enabled features. *)
+
+val validateEnabled : unit -> unit
+(** Same as {!Features.validate} with the set of currently enabled features. *)
+
diff --git a/src/fileinfo.ml b/src/fileinfo.ml
index 4a39ce8..38de32b 100644
--- a/src/fileinfo.ml
+++ b/src/fileinfo.ml
@@ -20,18 +20,22 @@ let debugV = Util.debug "fileinfo+"
let allowSymlinks =
Prefs.createBoolWithDefault "links"
- "!allow the synchronization of symbolic links (true/false/default)"
+ ~category:(`Advanced `Sync)
+ "allow the synchronization of symbolic links (true/false/default)"
("When set to {\\tt true}, this flag causes Unison to synchronize \
symbolic links. When the flag is set to {\\tt false}, symbolic \
- links will result in an error during update detection. \
+ links will be ignored during update detection. \
Ordinarily, when the flag is set to {\\tt default}, symbolic \
links are synchronized except when one of the hosts is running \
Windows. On a Windows client, Unison makes an attempt to detect \
if symbolic links are supported and allowed by user privileges. \
- You may have to get elevated privileges to create symbolic links.")
+ You may have to get elevated privileges to create symbolic links. \
+ When the flag is set to {\\t default} and symbolic links can't be \
+ synchronized then an error is produced during update detection.")
let symlinksAllowed =
Prefs.createBool "links-aux" true
+ ~category:(`Internal `Pseudo)
"*Pseudo-preference for internal use only" ""
let init b =
@@ -42,13 +46,55 @@ let init b =
type typ = [ `ABSENT | `FILE | `DIRECTORY | `SYMLINK ]
+let mtyp = Umarshal.(sum4 unit unit unit unit
+ (function
+ | `ABSENT -> I41 ()
+ | `FILE -> I42 ()
+ | `DIRECTORY -> I43 ()
+ | `SYMLINK -> I44 ())
+ (function
+ | I41 () -> `ABSENT
+ | I42 () -> `FILE
+ | I43 () -> `DIRECTORY
+ | I44 () -> `SYMLINK))
+
let type2string = function
`ABSENT -> "nonexistent"
| `FILE -> "file"
| `DIRECTORY -> "dir"
| `SYMLINK -> "symlink"
-type t = { typ : typ; inode : int; desc : Props.t; osX : Osx.info}
+(* IMPORTANT!
+ This is the 2.51-compatible version of type [Fileinfo.t]. It must always
+ remain exactly the same as the type [Fileinfo.t] in version 2.51.5. This
+ means that if any of the types it is composed of changes then for each
+ changed type also a 2.51-compatible version must be created. *)
+type t251 = { typ : typ; inode : int; desc : Props.t251; osX : Osx.info}
+
+type ('a, 'b) info = { typ : typ; inode : int; desc : 'a; osX : Osx.info }
+ constraint 'a = _ Props.props
+type t = (Props.t, [`WithRess]) info
+type basic = (Props.basic, [`NoRess]) info
+type bress = (Props.basic, [`WithRess]) info
+
+let minfo propsm = Umarshal.(prod4 mtyp int propsm Osx.minfo
+ (fun {typ; inode; desc; osX} -> typ, inode, desc, osX)
+ (fun (typ, inode, desc, osX) -> {typ; inode; desc; osX}))
+
+let m = minfo Props.m
+let mbasic = minfo Props.mbasic
+
+let to_compat251 (x : basic) : t251 =
+ { typ = x.typ;
+ inode = x.inode;
+ desc = Props.to_compat251 x.desc;
+ osX = x.osX }
+
+let of_compat251 (x : t251) : basic =
+ { typ = x.typ;
+ inode = x.inode;
+ desc = Props.of_compat251 x.desc;
+ osX = x.osX }
(* Stat function that pays attention to pref for following links *)
let statFn fromRoot fspath path =
@@ -67,7 +113,21 @@ let statFn fromRoot fspath path =
end else
stats
-let get fromRoot fspath path =
+(* Warning! Do not change this string without some backwards compatibility
+ code in place. This string is not only meant for humans, it is also
+ processed by code. *)
+let symlinkErr = " is a symbolic link"
+let symlinkErrLen = String.length symlinkErr
+
+let shouldIgnore s =
+ Prefs.read allowSymlinks = `False &&
+ let l = String.length s in
+ if l > symlinkErrLen then
+ String.sub s (l - symlinkErrLen) symlinkErrLen = symlinkErr
+ else
+ false
+
+let getAux fromRoot fspath path getProps =
Util.convertUnixErrorsToTransient
"querying file information"
(fun () ->
@@ -87,8 +147,9 @@ let get fromRoot fspath path =
else
raise
(Util.Transient
- (Format.sprintf "path %s is a symbolic link"
- (Fspath.toPrintString (Fspath.concat fspath path))))
+ ("path " ^
+ (Fspath.toPrintString (Fspath.concat fspath path)) ^
+ symlinkErr))
| _ ->
raise (Util.Transient
("path " ^
@@ -100,7 +161,7 @@ let get fromRoot fspath path =
inode = (* The inode number is truncated so that
it fits in a 31 bit ocaml integer *)
stats.Unix.LargeFile.st_ino land 0x3FFFFFFF;
- desc = Props.get stats osxInfos;
+ desc = getProps fspath path stats osxInfos;
osX = osxInfos }
with
Unix.Unix_error((Unix.ENOENT | Unix.ENOTDIR),_,_) ->
@@ -109,6 +170,26 @@ let get fromRoot fspath path =
desc = Props.dummy;
osX = Osx.getFileInfos fspath path `ABSENT })
+let getType fromRoot fspath path =
+ (getAux fromRoot fspath path (fun _ _ _ _ -> Props.dummy)).typ
+
+let getBasic fromRoot fspath path =
+ getAux fromRoot fspath path (fun _ _ st _ -> Props.get' st)
+
+let getBasicWithRess fromRoot fspath path =
+ getAux fromRoot fspath path (fun _ _ st i -> Props.getWithRess st i)
+
+let get ?(archProps = Props.dummy) fromRoot fspath path =
+ let getProps fspath path stats typ =
+ Props.get ~archProps fspath path stats typ in
+ getAux fromRoot fspath path getProps
+
+let basic x =
+ { typ = x.typ;
+ inode = x.inode;
+ desc = x.desc;
+ osX = x.osX }
+
let check fspath path props =
Util.convertUnixErrorsToTransient
"checking file information"
@@ -139,20 +220,45 @@ let set fspath path action newDesc =
Props.set fspath path kind p;
check fspath path p
-type stamp =
+(* IMPORTANT!
+ This is the 2.51-compatible version of type [Fileinfo.stamp]. It must
+ always remain exactly the same as the type [Fileinfo.stamp] in version
+ 2.51.5. *)
+type stamp251 =
InodeStamp of int (* inode number, for Unix systems *)
| CtimeStamp of float (* creation time, for windows systems *)
- (* FIX [BCP, 3/07]: The Ctimestamp variant is actually bogus.
- For file transfers, it appears that using the ctime to detect a
- file change is completely ineffective as, when a file is deleted (or
- renamed) and then replaced by another file, the new file inherits the
- ctime of the old file. It is slightly harmful performancewise, as
- fastcheck expects ctime to be preserved by renaming. Thus, we should
- probably not use any stamp under Windows. *)
+
+type stamp =
+ | InodeStamp of int (* inode number, for Unix systems *)
+ | NoStamp
+ | RescanStamp (* stamp indicating file should be rescanned
+ (perhaps because previous transfer failed) *)
+
+let mstamp = Umarshal.(sum3 int unit unit
+ (function
+ | InodeStamp a -> I31 a
+ | NoStamp -> I32 ()
+ | RescanStamp -> I33 ())
+ (function
+ | I31 a -> InodeStamp a
+ | I32 () -> NoStamp
+ | I33 () -> RescanStamp))
+
+let stamp_to_compat251 (st : stamp) : stamp251 =
+ match st with
+ | InodeStamp i -> InodeStamp i
+ | NoStamp -> CtimeStamp 0.0
+ | RescanStamp -> InodeStamp (-1)
+
+let stamp_of_compat251 (st : stamp251) : stamp =
+ match st with
+ | InodeStamp i -> if i <> -1 then InodeStamp i else RescanStamp
+ | CtimeStamp _ -> NoStamp
let ignoreInodeNumbers =
Prefs.createBool "ignoreinodenumbers" false
- "!ignore inode number changes when detecting updates"
+ ~category:(`Advanced `Syncprocess)
+ "ignore inode number changes when detecting updates"
("When set to true, this preference makes Unison not take advantage \
of inode numbers during fast update detection. \
This switch should be used with care, as it \
@@ -161,17 +267,15 @@ let ignoreInodeNumbers =
let _ = Prefs.alias ignoreInodeNumbers "pretendwin"
let stamp info =
- (* Was "CtimeStamp info.ctime", but this is bogus: Windows
- ctimes are not reliable. *)
- if Prefs.read ignoreInodeNumbers then CtimeStamp 0.0 else
- if Fs.hasInodeNumbers () then InodeStamp info.inode else CtimeStamp 0.0
+ if Prefs.read ignoreInodeNumbers then NoStamp else
+ if Fs.hasInodeNumbers () then InodeStamp info.inode else NoStamp
let ressStamp info = Osx.stamp info.osX
let unchanged fspath path info =
(* The call to [Util.time] must be before the call to [get] *)
let t0 = Util.time () in
- let info' = get true fspath path in
+ let info' = get ~archProps:info.desc true fspath path in
let dataUnchanged =
Props.same_time info.desc info'.desc
&&
@@ -186,24 +290,3 @@ let unchanged fspath path info =
(info', dataUnchanged,
Osx.ressUnchanged info.osX.Osx.ressInfo info'.osX.Osx.ressInfo
(Some t0) dataUnchanged)
-
-(****)
-
-let get' f =
- Util.convertUnixErrorsToTransient
- "querying file information"
- (fun () ->
- try
- let stats = System.stat f in
- let typ = `FILE in
- let osxInfos = Osx.defaultInfos typ in
- { typ = typ;
- inode = stats.Unix.LargeFile.st_ino land 0x3FFFFFFF;
- desc = Props.get stats osxInfos;
- osX = osxInfos }
- with
- Unix.Unix_error((Unix.ENOENT | Unix.ENOTDIR),_,_) ->
- { typ = `ABSENT;
- inode = 0;
- desc = Props.dummy;
- osX = Osx.defaultInfos `ABSENT })
diff --git a/src/fileinfo.mli b/src/fileinfo.mli
index 7d5242d..e84324a 100644
--- a/src/fileinfo.mli
+++ b/src/fileinfo.mli
@@ -2,22 +2,49 @@
(* Copyright 1999-2020, Benjamin C. Pierce (see COPYING for details) *)
type typ = [`ABSENT | `FILE | `DIRECTORY | `SYMLINK]
+val mtyp : typ Umarshal.t
val type2string : typ -> string
-type t = { typ : typ; inode : int; desc : Props.t; osX : Osx.info}
+type t251 = { typ : typ; inode : int; desc : Props.t251; osX : Osx.info}
+type ('a, 'b) info = private { typ : typ; inode : int; desc : 'a; osX : Osx.info }
+ constraint 'a = _ Props.props
+type t = (Props.t, [`WithRess]) info
+type basic = (Props.basic, [`NoRess]) info
+type bress = (Props.basic, [`WithRess]) info
-val get : bool (* fromRoot *) -> Fspath.t -> Path.local -> t
+val basic : bress -> basic
+
+val m : t Umarshal.t
+val mbasic : basic Umarshal.t
+
+val to_compat251 : basic -> t251
+val of_compat251 : t251 -> basic
+
+val getType : bool (* fromRoot *) -> Fspath.t -> Path.local -> typ
+val getBasic : bool (* fromRoot *) -> Fspath.t -> Path.local -> basic
+val getBasicWithRess : bool (* fromRoot *) -> Fspath.t -> Path.local -> bress
+val get : ?archProps:Props.t -> bool (* fromRoot *) -> Fspath.t -> Path.local -> t
val set : Fspath.t -> Path.local ->
- [`Set of Props.t | `Copy of Path.local | `Update of Props.t] ->
- Props.t -> unit
-val get' : System.fspath -> t
+ [`Set of Props.basic | `Copy of Path.local | `Update of Props.t] ->
+ Props.x -> unit
(* IF THIS CHANGES, MAKE SURE TO INCREMENT THE ARCHIVE VERSION NUMBER! *)
-type stamp =
+type stamp251 =
InodeStamp of int (* inode number, for Unix systems *)
| CtimeStamp of float (* creation time, for windows systems *)
-val stamp : t -> stamp
+type stamp =
+ | InodeStamp of int (* inode number, for Unix systems *)
+ | NoStamp
+ | RescanStamp (* stamp indicating file should be rescanned
+ (perhaps because previous transfer failed) *)
+
+val mstamp : stamp Umarshal.t
+
+val stamp_to_compat251 : stamp -> stamp251
+val stamp_of_compat251 : stamp251 -> stamp
+
+val stamp : _ info -> stamp
val ressStamp : t -> Osx.ressStamp
@@ -28,4 +55,5 @@ val unchanged : Fspath.t -> Path.local -> t -> (t * bool * bool)
val init : bool -> unit
val allowSymlinks : [`True|`False|`Default] Prefs.t
+val shouldIgnore : string (* error message *) -> bool
val ignoreInodeNumbers : bool Prefs.t
diff --git a/src/files.ml b/src/files.ml
index f6c0dac..28a37ff 100644
--- a/src/files.ml
+++ b/src/files.ml
@@ -46,20 +46,26 @@ let writeCommitLog source target tempname =
Printf.fprintf c "(and delete this notice when you've done so).\n";
close_out c)
-let clearCommitLog pathTo =
+let clearCommitLog tmpName =
debug (fun() -> (Util.msg "Deleting commit log\n"));
- let tmpPathDir = Fspath.canonize (Some Util.unisonDirStr) in (* tmpPathDir is a Fspath.t *)
- (* Use pathTo in the temporary name (instead of DANGER.README) to reduce chance of reuse *)
- let tmpPath = Os.tempPath tmpPathDir pathTo in (* tmpPath is a Path.local *)
- let dangerFspath = Fspath.canonize (Some (System.fspathToString commitLogName)) in
- let dangerFsPathTmp = Fspath.concat tmpPathDir tmpPath in
+ let commitLogNameWin () =
+ (* Work around an issue in Windows where unlink may not be immediate. *)
+ let p = commitLogName ^ (Filename.basename (Path.toString tmpName)) in
+ let rec tmp n =
+ let p = p ^ (string_of_int n) in
+ if System.file_exists p then tmp (n + 1)
+ else (System.rename commitLogName p; p)
+ in
+ try tmp 0 with
+ | Sys_error _ | Unix.Unix_error _ -> commitLogName
+ in
+ let commitLogUnlinkPath =
+ if Util.osType = `Win32 then commitLogNameWin () else commitLogName in
- Os.renameFspath "DANGER.README" dangerFspath dangerFsPathTmp;
-
Util.convertUnixErrorsToFatal
"clearing commit log"
- (fun () -> System.unlink (System.fspathFromString (Fspath.toString dangerFsPathTmp)) )
+ (fun () -> System.unlink commitLogUnlinkPath)
let processCommitLog () =
if System.file_exists commitLogName then begin
@@ -68,21 +74,22 @@ let processCommitLog () =
"Warning: the previous run of %s terminated in a dangerous state.
Please consult the file %s, delete it, and try again."
Uutil.myName
- (System.fspathToPrintString commitLogName)))
+ commitLogName))
end else
Lwt.return ()
let processCommitLogOnHost =
- Remote.registerHostCmd "processCommitLog" processCommitLog
+ Remote.registerHostCmd "processCommitLog" Umarshal.unit Umarshal.unit processCommitLog
let processCommitLogs() =
Lwt_unix.run
- (Globals.allHostsIter (fun h -> processCommitLogOnHost h ()))
+ (Globals.allRootsIter (fun r -> processCommitLogOnHost r ()))
(* ------------------------------------------------------------ *)
let copyOnConflict = Prefs.createBool "copyonconflict" false
- "!keep copies of conflicting files"
+ ~category:(`Advanced `Syncprocess)
+ "keep copies of conflicting files"
"When this flag is set, Unison will make a copy of files that would \
otherwise be overwritten or deleted in case of conflicting changes, \
and more generally whenever the default behavior is overridden. \
@@ -92,7 +99,7 @@ let copyOnConflict = Prefs.createBool "copyonconflict" false
let prepareCopy workingDir path notDefault =
if notDefault && Prefs.read copyOnConflict then begin
- match (Fileinfo.get true workingDir path).Fileinfo.typ with
+ match Fileinfo.getType true workingDir path with
| `ABSENT -> Some (workingDir, path, None)
| _ ->
begin
@@ -143,7 +150,15 @@ let deleteLocal (fspathTo, (pathTo, ui, notDefault)) =
Update.replaceArchiveLocal fspathTo localPathTo Update.NoArchive;
Lwt.return ()
-let deleteOnRoot = Remote.registerRootCmd "delete" deleteLocal
+let convV0 = Remote.makeConvV0FunArg
+ (fun (fspathTo, (pathTo, ui, notDefault)) ->
+ (fspathTo, (pathTo, Common.ui_to_compat251 ui, notDefault)))
+ (fun (fspathTo, (pathTo, ui, notDefault)) ->
+ (fspathTo, (pathTo, Common.ui_of_compat251 ui, notDefault)))
+
+let deleteOnRoot = Remote.registerRootCmd "delete" ~convV0
+ Umarshal.(prod3 Path.m Common.mupdateItem bool id id) Umarshal.unit
+ deleteLocal
let delete rootFrom pathFrom rootTo pathTo ui notDefault =
deleteOnRoot rootTo (pathTo, ui, notDefault) >>= fun _ ->
@@ -162,18 +177,49 @@ let setPropLocal (fspath, (path, ui, newDesc, oldDesc)) =
let localPath = Update.translatePathLocal fspath path in
let (workingDir,realPath) = Fspath.findWorkingDir fspath localPath in
Fileinfo.set workingDir realPath (`Update oldDesc) newDesc;
+ let newDesc = Props.purgeExtData newDesc in
if fileUpdated ui then Stasher.stashCurrentVersion fspath localPath None;
(* Archive update must be done last *)
Update.updateProps fspath localPath (Some newDesc) ui;
Lwt.return ()
-let setPropOnRoot = Remote.registerRootCmd "setProp" setPropLocal
+let convV0 = Remote.makeConvV0FunArg
+ (fun (fspath, (path, ui, newDesc, oldDesc)) ->
+ (fspath, (path, Common.ui_to_compat251 ui,
+ Props.to_compat251 newDesc, Props.to_compat251 oldDesc)))
+ (fun (fspath, (path, ui, newDesc, oldDesc)) ->
+ (fspath, (path, Common.ui_of_compat251 ui,
+ Props.of_compat251 newDesc, Props.of_compat251 oldDesc)))
+
+let setPropOnRoot = Remote.registerRootCmd "setProp" ~convV0
+ Umarshal.(prod4 Path.m Common.mupdateItem Props.mx Props.m id id) Umarshal.unit
+ setPropLocal
+
+let propOpt_to_compat251 = function
+ | Some prop -> Some (Props.to_compat251 prop)
+ | None -> None
+
+let propOpt_of_compat251 = function
+ | Some prop -> Some (Props.of_compat251 prop)
+ | None -> None
+
+let convV0 = Remote.makeConvV0FunArg
+ (fun (fspath, (path, propOpt, ui)) ->
+ (fspath, (Path.makeGlobal path, propOpt_to_compat251 propOpt,
+ Common.ui_to_compat251 ui)))
+ (fun (fspath, (path, propOpt, ui)) ->
+ (fspath, (Path.forceLocal path,
+ propOpt_of_compat251 propOpt, Common.ui_of_compat251 ui)))
let updatePropsOnRoot =
Remote.registerRootCmd
- "updateProps"
+ "updateProps" ~convV0
+ Umarshal.(prod3 Path.mlocal (option Props.m) Common.mupdateItem id id)
+ Umarshal.unit
(fun (fspath, (path, propOpt, ui)) ->
- let localPath = Update.translatePathLocal fspath path in
+ (* Previous versions of this function received a global path as input *)
+ let localPath = if Props.xattrEnabled () then path
+ else Update.translatePathLocal fspath (Path.makeGlobal path) in
(* Archive update must be done first *)
Update.updateProps fspath localPath propOpt ui;
if fileUpdated ui then
@@ -193,16 +239,26 @@ let setProp rootFrom pathFrom rootTo pathTo newDesc oldDesc uiFrom uiTo =
(Props.toString newDesc)
(root2string rootTo) (Path.toString pathTo)
(Props.toString oldDesc));
+ Copy.readPropsExtDataG rootFrom pathFrom newDesc >>= fun (p, newDesc) ->
setPropOnRoot rootTo (pathTo, uiTo, newDesc, oldDesc) >>= fun _ ->
- updateProps rootFrom pathFrom None uiFrom
+ (match p with
+ | None -> Update.translatePath rootFrom pathFrom
+ | Some path -> Lwt.return path) >>= fun localPathFrom ->
+ updateProps rootFrom localPathFrom None uiFrom
(* ------------------------------------------------------------ *)
+let convV0 = Remote.makeConvV0FunRet
+ (fun (b, desc) -> (b, Props.to_compat251 desc))
+ (fun (b, desc) -> (b, Props.of_compat251 desc))
+
let mkdirOnRoot =
Remote.registerRootCmd
- "mkdir"
+ "mkdir" ~convV0
+ Umarshal.(prod2 Fspath.m Path.mlocal id id)
+ Umarshal.(prod2 bool Props.mbasic id id)
(fun (fspath,(workingDir,path)) ->
- let info = Fileinfo.get false workingDir path in
+ let info = Fileinfo.getBasic false workingDir path in
if info.Fileinfo.typ = `DIRECTORY then begin
begin try
(* Make sure the directory is writable *)
@@ -213,13 +269,23 @@ let mkdirOnRoot =
end else begin
if info.Fileinfo.typ <> `ABSENT then
Os.delete workingDir path;
- Os.createDir workingDir path Props.dirDefault;
- Lwt.return (false, (Fileinfo.get false workingDir path).Fileinfo.desc)
+ Os.createDir workingDir path (Props.perms Props.dirDefault);
+ Lwt.return (false, (Fileinfo.getBasic false workingDir path).desc)
end)
+let convV0 = Remote.makeConvV0FunArg
+ (fun (fspath, (workingDir, path, initialDesc, newDesc)) ->
+ (fspath, (workingDir, path,
+ Props.to_compat251 initialDesc, Props.to_compat251 newDesc)))
+ (fun (fspath, (workingDir, path, initialDesc, newDesc)) ->
+ (fspath, (workingDir, path,
+ Props.of_compat251 initialDesc, Props.of_compat251 newDesc)))
+
let setDirPropOnRoot =
Remote.registerRootCmd
- "setDirProp"
+ "setDirProp" ~convV0
+ Umarshal.(prod4 Fspath.m Path.mlocal Props.mbasic Props.mx id id)
+ Umarshal.unit
(fun (_, (workingDir, path, initialDesc, newDesc)) ->
Fileinfo.set workingDir path (`Set initialDesc) newDesc;
Lwt.return ())
@@ -227,6 +293,8 @@ let setDirPropOnRoot =
let makeSymlink =
Remote.registerRootCmd
"makeSymlink"
+ Umarshal.(prod3 Fspath.m Path.mlocal string id id)
+ Umarshal.unit
(fun (fspath, (workingDir, path, l)) ->
if Os.exists workingDir path then
Os.delete workingDir path;
@@ -248,15 +316,15 @@ let performRename fspathTo localPathTo workingDir pathFrom pathTo prevArch =
(Fspath.toDebugString source) (Fspath.toDebugString target))
(fun () ->
debugverbose (fun() ->
- Util.msg "calling Fileinfo.get from renameLocal\n");
+ Util.msg "calling Fileinfo.getType from renameLocal\n");
let filetypeFrom =
- (Fileinfo.get false source Path.empty).Fileinfo.typ in
+ Fileinfo.getType false source Path.empty in
debugverbose (fun() ->
- Util.msg "back from Fileinfo.get from renameLocal\n");
+ Util.msg "back from Fileinfo.getType from renameLocal\n");
if filetypeFrom = `ABSENT then raise (Util.Transient (Printf.sprintf
"Error while renaming %s to %s -- source file has disappeared!"
(Fspath.toPrintString source) (Fspath.toPrintString target)));
- let filetypeTo = (Fileinfo.get false target Path.empty).Fileinfo.typ in
+ let filetypeTo = Fileinfo.getType false target Path.empty in
(* Windows and Unix operate differently if the target path of a
rename already exists: in Windows an exception is raised, in
@@ -297,7 +365,7 @@ let performRename fspathTo localPathTo workingDir pathFrom pathTo prevArch =
(Fspath.toDebugString target));
Os.rename "renameLocal(2)"
source Path.empty target Path.empty))
- (fun _ -> clearCommitLog pathTo);
+ (fun _ -> clearCommitLog tmpPath);
(* It is ok to leave a temporary file. So, the log can be
cleared before deleting it. *)
Os.delete temp Path.empty
@@ -327,7 +395,7 @@ let performRename fspathTo localPathTo workingDir pathFrom pathTo prevArch =
either locally or on the other side. *)
let renameLocal
(fspathTo,
- (localPathTo, workingDir, pathFrom, pathTo, ui, archOpt, notDefault)) =
+ ((localPathTo, workingDir, pathFrom, pathTo), (ui, archOpt, notDefault))) =
let copyInfo = prepareCopy workingDir pathTo notDefault in
(* Make sure the target is unchanged, then do the rename.
(Note that there is an unavoidable race condition here...) *)
@@ -348,7 +416,33 @@ let renameLocal
end;
Lwt.return ()
-let renameOnHost = Remote.registerRootCmd "rename" renameLocal
+let archOpt_to_compat251 = function
+ | Some arch -> Some (Update.to_compat251 arch)
+ | None -> None
+
+let archOpt_of_compat251 = function
+ | Some arch -> Some (Update.of_compat251 arch)
+ | None -> None
+
+let convV0 = Remote.makeConvV0FunArg
+ (fun (fspathTo,
+ ((localPathTo, workingDir, pathFrom, pathTo), (ui, archOpt, notDefault))) ->
+ (fspathTo,
+ (localPathTo, workingDir, pathFrom, pathTo,
+ Common.ui_to_compat251 ui, archOpt_to_compat251 archOpt, notDefault)))
+ (fun (fspathTo,
+ (localPathTo, workingDir, pathFrom, pathTo, ui, archOpt, notDefault)) ->
+ (fspathTo,
+ ((localPathTo, workingDir, pathFrom, pathTo),
+ (Common.ui_of_compat251 ui, archOpt_of_compat251 archOpt, notDefault))))
+
+let mrename = Umarshal.(prod2
+ (prod4 Path.mlocal Fspath.m Path.mlocal Path.mlocal id id)
+ (prod3 Common.mupdateItem (option Update.marchive) bool id id)
+ id id)
+
+let renameOnHost =
+ Remote.registerRootCmd "rename" ~convV0 mrename Umarshal.unit renameLocal
let rename root localPath workingDir pathOld pathNew ui archOpt notDefault =
debug (fun() ->
@@ -357,7 +451,7 @@ let rename root localPath workingDir pathOld pathNew ui archOpt notDefault =
(Path.toString localPath)
(Path.toString pathOld) (Path.toString pathNew));
renameOnHost root
- (localPath, workingDir, pathOld, pathNew, ui, archOpt, notDefault)
+ ((localPath, workingDir, pathOld, pathNew), (ui, archOpt, notDefault))
(* ------------------------------------------------------------ *)
@@ -383,8 +477,10 @@ let setupTargetPathsLocal (fspath, path) =
let tempPath = Os.tempPath ~fresh:false workingDir realPath in
Lwt.return (workingDir, realPath, tempPath, localPath)
+let msetupTargetPaths = Umarshal.(prod4 Fspath.m Path.mlocal Path.mlocal Path.mlocal id id)
+
let setupTargetPaths =
- Remote.registerRootCmd "setupTargetPaths" setupTargetPathsLocal
+ Remote.registerRootCmd "setupTargetPaths" Path.m msetupTargetPaths setupTargetPathsLocal
let rec createDirectories fspath localPath props =
match props with
@@ -413,10 +509,27 @@ let setupTargetPathsAndCreateParentDirectoryLocal (fspath, (path, props)) =
let tempPath = Os.tempPath ~fresh:false workingDir realPath in
Lwt.return (workingDir, realPath, tempPath, localPath)
+let convV0 = Remote.makeConvV0FunArg
+ (fun (fspath, (path, props)) ->
+ (fspath, (path, Safelist.map Props.to_compat251 props)))
+ (fun (fspath, (path, props)) ->
+ (fspath, (path, Safelist.map Props.of_compat251 props)))
+
let setupTargetPathsAndCreateParentDirectory =
- Remote.registerRootCmd "setupTargetPathsAndCreateParentDirectory"
+ Remote.registerRootCmd "setupTargetPathsAndCreateParentDirectory" ~convV0
+ Umarshal.(prod2 Path.m (list Props.mx) id id)
+ Umarshal.(prod4 Fspath.m Path.mlocal Path.mlocal Path.mlocal id id)
setupTargetPathsAndCreateParentDirectoryLocal
+let rec readParentsExtData rootFrom pathFrom acc = function
+ | [] -> Safelist.rev acc |> Lwt.return
+ | desc :: rem ->
+ match Path.deconstructRev pathFrom with
+ | None -> assert false
+ | Some (_, parentPath) ->
+ Copy.readPropsExtData rootFrom parentPath desc >>= fun desc' ->
+ readParentsExtData rootFrom parentPath (desc' :: acc) rem
+
(* ------------------------------------------------------------ *)
let updateSourceArchiveLocal (fspathFrom, (localPathFrom, uiFrom, errPaths)) =
@@ -435,8 +548,16 @@ let updateSourceArchiveLocal (fspathFrom, (localPathFrom, uiFrom, errPaths)) =
Stasher.stashCurrentVersion fspathFrom localPathFrom None;
Lwt.return ()
+let convV0 = Remote.makeConvV0FunArg
+ (fun (fspathFrom, (localPathFrom, uiFrom, errPaths)) ->
+ (fspathFrom, (localPathFrom, Common.ui_to_compat251 uiFrom, errPaths)))
+ (fun (fspathFrom, (localPathFrom, uiFrom, errPaths)) ->
+ (fspathFrom, (localPathFrom, Common.ui_of_compat251 uiFrom, errPaths)))
+
let updateSourceArchive =
- Remote.registerRootCmd "updateSourceArchive" updateSourceArchiveLocal
+ Remote.registerRootCmd "updateSourceArchive" ~convV0
+ Umarshal.(prod3 Path.mlocal Common.mupdateItem (list Path.mlocal) id id) Umarshal.unit
+ updateSourceArchiveLocal
(* ------------------------------------------------------------ *)
@@ -472,7 +593,7 @@ let deleteSpuriousChildrenLocal (_, (fspathTo, pathTo, archChildren)) =
Lwt.return ()
let deleteSpuriousChildren =
- Remote.registerRootCmd "deleteSpuriousChildren" deleteSpuriousChildrenLocal
+ Remote.registerRootCmd "deleteSpuriousChildren" Umarshal.(prod3 Fspath.m Path.mlocal (list Name.m) id id) Umarshal.unit deleteSpuriousChildrenLocal
let rec normalizeProps propsFrom propsTo =
match propsFrom, propsTo with
@@ -482,7 +603,7 @@ let rec normalizeProps propsFrom propsTo =
(* ------------------------------------------------------------ *)
-let copyReg = Lwt_util.make_region 50
+let copyReg = Remote.lwtRegionWithConnCleanup 50
let copy
update
@@ -503,9 +624,13 @@ let copy
"copy %s %s ---> %s %s \n"
(root2string rootFrom) (Path.toString pathFrom)
(root2string rootTo) (Path.toString pathTo));
+ (* Calculate source path *)
+ Update.translatePath rootFrom pathFrom >>= fun localPathFrom ->
(* Calculate target paths *)
+ normalizeProps propsFrom propsTo
+ |> readParentsExtData rootFrom localPathFrom [] >>= fun parentProps ->
setupTargetPathsAndCreateParentDirectory rootTo
- (pathTo, normalizeProps propsFrom propsTo)
+ (pathTo, parentProps)
>>= fun (workingDir, realPathTo, tempPathTo, localPathTo) ->
(* When in Unicode case-insensitive mode, we want to create files
with NFC normal-form filenames. *)
@@ -520,8 +645,6 @@ let copy
| Some (name, parentPath) ->
Path.child parentPath (Name.normalize name)
in
- (* Calculate source path *)
- Update.translatePath rootFrom pathFrom >>= fun localPathFrom ->
let errors = ref [] in
(* Inner loop for recursive copy... *)
let rec copyRec pFrom (* Path to copy from *)
@@ -538,7 +661,7 @@ let copy
(fun () ->
match f with
Update.ArchiveFile (desc, fp, stamp, ress) ->
- Lwt_util.run_in_region copyReg 1 (fun () ->
+ Lwt_util.run_in_region !copyReg 1 (fun () ->
Abort.check id;
let stmp =
if Update.useFastChecking () then Some stamp else None in
@@ -552,14 +675,14 @@ let copy
fp, Fileinfo.stamp info, ress'),
[]))
| Update.ArchiveSymlink l ->
- Lwt_util.run_in_region copyReg 1 (fun () ->
+ Lwt_util.run_in_region !copyReg 1 (fun () ->
debug (fun() -> Util.msg "Making symlink %s/%s -> %s\n"
(root2string rootTo) (Path.toString pTo) l);
Abort.check id;
makeSymlink rootTo (workingDir, pTo, l) >>= fun () ->
Lwt.return (f, []))
| Update.ArchiveDir (desc, children) ->
- Lwt_util.run_in_region copyReg 1 (fun () ->
+ Lwt_util.run_in_region !copyReg 1 (fun () ->
debug (fun() -> Util.msg "Creating directory %s/%s\n"
(root2string rootTo) (Path.toString pTo));
mkdirOnRoot rootTo (workingDir, pTo))
@@ -597,11 +720,12 @@ let copy
else
Lwt.return ()
end >>= fun () ->
- Lwt_util.run_in_region copyReg 1 (fun () ->
+ Copy.readPropsExtData rootFrom pFrom desc >>= fun desc' ->
+ Lwt_util.run_in_region !copyReg 1 (fun () ->
(* We use the actual file permissions so as to preserve
inherited bits *)
setDirPropOnRoot rootTo
- (workingDir, pTo, initialDesc, desc)) >>= fun () ->
+ (workingDir, pTo, initialDesc, desc')) >>= fun () ->
Lwt.return (Update.ArchiveDir (desc, newChildren),
List.flatten pathl)
| Update.NoArchive ->
@@ -609,10 +733,8 @@ let copy
(fun e ->
match e with
Util.Transient _ ->
- if not (Abort.testException e) then begin
- Abort.file id;
- errors := e :: !errors
- end;
+ if not (Abort.testException e) then Abort.file id;
+ errors := e :: !errors;
Lwt.return (Update.NoArchive, [pFrom])
| _ ->
Lwt.fail e)
@@ -647,7 +769,8 @@ let (>>=) = Lwt.bind
let diffCmd =
Prefs.createString "diff" "diff -u OLDER NEWER"
- "!set command for showing differences between files"
+ ~category:(`Advanced `General)
+ "set command for showing differences between files"
("This preference can be used to control the name and command-line "
^ "arguments of the system "
^ "utility used to generate displays of file differences. The default "
@@ -813,11 +936,11 @@ let formatMergeCmd p f1 f2 backup out1 out2 outarch batchmode =
(Uutil.quotes (Path.toString p)) in
cooked
-let copyBack fspathFrom pathFrom rootTo pathTo propsTo uiTo id =
+let copyBack fspathFrom pathFrom rootTo pathTo propsTo uiTo archTo id =
setupTargetPaths rootTo pathTo
>>= (fun (workingDirForCopy, realPathTo, tempPathTo, localPathTo) ->
- let info = Fileinfo.get false fspathFrom pathFrom in
- let fp = Os.fingerprint fspathFrom pathFrom info in
+ let info = Fileinfo.getBasicWithRess false fspathFrom pathFrom in
+ let fp = Os.fingerprint fspathFrom pathFrom info.Fileinfo.typ in
let stamp = Osx.stamp info.Fileinfo.osX in
let newprops = Props.setLength propsTo (Props.length info.Fileinfo.desc) in
Copy.file
@@ -825,11 +948,13 @@ let copyBack fspathFrom pathFrom rootTo pathTo propsTo uiTo id =
`Copy newprops fp None stamp id >>= fun info ->
debugverbose (fun () -> Util.msg "rename from copyBack\n");
rename rootTo localPathTo workingDirForCopy tempPathTo realPathTo
- uiTo None false)
+ uiTo archTo false)
let keeptempfilesaftermerge =
Prefs.createBool
- "keeptempfilesaftermerge" false "*" ""
+ "keeptempfilesaftermerge" false
+ ~category:(`Internal `Devel)
+ "*" ""
let showStatus = function
| Unix.WEXITED i -> Printf.sprintf "exited (%d)" i
@@ -936,10 +1061,10 @@ let merge root1 path1 ui1 root2 path2 ui2 id showMergeFn =
Os.delete workingDirForMerge new1;
Os.delete workingDirForMerge new2;
Os.delete workingDirForMerge newarch;
- let info1 = Fileinfo.get false workingDirForMerge working1 in
+ let info1 = Fileinfo.getType false workingDirForMerge working1 in
(* FIX: Why split out the parts of the pair? Why is it not abstract anyway??? *)
let fp1 = Os.fingerprint workingDirForMerge working1 info1 in
- let info2 = Fileinfo.get false workingDirForMerge working2 in
+ let info2 = Fileinfo.getType false workingDirForMerge working2 in
let fp2 = Os.fingerprint workingDirForMerge working2 info2 in
let cmd = formatMergeCmd
path1
@@ -989,8 +1114,8 @@ let merge root1 path1 ui1 root2 path2 ui2 id showMergeFn =
say (fun () -> Util.msg "Three outputs detected \n")
else
say (fun () -> Util.msg "Two outputs detected \n");
- let info1 = Fileinfo.get false workingDirForMerge new1 in
- let info2 = Fileinfo.get false workingDirForMerge new2 in
+ let info1 = Fileinfo.getType false workingDirForMerge new1 in
+ let info2 = Fileinfo.getType false workingDirForMerge new2 in
let fp1' = Os.fingerprint workingDirForMerge new1 info1 in
let fp2' = Os.fingerprint workingDirForMerge new2 info2 in
if fp1'=fp2' then begin
@@ -1030,9 +1155,9 @@ let merge root1 path1 ui1 root2 path2 ui2 id showMergeFn =
if working1_still_exists && working2_still_exists then begin
say (fun () -> Util.msg "No output from merge cmd and both original files are still present\n");
- let info1' = Fileinfo.get false workingDirForMerge working1 in
+ let info1' = Fileinfo.getType false workingDirForMerge working1 in
let fp1' = Os.fingerprint workingDirForMerge working1 info1' in
- let info2' = Fileinfo.get false workingDirForMerge working2 in
+ let info2' = Fileinfo.getType false workingDirForMerge working2 in
let fp2' = Os.fingerprint workingDirForMerge working2 info2' in
if fp1 = fp1' && fp2 = fp2' then
raise (Util.Transient "Merge program didn't change either temp file");
@@ -1087,28 +1212,63 @@ let merge root1 path1 ui1 root2 path2 ui2 id showMergeFn =
Lwt_unix.run
(debug (fun () -> Util.msg "Committing results of merge\n");
- copyBack workingDirForMerge working1 root1 path1 desc1 ui1 id >>= (fun () ->
- copyBack workingDirForMerge working2 root2 path2 desc2 ui2 id >>= (fun () ->
+ let (desc1, desc2, archTo) =
let arch_fspath = Fspath.concat workingDirForMerge workingarch in
if Fs.file_exists arch_fspath then begin
debug (fun () -> Util.msg "Updating unison archives for %s to reflect results of merge\n"
(Path.toString path1));
if not (Stasher.shouldBackupCurrent path1) then
Util.msg "Warning: 'backupcurrent' is not set for path %s\n" (Path.toString path1);
- Stasher.stashCurrentVersion workingDirForMerge localPath1 (Some workingarch);
- let infoarch = Fileinfo.get false workingDirForMerge workingarch in
- let fp = Os.fingerprint arch_fspath Path.empty infoarch in
+ let infoarch = Fileinfo.getBasicWithRess false arch_fspath Path.empty in
+ let fp = Os.fingerprint arch_fspath Path.empty infoarch.typ in
debug (fun () -> Util.msg "New fingerprint is %s\n" (Os.fullfingerprint_to_string fp));
+ let pseudoMergeDesc merge_desc =
+ (* Length and times (because the merge result's mtime is set in
+ both replicas) must come from the merge result. The remaining
+ props should be as close as possible to one of the original
+ files to reduce the possibility of props conflicts at the next
+ sync.
+
+ Current props, desc1 and desc2, can't be compared before having
+ same time and length (taken from the merge result). *)
+ let fixup_desc desc n =
+ let desc' = Props.setTime desc n in
+ Props.setLength desc' (Props.length n)
+ in
+ let desc1' = fixup_desc desc1 merge_desc
+ and desc2' = fixup_desc desc2 merge_desc in
+ let pref_desc =
+ if Props.similar desc1' desc2' then Some desc1 else
+ match ui1, ui2 with
+ | Updates (_, Previous (_, pdesc1, _, _)),
+ Updates (_, Previous (_, pdesc2, _, _)) ->
+ if Props.similar pdesc1 desc1 then Some desc1 else
+ if Props.similar pdesc2 desc2 then Some desc2 else
+ if Props.similar pdesc1 pdesc2 then Some pdesc1 else
+ None (* Is it possible to arrive here? *)
+ | NoUpdates, (NoUpdates | Updates _) -> Some desc1
+ | Updates _, NoUpdates -> Some desc2
+ | _ -> None
+ in
+ match pref_desc with
+ | None -> None
+ | Some pref_desc -> Some (fixup_desc pref_desc merge_desc)
+ in
let new_archive_entry =
- Update.ArchiveFile
- (Props.get (Fs.stat arch_fspath) infoarch.osX, fp,
- Fileinfo.stamp (Fileinfo.get true arch_fspath Path.empty),
- Osx.stamp infoarch.osX) in
- Update.replaceArchive root1 path1 new_archive_entry >>= fun _ ->
- Update.replaceArchive root2 path2 new_archive_entry >>= fun _ ->
- Lwt.return ()
+ match pseudoMergeDesc infoarch.desc with
+ | None -> None
+ | Some new_arch_desc ->
+ Some (Update.ArchiveFile (new_arch_desc, fp,
+ Fileinfo.stamp infoarch, Osx.stamp infoarch.osX)) in
+ (Props.setTime desc1 infoarch.Fileinfo.desc,
+ Props.setTime desc2 infoarch.Fileinfo.desc,
+ new_archive_entry)
end else
- (Lwt.return ()) )))) )
+ (desc1, desc2, None)
+ in
+ copyBack workingDirForMerge working1 root1 path1 desc1 ui1 archTo id >>= (fun () ->
+ copyBack workingDirForMerge working2 root2 path2 desc2 ui2 archTo id >>= (fun () ->
+ Lwt.return () )))) )
(fun _ ->
Util.ignoreTransientErrors
(fun () ->
diff --git a/src/files.mli b/src/files.mli
index 836db34..c4c65a5 100644
--- a/src/files.mli
+++ b/src/files.mli
@@ -16,7 +16,7 @@ val delete :
(* Region used for the copying. Exported to be correctly set in transport.ml *)
(* to the maximum number of threads *)
-val copyReg : Lwt_util.region
+val copyReg : Lwt_util.region ref
(* Copy a path in one replica to another path in a second replica. The copy *)
(* is performed atomically (or as close to atomically as the os will *)
@@ -68,7 +68,7 @@ val diff :
val processCommitLogs : unit -> unit
(* List the files in a directory matching a pattern. *)
-val ls : System.fspath -> string -> string list
+val ls : string -> string -> string list
val merge :
Common.root (* first root *)
diff --git a/src/fingerprint.ml b/src/fingerprint.ml
index 00bbc03..9164fae 100644
--- a/src/fingerprint.ml
+++ b/src/fingerprint.ml
@@ -19,6 +19,8 @@
(* INCREMENT "UPDATE.ARCHIVEFORMAT" *)
type t = string
+let m = Umarshal.string
+
let pseudo_prefix = "LEN"
let pseudo path len = pseudo_prefix ^ (Uutil.Filesize.toString len) ^ "@" ^
diff --git a/src/fingerprint.mli b/src/fingerprint.mli
index 8543fec..45bf54a 100644
--- a/src/fingerprint.mli
+++ b/src/fingerprint.mli
@@ -3,6 +3,8 @@
type t
+val m : t Umarshal.t
+
(* Os.safeFingerprint should usually be used rather than these functions *)
val file : Fspath.t -> Path.local -> t
val subfile : Fspath.t -> Int64.t -> Uutil.Filesize.t -> t
diff --git a/src/fpcache.ml b/src/fpcache.ml
index 11ea86c..6f0b6b4 100644
--- a/src/fpcache.ml
+++ b/src/fpcache.ml
@@ -34,6 +34,12 @@ let tbl = PathTbl.create 101
type entry =
int * string * (Props.t * Os.fullfingerprint * Fileinfo.stamp * Osx.ressStamp)
+let mentry = Umarshal.(prod3 int string
+ (prod4 Props.m Os.mfullfingerprint Fileinfo.mstamp Osx.mressStamp id id)
+ id id)
+
+let mentry_list = Umarshal.list mentry
+
type state =
{ oc : out_channel;
mutable count : int;
@@ -74,14 +80,14 @@ let read st ic =
(* I/O errors are dealt with at a higher level *)
let fp1 = Digest.input ic in
let fp2 = Digest.input ic in
- let headerSize = Marshal.header_size in
+ let headerSize = Umarshal.header_size in
let header = Bytes.create headerSize in
really_input ic header 0 headerSize;
if fp1 <> Digest.bytes header then begin
debug (fun () -> Util.msg "bad header checksum\n");
raise End_of_file
end;
- let dataSize = Marshal.data_size header 0 in
+ let dataSize = Umarshal.data_size header 0 in
let s = Bytes.create (headerSize + dataSize) in
Bytes.blit header 0 s 0 headerSize;
really_input ic s headerSize dataSize;
@@ -89,7 +95,13 @@ let read st ic =
debug (fun () -> Util.msg "bad chunk checksum\n");
raise End_of_file
end;
- let q : entry list = Marshal.from_bytes s 0 in
+ let q =
+ try Umarshal.from_bytes mentry_list s 0 with
+ | Umarshal.Error _ ->
+ debug (fun () -> Util.msg ("Umarshal error when reading from file, "
+ ^^ "ignoring and continuing\n"));
+ []
+ in
debug (fun () -> Util.msg "read chunk of %d files\n" (List.length q));
List.iter (fun (l, p, i) -> PathTbl.add tbl (decompress st l p) i) q
@@ -102,8 +114,8 @@ let closeOut st =
let write state =
let q = Safelist.rev state.queue in
- let s = Marshal.to_string q [Marshal.No_sharing] in
- let fp1 = Digest.substring s 0 Marshal.header_size in
+ let s = Umarshal.to_string mentry_list q in
+ let fp1 = Digest.substring s 0 Umarshal.header_size in
let fp2 = Digest.string s in
begin try
Digest.output state.oc fp1; Digest.output state.oc fp2;
@@ -127,7 +139,7 @@ let finish () =
closeOut st
| None -> ()
-let magic = "Unison fingerprint cache format 2"
+let magic = "Unison fingerprint cache format 3"
let init fastCheck ignorearchives fspath =
finish ();
@@ -218,11 +230,10 @@ let dataClearlyUnchanged fastCheck path info desc stamp =
match stamp with
Fileinfo.InodeStamp inode ->
info.Fileinfo.inode = inode
- | Fileinfo.CtimeStamp ctime ->
- (* BCP [Apr 07]: This doesn't work -- ctimes are unreliable
- under windows. :-(
- info.Fileinfo.ctime = ctime *)
+ | Fileinfo.NoStamp ->
true
+ | Fileinfo.RescanStamp ->
+ false
let ressClearlyUnchanged fastCheck info ress dataClearlyUnchanged =
fastCheck
@@ -237,8 +248,9 @@ let clearlyUnchanged fastCheck path newInfo oldDesc oldStamp oldRess =
du && ressClearlyUnchanged fastCheck newInfo oldRess du
let fastercheckUNSAFE =
- Prefs.createBool "fastercheckUNSAFE"
- false "!skip computing fingerprints for new files (experts only!)"
+ Prefs.createBool "fastercheckUNSAFE" false
+ ~category:`Expert
+ "skip computing fingerprints for new files (experts only!)"
( "THIS FEATURE IS STILL EXPERIMENTAL AND SHOULD BE USED WITH EXTREME CAUTION. "
^ "\n\n"
^ "When this flag is set to {\\tt true}, Unison will compute a 'pseudo-"
@@ -290,7 +302,7 @@ let fingerprint ?(newfile=false) fastCheck currfspath path info optFp =
if Prefs.read fastercheckUNSAFE && newfile then begin
debug (fun()-> Util.msg "skipping initial fingerprint of %s\n"
(Fspath.toDebugString (Fspath.concat currfspath path)));
- (Fileinfo.get false currfspath path,
+ (Fileinfo.get ~archProps:info.desc false currfspath path,
Os.pseudoFingerprint path (Props.length info.Fileinfo.desc))
end else begin
Os.safeFingerprint currfspath path info optFp
diff --git a/src/fpcache.mli b/src/fpcache.mli
index 50e7981..884a487 100644
--- a/src/fpcache.mli
+++ b/src/fpcache.mli
@@ -2,7 +2,7 @@
(* Copyright 1999-2020, Benjamin C. Pierce (see COPYING for details) *)
(* Initialize the cache *)
-val init : bool -> bool -> System.fspath -> unit
+val init : bool -> bool -> string -> unit
(* Close the cache file and clear the in-memory cache *)
val finish : unit -> unit
diff --git a/src/fs.ml b/src/fs.ml
index fe2fd19..8a14852 100644
--- a/src/fs.ml
+++ b/src/fs.ml
@@ -15,47 +15,50 @@
along with this program. If not, see <http://www.gnu.org/licenses/>.
*)
-module System = System_impl.Fs
-
type fspath = Fspath.t
+let mfspath = Fspath.m
type dir_handle = System.dir_handle
= { readdir : unit -> string; closedir : unit -> unit }
-let symlink l f = System.symlink l (Fspath.toString f)
+let path p = Fspath.toString p |> System.extendedPath
+
+(****)
+
+let symlink l f = System.symlink l (path f)
-let readlink f = System.readlink (Fspath.toString f)
+let readlink f = System.readlink (path f)
-let chown f usr grp = System.chown (Fspath.toString f) usr grp
+let chown f usr grp = System.chown (path f) usr grp
-let chmod f mode = System.chmod (Fspath.toString f) mode
+let chmod f mode = System.chmod (path f) mode
-let utimes f t1 t2 = System.utimes (Fspath.toString f) t1 t2
+let utimes f t1 t2 = System.utimes (path f) t1 t2
-let unlink f = System.unlink (Fspath.toString f)
+let unlink f = System.unlink (path f)
-let rmdir f = System.rmdir (Fspath.toString f)
+let rmdir f = System.rmdir (path f)
-let mkdir f mode = System.mkdir (Fspath.toString f) mode
+let mkdir f mode = System.mkdir (path f) mode
-let rename f f' = System.rename (Fspath.toString f) (Fspath.toString f')
+let rename f f' = System.rename (path f) (path f')
-let stat f = System.stat (Fspath.toString f)
+let stat f = System.stat (path f)
-let lstat f = System.lstat (Fspath.toString f)
+let lstat f = System.lstat (path f)
-let openfile f flags perms = System.openfile (Fspath.toString f) flags perms
+let openfile f flags perms = System.openfile (path f) flags perms
-let opendir f = System.opendir (Fspath.toString f)
+let opendir f = System.opendir (path f)
let open_in_gen flags mode f =
- System.open_in_gen flags mode (Fspath.toString f)
+ System.open_in_gen flags mode (path f)
let open_out_gen flags mode f =
- System.open_out_gen flags mode (Fspath.toString f)
+ System.open_out_gen flags mode (path f)
(****)
-let open_in_bin f = open_in_gen [Open_rdonly; Open_binary] 0 f
+let open_in_bin f = System.open_in_bin (path f)
let file_exists f =
try
@@ -65,11 +68,24 @@ let file_exists f =
(****)
-let fingerprint f = System.fingerprint (Fspath.toString f)
+exception XattrNotSupported = System.XattrNotSupported
+
+let xattr_list f = System.xattr_list (path f)
+let xattr_get f n = System.xattr_get (path f) n
+let xattr_set f n v = System.xattr_set (path f) n v
+let xattr_remove f n = System.xattr_remove (path f) n
+
+let xattrUpdatesCTime = System.xattrUpdatesCTime
+
+(****)
+
+let acl_get_text f = System.acl_get_text (path f)
+let acl_set_text f acl = System.acl_set_text (path f) acl
+
+(****)
+
+let fingerprint f = System.fingerprint (path f)
-let canSetTime f = System.canSetTime (Fspath.toString f)
let hasInodeNumbers () = System.hasInodeNumbers ()
let hasSymlink () = System.hasSymlink ()
let hasCorrectCTime = System.hasCorrectCTime
-
-let setUnicodeEncoding = System.setUnicodeEncoding
diff --git a/src/fs.mli b/src/fs.mli
index f77da51..2aedc54 100644
--- a/src/fs.mli
+++ b/src/fs.mli
@@ -4,5 +4,3 @@
(* Operations on fspaths *)
include System_intf.Core with type fspath = Fspath.t
-
-val setUnicodeEncoding : bool -> unit
diff --git a/src/fsmonitor.py b/src/fsmonitor.py
index 2def7dd..03ee2be 100644
--- a/src/fsmonitor.py
+++ b/src/fsmonitor.py
@@ -323,7 +323,7 @@ if sys.platform == 'darwin':
#make a list of all files in question (all files in path w/o dirs)
try:
names = os.listdir(path)
- except os.error, msg:
+ except os.error:
#path does not exist (anymore?). Add it to the results
mydebug("adding nonexisting path %s for sync",path)
result.append(path)
@@ -541,7 +541,7 @@ if sys.platform == 'win32':
while 1:
sleep(3600)
except KeyboardInterrupt:
- print "Cleaning up."
+ print("Cleaning up.")
#################################################
# END Windows specific code
@@ -664,7 +664,7 @@ to read all the settings from there."""
while sys.stdin.readline(): pass
os._exit(0)
t = threading.Thread(target=exitThread)
- t.setDaemon(True)
+ t.daemon = True
t.start()
if sys.platform=='darwin':
diff --git a/src/fsmonitor/linux/Makefile b/src/fsmonitor/linux/Makefile
index f6905d8..223d82e 100644
--- a/src/fsmonitor/linux/Makefile
+++ b/src/fsmonitor/linux/Makefile
@@ -20,9 +20,9 @@ endif
buildexecutable:: $(FSMONITOR)$(EXEC_EXT)
-$(FSMONITOR)$(EXEC_EXT): $(COMPATOCAMLOBJS) $(FSMCAMLOBJS) $(FSMCOBJS)
+$(FSMONITOR)$(EXEC_EXT): $(FSMCAMLOBJS) $(FSMCOBJS)
@echo Linking $@
- $(CAMLC) -verbose $(CAMLFLAGS) $(CAMLLDFLAGS) -o $@ $(CFLAGS) $(FSMCAMLLIBS) $^ $(CLIBS)
+ $(CAMLC) -verbose $(CAMLFLAGS) $(CAMLLDFLAGS) -o $@ $(CAMLCFLAGS) $(FSMCAMLLIBS) $^ $(CLIBS)
clean::
rm -f $(DIR)/*.cm[iox] $(DIR)/*.o $(DIR)/*~
diff --git a/src/fsmonitor/linux/dune b/src/fsmonitor/linux/dune
index 5c555c8..c9c6a81 100644
--- a/src/fsmonitor/linux/dune
+++ b/src/fsmonitor/linux/dune
@@ -1,11 +1,17 @@
(copy_files# ../watchercommon.ml{,i})
(library
- (name fswatcher)
+ (name fswatcher_linux)
(wrapped false)
- (enabled_if (= %{system} "linux"))
+ (enabled_if
+ (or
+ (= %{system} "linux")
+ (= %{system} "linux_elf")
+ (= %{system} "elf")
+ (= %{system} "linux_eabihf")
+ (= %{system} "linux_eabi")))
(modules :standard \ watcher)
- (flags :standard -w -3-27-39)
+ (flags :standard -w -3-27)
(foreign_stubs
(language c)
(names inotify_stubs))
@@ -14,7 +20,14 @@
(executable
(name watcher)
(public_name unison-fsmonitor)
- (enabled_if (= %{system} "linux"))
+ (package unison-fsmonitor)
+ (enabled_if
+ (or
+ (= %{system} "linux")
+ (= %{system} "linux_elf")
+ (= %{system} "elf")
+ (= %{system} "linux_eabihf")
+ (= %{system} "linux_eabi")))
(modules watcher)
(flags :standard -w -27)
- (libraries fswatcher))
+ (libraries fswatcher_linux))
diff --git a/src/fsmonitor/linux/inotify.ml b/src/fsmonitor/linux/inotify.ml
index d4371a7..5a19569 100644
--- a/src/fsmonitor/linux/inotify.ml
+++ b/src/fsmonitor/linux/inotify.ml
@@ -14,8 +14,6 @@
* Inotify OCaml binding
*)
-exception Error of string * int
-
type select_event =
| S_Access
| S_Attrib
@@ -115,5 +113,3 @@ let read fd =
done;
List.rev !ret
-
-let _ = Callback.register_exception "inotify.error" (Error ("register_callback", 0))
diff --git a/src/fsmonitor/linux/inotify.mli b/src/fsmonitor/linux/inotify.mli
index b248c9d..da79712 100644
--- a/src/fsmonitor/linux/inotify.mli
+++ b/src/fsmonitor/linux/inotify.mli
@@ -13,8 +13,6 @@
*
* Inotify OCaml binding
*)
-exception Error of string * int
-
type select_event =
| S_Access
| S_Attrib
diff --git a/src/fsmonitor/linux/inotify_stubs.c b/src/fsmonitor/linux/inotify_stubs.c
index 1df1f46..2715793 100644
--- a/src/fsmonitor/linux/inotify_stubs.c
+++ b/src/fsmonitor/linux/inotify_stubs.c
@@ -23,10 +23,13 @@
#include <caml/mlvalues.h>
#include <caml/memory.h>
#include <caml/alloc.h>
-#include <caml/custom.h>
-#include <caml/fail.h>
-#include <caml/signals.h>
-#include <caml/callback.h>
+#include <caml/unixsupport.h>
+#include <caml/version.h>
+
+#if OCAML_VERSION_MAJOR < 5
+#define caml_unix_error unix_error
+#define caml_uerror uerror
+#endif
#ifndef IN_EXCL_UNLINK
#define IN_EXCL_UNLINK 0 /* If not supported, just ignore */
@@ -47,41 +50,30 @@ static int inotify_return_table[] = {
IN_IGNORED, IN_ISDIR, IN_Q_OVERFLOW, IN_UNMOUNT, 0
};
-static void raise_inotify_error(char const *msg)
-{
- static const value *inotify_err = NULL;
- value args[2];
-
- if (!inotify_err)
- inotify_err = caml_named_value("inotify.error");
- args[0] = caml_copy_string(msg);
- args[1] = Val_int(errno);
-
- caml_raise_with_args(*inotify_err, 2, args);
-}
-
-value stub_inotify_init(value unit)
+CAMLprim value stub_inotify_init(value unit)
{
CAMLparam1(unit);
int fd;
fd = inotify_init();
+ if (fd == -1)
+ caml_uerror("inotify_init", Nothing);
CAMLreturn(Val_int(fd));
}
-value stub_inotify_ioctl_fionread(value fd)
+CAMLprim value stub_inotify_ioctl_fionread(value fd)
{
CAMLparam1(fd);
int rc, bytes;
rc = ioctl(Int_val(fd), FIONREAD, &bytes);
if (rc == -1)
- raise_inotify_error("ioctl fionread");
+ caml_uerror("ioctl fionread", Nothing);
CAMLreturn(Val_int(bytes));
}
-value stub_inotify_add_watch(value fd, value path, value mask)
+CAMLprim value stub_inotify_add_watch(value fd, value path, value mask)
{
CAMLparam3(fd, path, mask);
int cv_mask, wd;
@@ -89,28 +81,28 @@ value stub_inotify_add_watch(value fd, value path, value mask)
cv_mask = caml_convert_flag_list(mask, inotify_flag_table);
wd = inotify_add_watch(Int_val(fd), String_val(path), cv_mask);
if (wd < 0)
- raise_inotify_error("add_watch");
+ caml_uerror("inotify_add_watch", Nothing);
CAMLreturn(Val_int(wd));
}
-value stub_inotify_rm_watch(value fd, value wd)
+CAMLprim value stub_inotify_rm_watch(value fd, value wd)
{
CAMLparam2(fd, wd);
int ret;
ret = inotify_rm_watch(Int_val(fd), Int_val(wd));
if (ret == -1)
- raise_inotify_error("rm_watch");
+ caml_uerror("inotify_rm_watch", Nothing);
CAMLreturn(Val_unit);
}
-value stub_inotify_struct_size(void)
+CAMLprim value stub_inotify_struct_size(void)
{
CAMLparam0();
CAMLreturn(Val_int(sizeof(struct inotify_event)));
}
-value stub_inotify_convert(value buf)
+CAMLprim value stub_inotify_convert(value buf)
{
CAMLparam1(buf);
CAMLlocal3(event, l, tmpl);
diff --git a/src/fsmonitor/linux/watcher.ml b/src/fsmonitor/linux/watcher.ml
index f36de3e..40a2c50 100644
--- a/src/fsmonitor/linux/watcher.ml
+++ b/src/fsmonitor/linux/watcher.ml
@@ -185,7 +185,7 @@ let release_watch file =
begin try
Lwt_inotify.rm_watch st id
(* Will fail with EINVAL if the file has been deleted... *)
- with Inotify.Error (_, no) ->
+ with Unix.Unix_error _ ->
()
end;
Hashtbl.remove watcher_by_id id
@@ -214,22 +214,23 @@ let add_watch path file follow =
Hashtbl.replace watcher_by_id id (IntSet.add (get_id file) s);
set_watch file (Some id)
end
- with Inotify.Error (_, no) ->
+ with Unix.Unix_error (errno, _, _) ->
release_watch file;
- match no with
- 2 (* ENOENT *) ->
+ match errno with
+ | ENOENT ->
raise Watchercommon.Already_lost
- | 28 (* ENOSPC *) ->
+ | ENOSPC ->
Watchercommon.error ("cannot add a watcher: system limit reached"
^ " (you can do a web search for \"inotify max_user_watches\""
^ " to understand the reasons and mitigations for this error)")
- | 13 (* EACCES *) | 20 (* ENOTDIR *) | 40 (* ELOOP *) ->
+ | EACCES | ENOTDIR | ELOOP ->
(* These errors should be well handled by Unison (they will
result in errors during update detection *)
()
| _ ->
Watchercommon.error
- (Format.sprintf "unexpected error %d while adding a watcher" no)
+ (Format.sprintf "unexpected error while adding a watcher: %s"
+ (Unix.error_message errno))
end
diff --git a/src/fsmonitor/solaris/Makefile b/src/fsmonitor/solaris/Makefile
index d488e58..ce66420 100644
--- a/src/fsmonitor/solaris/Makefile
+++ b/src/fsmonitor/solaris/Makefile
@@ -19,9 +19,9 @@ endif
buildexecutable:: $(FSMONITOR)$(EXEC_EXT)
-$(FSMONITOR)$(EXEC_EXT): $(COMPATOCAMLOBJS) $(FSMCAMLOBJS) $(FSMCOBJS)
+$(FSMONITOR)$(EXEC_EXT): $(FSMCAMLOBJS) $(FSMCOBJS)
@echo Linking $@
- $(CAMLC) -verbose $(CAMLFLAGS) $(CAMLLDFLAGS) -o $@ $(CFLAGS) $(FSMCAMLLIBS) $^ $(CLIBS)
+ $(CAMLC) -verbose $(CAMLFLAGS) $(CAMLLDFLAGS) -o $@ $(CAMLCFLAGS) $(FSMCAMLLIBS) $^ $(CLIBS)
clean::
rm -f $(DIR)/*.cm[iox] $(DIR)/*.o $(DIR)/*~
diff --git a/src/fsmonitor/solaris/dune b/src/fsmonitor/solaris/dune
new file mode 100644
index 0000000..1f5abf7
--- /dev/null
+++ b/src/fsmonitor/solaris/dune
@@ -0,0 +1,22 @@
+(copy_files# ../watchercommon.ml{,i})
+
+(library
+ (name fswatcher_solaris)
+ (wrapped false)
+ (enabled_if (= %{system} "solaris"))
+ (modules :standard \ watcher)
+ (flags :standard -w -3-27-39)
+ (foreign_stubs
+ (language c)
+ (names fen_stubs))
+ (libraries unix lwt_lib))
+
+(executable
+ (name watcher)
+ (public_name unison-fsmonitor)
+ (package unison-fsmonitor)
+ (enabled_if (= %{system} "solaris"))
+ (modules watcher)
+ (flags :standard -w -27)
+ (libraries fswatcher_solaris))
+
diff --git a/src/fsmonitor/solaris/fen_stubs.c b/src/fsmonitor/solaris/fen_stubs.c
index acac988..b57e924 100644
--- a/src/fsmonitor/solaris/fen_stubs.c
+++ b/src/fsmonitor/solaris/fen_stubs.c
@@ -25,7 +25,18 @@
#include <caml/memory.h>
#include <caml/alloc.h>
#include <caml/unixsupport.h>
+#include <caml/version.h>
+#if OCAML_VERSION_MAJOR < 5
+#define caml_unix_error unix_error
+#define caml_uerror uerror
+#endif
+
+
+/* FILE_TRUNC was added in illumos and may not be present in Solaris */
+#ifndef FILE_TRUNC
+#define FILE_TRUNC 0
+#endif
/* We define the flags here rather than pass in from OCaml code
* because they're constant and it reduces extra processing. */
@@ -33,13 +44,13 @@
#define EV_FLAGS_NOFOLLOW EV_FLAGS_FOLLOW | FILE_NOFOLLOW
-CAMLprim value unsn_port_create()
+CAMLprim value unsn_port_create(value unit)
{
CAMLparam0();
int port = port_create();
if (port == -1) {
- uerror("port_create", Nothing);
+ caml_uerror("port_create", Nothing);
}
CAMLreturn(Val_int(port));
@@ -51,7 +62,7 @@ CAMLprim value unsn_port_close(value v)
int status = close(Int_val(v));
if (status == -1) {
- uerror("port_close", Nothing);
+ caml_uerror("port_close", Nothing);
}
CAMLreturn(Val_unit);
@@ -132,7 +143,7 @@ CAMLprim value unsn_port_associate(value port, value path, value follow, value c
struct event_obj *eo = malloc(sizeof(struct event_obj));
if (eo == NULL) {
- unix_error(ENOMEM, "port_associate", path);
+ caml_unix_error(ENOMEM, "port_associate", path);
}
eo->cookie = Int_val(cookie);
@@ -141,7 +152,7 @@ CAMLprim value unsn_port_associate(value port, value path, value follow, value c
int status = port_associate_aux(Int_val(port), eo, Bool_val(follow));
if (status == -1) {
free_eo(eo);
- uerror("port_associate", path);
+ caml_uerror("port_associate", path);
}
/* Returning a malloc'ed pointer as a value is not fully safe as it's not
@@ -163,7 +174,7 @@ CAMLprim value unsn_port_reassociate(value port, value eo_val, value follow)
struct event_obj *eo = EvObj_val(eo_val);
if (eo == NULL) {
- unix_error(EINVAL, "port_reassociate",
+ caml_unix_error(EINVAL, "port_reassociate",
caml_copy_string("NULL eo; this indicates a BUG!"));
}
@@ -193,13 +204,13 @@ CAMLprim value unsn_port_dissociate(value port, value eo_val)
struct event_obj *eo = EvObj_val(eo_val);
if (eo == NULL) {
- unix_error(EINVAL, "port_dissociate",
+ caml_unix_error(EINVAL, "port_dissociate",
caml_copy_string("NULL eo; this indicates a BUG!"));
}
int status = port_dissociate(Int_val(port), PORT_SOURCE_FILE, (uintptr_t) &(eo->fo));
if (status == -1 && errno != ENOENT) {
- uerror("port_dissociate", caml_copy_string(eo->fo.fo_name));
+ caml_uerror("port_dissociate", caml_copy_string(eo->fo.fo_name));
}
CAMLreturn(Val_unit);
@@ -229,13 +240,13 @@ CAMLprim value unsn_port_get(value port)
pel = malloc(cnt * sizeof(port_event_t));
if (pel == NULL) {
- unix_error(ENOMEM, "port_getn", Nothing);
+ caml_unix_error(ENOMEM, "port_getn", Nothing);
}
status = port_getn(Int_val(port), pel, cnt, &cnt, &timeout);
if (status == -1 && errno != ETIME && errno != EINTR) {
free(pel);
- uerror("port_getn", Nothing);
+ caml_uerror("port_getn", Nothing);
}
for (int j = 0; j < cnt; j++) {
@@ -247,7 +258,7 @@ CAMLprim value unsn_port_get(value port)
if (eo == NULL) {
free(pel);
- unix_error(EINVAL, "portev_user",
+ caml_unix_error(EINVAL, "portev_user",
caml_copy_string("NULL eo; this indicates a BUG!"));
}
diff --git a/src/fsmonitor/watchercommon.ml b/src/fsmonitor/watchercommon.ml
index dc08bc9..732a1f9 100644
--- a/src/fsmonitor/watchercommon.ml
+++ b/src/fsmonitor/watchercommon.ml
@@ -285,7 +285,7 @@ let remove_change dir nm =
let clear_change_table hash =
changes := StringMap.remove hash !changes
-let rec clear_changes hash time =
+let clear_changes hash time =
let rec clear_rec f =
f.changed_children <-
StringMap.filter
diff --git a/src/fsmonitor/windows/Makefile b/src/fsmonitor/windows/Makefile
index 64c56c1..95d28b3 100644
--- a/src/fsmonitor/windows/Makefile
+++ b/src/fsmonitor/windows/Makefile
@@ -3,6 +3,7 @@ FSMONITOR = unison-fsmonitor
DIR=fsmonitor/windows
FSMOCAMLOBJS = \
+ ubase/umarshal.cmo \
ubase/rx.cmo unicode_tables.cmo unicode.cmo \
system/system_generic.cmo system/system_win.cmo \
system/win/system_impl.cmo \
@@ -10,8 +11,10 @@ FSMOCAMLOBJS = \
lwt/win/lwt_win.cmo \
fsmonitor/watchercommon.cmo $(DIR)/watcher.cmo
FSMCOBJS = \
- system/system_win_stubs.o lwt/lwt_unix_stubs.o
-FSMOCAMLLIBS=bigarray.cma unix.cma
+ bytearray_stubs$(OBJ_EXT) \
+ system/system_win_stubs$(OBJ_EXT) lwt/lwt_unix_stubs$(OBJ_EXT) \
+ props_xattr$(OBJ_EXT) props_acl$(OBJ_EXT)
+FSMOCAMLLIBS=unix.cma
ifeq ($(NATIVE), true)
FSMCAMLOBJS=$(subst .cmo,.cmx, $(FSMOCAMLOBJS))
@@ -23,10 +26,10 @@ endif
buildexecutable:: $(FSMONITOR)$(EXEC_EXT)
-$(FSMONITOR)$(EXEC_EXT): $(COMPATOCAMLOBJS) $(FSMCAMLOBJS) $(FSMCOBJS)
+$(FSMONITOR)$(EXEC_EXT): $(FSMCAMLOBJS) $(FSMCOBJS)
@echo Linking $@
- $(CAMLC) -verbose $(CAMLFLAGS) $(CAMLLDFLAGS) -o $@ $(CFLAGS) $(FSMCAMLLIBS) $^ $(CLIBS)
+ $(CAMLC) -verbose $(CAMLFLAGS) $(CAMLLDFLAGS) -o $@ $(CAMLCFLAGS) $(FSMCAMLLIBS) $^ $(CLIBS)
clean::
- rm -f $(DIR)/*.cm[iox] $(DIR)/*.o $(DIR)/*~
+ rm -f $(DIR)/*.cm[iox] $(DIR)/*.{o,obj} $(DIR)/*~
rm -f $(FSMONITOR)$(EXEC_EXT)
diff --git a/src/fsmonitor/windows/watcher.ml b/src/fsmonitor/windows/watcher.ml
index 5416534..928eb0b 100644
--- a/src/fsmonitor/windows/watcher.ml
+++ b/src/fsmonitor/windows/watcher.ml
@@ -80,7 +80,7 @@ let rec follow_win_path_parent root dir path pos =
let get_win_path root dir ((ev_path, act) as ev) =
(* Blindly expand the event path to long names form. If event path
- is not found among the watched patchs then try to find the nearest
+ is not found among the watched paths then try to find the nearest
parent directory and report a modification on it. MSDN states the
following: "If there is both a short and long name for the file,
[Lwt_win.readdirectorychanges] will return one of these names,
@@ -88,7 +88,7 @@ let get_win_path root dir ((ev_path, act) as ev) =
let p = if event_kind ev = `DEL then None else
follow_win_path dir (Lwt_win.longpathname root ev_path) 0 in
match p with
- | Some _ as pathnm -> (pathnm, ev)
+ | Some _ -> (p, ev)
| None ->
(* If path is not found or event is a deletion then look up the
parent directory and report a modification on it. It is not
@@ -110,21 +110,11 @@ let flags =
let watch_root_directory path dir =
let h = Lwt_win.open_directory path in
let path = Lwt_win.longpathname "" path in
- let path =
- if String.sub path 0 4 = "\\\\?\\" then begin
- let n = String.sub path 4 (String.length path - 4) in
- if String.sub n 0 3 = "UNC" then
- "\\" ^ String.sub n 3 (String.length n - 3)
- else
- n
- end else
- path
- in
let rec loop () =
Lwt_win.readdirectorychanges h true flags >>= fun l ->
let time = Unix.gettimeofday () in
List.iter
- (fun ((ev_path, _) as ev) ->
+ (fun ev ->
if !previous_event <> Some ev then begin
previous_event := Some ev;
if !Watchercommon.debug then print_event ev;
diff --git a/src/fspath.ml b/src/fspath.ml
index fde5979..cd81268 100644
--- a/src/fspath.ml
+++ b/src/fspath.ml
@@ -28,28 +28,58 @@
(* All fspaths are absolute *)
(* - *)
-module Fs = System_impl.Fs
-
let debug = Util.debug "fspath"
let debugverbose = Util.debug "fsspath+"
type t = Fspath of string
+let m = Umarshal.(sum1 string (function Fspath a -> a) (function a -> Fspath a))
+
let toString (Fspath f) = f
let toPrintString (Fspath f) = f
let toDebugString (Fspath f) = String.escaped f
-let toSysPath (Fspath f) = System.fspathFromString f
(* Needed to hack around some ocaml/Windows bugs, see comment at stat, below *)
-let winRootRx = Rx.rx "(([a-zA-Z]:)?/|//[^/]+/[^/]+/)"
+let winRootRx = Rx.rx "(([a-zA-Z]:)?/|//[^?/]+/[^/]+/|//[?]/[Uu][Nn][Cc]/[^/]+/[^/]+/)|//[?]/([^Uu][^/]*|[Uu]|[Uu][^Nn][^/]*|[Uu][Nn]|[Uu][Nn][^Cc][^/]*|[Uu][Nn][Cc][^/]+)/"
(* FIX I think we could just check the last character of [d]. *)
let isRootDir d =
(* We assume all path separators are slashes in d *)
d="/" ||
(Util.osType = `Win32 && Rx.match_string winRootRx d)
-let winRootFixRx = Rx.rx "//[^/]+/[^/]+"
+(* Here, backslashes are allowed as path separators in Windows *)
+let isRootDirLocalString d =
+ let d =
+ if Util.osType = `Win32 then Fileutil.backslashes2forwardslashes d else d
+ in
+ isRootDir ((Fileutil.removeTrailingSlashes d) ^ "/")
let winRootFix d =
- if Rx.match_string winRootFixRx d then d^"/" else d
+ if Rx.match_string winRootRx (d ^ "/") then d ^ "/" else d
+let winFNsPrefixRx = Rx.rx "[\\/][\\/][?][\\/][^\\/]+"
+let isInvalidWinPath p =
+ Rx.match_string winFNsPrefixRx p (* Is there a path after the prefix? *)
+let winSafeDirname p =
+ if Util.osType <> `Win32 then
+ Filename.dirname p
+ else
+ (* [Filename.dirname] can't handle Windows paths prefixed with \\?\
+ (Win32 file namespace) if [dirname] goes all the way up to the fs root.
+ Most paths are still processed correctly because they are basically a
+ DOS path prefixed with \\?\ or something similar to \\server\share\
+ paths. Only paths right at the fs root are problematic.
+
+ \\?\C:\ becomes \\? (correct is \\?\C:\)
+ \\?\C:\sub becomes \\?\C (correct is \\?\C:\)
+ \\?\Volume{GUID}\ becomes \\? (correct is \\?\Volume{GUID}\)
+ \\?\Volume{GUID}\sub becomes \\?\Volume{GUID} (correct is \\?\Volume{GUID}\)
+
+ As a workaround, first remove the \\?\ prefix and the first component of
+ the path (usually this would be the "volume", except for UNC paths).
+ Then add the removed prefix back to the result of [dirname]. *)
+ match Rx.match_prefix winFNsPrefixRx p 0 with
+ | None -> Filename.dirname p
+ | Some pos ->
+ String.sub p 0 pos ^
+ Filename.dirname (String.sub p pos (String.length p - pos))
(* [differentSuffix: fspath -> fspath -> (string * string)] returns the *)
(* least distinguishing suffixes of two fspaths, for displaying in the user *)
@@ -232,12 +262,12 @@ let canonizeFspath p0 =
let p = match p0 with None -> "." | Some "" -> "." | Some s -> s in
let p' =
begin
- let original = Fs.getcwd() in
+ let original = System.getcwd () in
try
let newp =
- (Fs.chdir p; (* This might raise Sys_error *)
- Fs.getcwd()) in
- Fs.chdir original;
+ System.chdir p; (* This might raise Sys_error *)
+ System.getcwd () in
+ System.chdir original;
newp
with
Sys_error why ->
@@ -251,18 +281,19 @@ let canonizeFspath p0 =
(* fails, we just quit. This works nicely for most cases of (1), *)
(* it works for (2), and on (3) it may leave a mess for someone *)
(* else to pick up. *)
- let p = if Util.osType = `Win32 then Fileutil.backslashes2forwardslashes p else p in
- if isRootDir p then raise
+ if isRootDirLocalString p || isInvalidWinPath p then raise
(Util.Fatal (Printf.sprintf
- "Cannot find canonical name of root directory %s\n(%s)" p why));
- let parent = Filename.dirname p in
+ "Cannot find canonical name of root directory %s\n(%s)%s" p why
+ (if isInvalidWinPath p then "\nMaybe you need to add a "
+ ^ "backslash at end of the root path?" else "")));
+ let parent = winSafeDirname p in
let parent' = begin
- (try Fs.chdir parent with
+ (try System.chdir parent with
Sys_error why2 -> raise (Util.Fatal (Printf.sprintf
- "Cannot find canonical name of %s: unable to cd either to it\
+ "Cannot find canonical name of %s: unable to cd either to it \
(%s)\nor to its parent %s\n(%s)" p why parent why2)));
- Fs.getcwd() end in
- Fs.chdir original;
+ System.getcwd () end in
+ System.chdir original;
let bn = Filename.basename p in
if bn="" then parent'
else toString(child (localString2fspath parent')
@@ -302,28 +333,62 @@ let findWorkingDir fspath path =
(Util.Transient (Printf.sprintf
"Too many symbolic links from %s" abspath));
try
- let link = Fs.readlink p in
+ (* Relevant on Windows: We can (and should) use [extendedPath] only
+ on the very first input, which is known to satisfy [Fspath.t]
+ invariants. Inputs used for all following loops come from the output
+ of [readlink] either without any processing done on it (if the link
+ is an absolute path) - such paths are potentially unsuitable as
+ input to [extendedPath] - or already extended (when concatenating
+ a relative path). *)
+ let link = System.readlink (if n = 0 then System.extendedPath p else p) in
let linkabs =
if Filename.is_relative link then
- Fs.fspathConcat (Fs.fspathDirname p) link
+ (* FIXME? On Windows, this concatenation will potentially create
+ an invalid path if [link] contains components like "." and "..".
+ These components will not be processed by Windows if [p] has
+ prefix \\?\ or //?/ or if the resulting path is later used as
+ input to a syscall via [Fs] module (then the said prefix could be
+ added automatically).
+ https://docs.microsoft.com/en-us/windows/win32/fileio/naming-a-file#win32-file-namespaces
+
+ The solution is perhaps to replace the entire [followlinks]
+ function with realpath(3) on POSIX platforms. The respective
+ function in Windows seems to be GetFinalPathNameByHandle, which
+ is available since Windows Vista.
+ [Unix.realpath] first appeared in OCaml 4.13.
+
+ However, realpath(3) does not have exactly the same semantics as
+ the current [followlinks] function. [followlinks] will go as far
+ as it can and gives the last successful intermediary path as the
+ result when an error happens. realpath(3) will give you all or
+ nothing.
+
+ [chdir] hack from [canonizeFspath] above seems to be the current
+ best compromise. *)
+ Filename.concat (winSafeDirname p) link
+ |> fun l ->
+ if Util.osType = `Win32 then
+ let Fspath l' = canonizeFspath (Some l) in
+ System.extendedPath l'
+ else l
else link in
followlinks (n+1) linkabs
with
- Unix.Unix_error _ -> p in
+ | Unix.Unix_error _ | Util.Fatal _ -> p
+ in
followlinks 0 abspath in
- if isRootDir realpath then
+ if isRootDirLocalString realpath then
raise (Util.Transient(Printf.sprintf
"The path %s is a root directory" abspath));
- let realpath = Fileutil.removeTrailingSlashes realpath in
let p = Filename.basename realpath in
debug
(fun() ->
Util.msg "Os.findWorkingDir(%s,%s) = (%s,%s)\n"
(toString fspath)
(Path.toString path)
- (Filename.dirname realpath)
+ (winSafeDirname realpath)
p);
- (localString2fspath (Filename.dirname realpath), Path.fromString p)
+ (localString2fspath (winSafeDirname realpath), Path.fromString p)
let quotes (Fspath f) = Uutil.quotes f
let compare (Fspath f1) (Fspath f2) = compare f1 f2
diff --git a/src/fspath.mli b/src/fspath.mli
index 73f760d..74eba10 100644
--- a/src/fspath.mli
+++ b/src/fspath.mli
@@ -5,6 +5,8 @@
type t
+val m : t Umarshal.t
+
val child : t -> Name.t -> t
val concat : t -> Path.local -> t
@@ -12,7 +14,6 @@ val canonize : string option -> t
val toString : t -> string
val toPrintString : t -> string
val toDebugString : t -> string
-val toSysPath : t -> System.fspath
(* If fspath+path refers to a (followed) symlink, then return the directory *)
(* of the symlink's target; otherwise return the parent dir of path. If *)
diff --git a/src/fswatch.ml b/src/fswatch.ml
index 3bcca5e..0841244 100644
--- a/src/fswatch.ml
+++ b/src/fswatch.ml
@@ -64,7 +64,7 @@ Protocol description
only further changes.
Unison can wait for changes in a replica by emitting a 'WAIT hash'
- command. It can watch several replicas by sending a serie of these
+ command. It can watch several replicas by sending a series of these
commands. The child process is expected to respond once, by a
'CHANGE hash1 ... hash2' response that lists the changed replicas
among those included in a 'WAIT' command, when changes are
@@ -172,7 +172,8 @@ end
let useWatcher =
Prefs.createBool "watch" false
- "!when set, use a file watcher process to detect changes"
+ ~category:(`Advanced `General)
+ "when set, use a file watcher process to detect changes"
"Unison uses a file watcher process, when available, to detect filesystem \
changes; this is used to speed up update detection. Setting this flag to \
false disables the use of this process."
@@ -221,26 +222,24 @@ let read_line i =
(****)
let path =
- List.map System.fspathFromString
- (try
+ try
Str.split (Str.regexp (if Util.osType = `Win32 then ";" else ":"))
(Sys.getenv "PATH")
with Not_found ->
- [])
+ []
let search_in_path ?(path = path) name =
- System.fspathConcat
+ Filename.concat
(List.find (fun dir ->
- let p = System.fspathConcat dir name in
+ let p = Filename.concat dir name in
let found = System.file_exists p in
- debug (fun () -> Util.msg "'%s' ...%s\n"
- (System.fspathToString p)
+ debug (fun () -> Util.msg "'%s' ...%s\n" p
(match found with true -> "found" | false -> "not found"));
found)
path)
name
-let exec_path = [System.fspathFromString Sys.executable_name]
+let exec_path = [Sys.executable_name]
(*
try
(* Linux *)
@@ -258,13 +257,12 @@ let exec_path = [System.fspathFromString Sys.executable_name]
[System.fspathConcat (System.getcwd ()) name]
*)
-let exec_dir = List.map System.fspathDirname exec_path
+let exec_dir = List.map Filename.dirname exec_path
let watcher =
lazy
(let suffix = if Util.osType = `Win32 then ".exe" else "" in
debug (fun () -> Util.msg "File monitoring helper program...\n");
- System.fspathToString
(try
search_in_path ~path:(exec_dir @ path)
("unison-fsmonitor-" ^ Uutil.myMajorVersion ^ suffix)
@@ -276,6 +274,7 @@ type 'a exn_option = Value of 'a | Exn of exn | Nothing
type conn =
{ output : Lwt_unix.file_descr;
+ pid : int;
has_changes : Cond.t;
has_line : Cond.t;
line_read : Cond.t;
@@ -295,6 +294,9 @@ let rec reader conn read_line =
reader conn read_line
end
+let safeTerm pid =
+ try ignore (Terminal.safe_waitpid pid) with Unix.Unix_error _ -> ()
+
let safeClose fd = try Lwt_unix.close fd with Unix.Unix_error _ -> ()
let currentConnection () =
@@ -304,7 +306,7 @@ let currentConnection () =
let closeConnection () =
match !conn with
- Some c -> conn := None; safeClose c.output
+ | Some c -> conn := None; safeClose c.output; safeTerm c.pid
| None -> ()
let connected () = !conn <> None
@@ -312,15 +314,14 @@ let connected () = !conn <> None
let startProcess () =
try
let w = Lazy.force watcher in
- let (i1,o1) = Lwt_unix.pipe_out () in
- let (i2,o2) = Lwt_unix.pipe_in () in
- Lwt_unix.set_close_on_exec i2;
- Lwt_unix.set_close_on_exec o1;
- Util.convertUnixErrorsToFatal "starting filesystem watcher" (fun () ->
- ignore (System.create_process w [|w|] i1 o2 Unix.stderr));
+ let (i1,o1) = Lwt_unix.pipe_out ~cloexec:true () in
+ let (i2,o2) = Lwt_unix.pipe_in ~cloexec:true () in
+ let pid = Util.convertUnixErrorsToFatal "starting filesystem watcher"
+ (fun () -> System.create_process w [|w|] i1 o2 Unix.stderr) in
Unix.close i1; Unix.close o2;
let c =
{ output = o1;
+ pid;
has_changes = Cond.make ();
has_line = Cond.make ();
line_read = Cond.make ();
@@ -443,6 +444,8 @@ let start hash =
true
end
+let running _ = connected ()
+
let wait hash =
let c = currentConnection () in
let res = Cond.wait c.has_changes in
diff --git a/src/fswatch.mli b/src/fswatch.mli
index c56e28e..d635d5c 100644
--- a/src/fswatch.mli
+++ b/src/fswatch.mli
@@ -4,6 +4,7 @@
type archiveHash = string
val start : archiveHash -> bool
+val running : archiveHash -> bool
val startScanning : archiveHash -> Fspath.t -> Path.local -> unit
val stopScanning : unit -> unit
diff --git a/src/fswatchold.ml b/src/fswatchold.ml
index 008fddc..8491207 100644
--- a/src/fswatchold.ml
+++ b/src/fswatchold.ml
@@ -15,9 +15,6 @@
along with this program. If not, see <http://www.gnu.org/licenses/>.
*)
-(* FIX: we should check that the child process has not died and
- restart it if so... *)
-
(* FIX: the names of the paths being watched should get included
in the name of the watcher's state file *)
@@ -49,8 +46,8 @@ let watchercmd archHash root =
let cmd = Printf.sprintf "python \"%s\" \"%s\" --outfile \"%s\" --statefile \"%s\" %s %s\n"
fsmonfile
root
- (System.fspathToPrintString changefile)
- (System.fspathToPrintString statefile)
+ changefile
+ statefile
(String.concat " " follow)
(String.concat " " paths) in
debug (fun() -> Util.msg "watchercmd = %s\n" cmd);
@@ -59,8 +56,9 @@ let watchercmd archHash root =
module StringSet= Set.Make (String)
module RootMap = Map.Make (String)
-type watcherinfo = {file: System.fspath;
+type watcherinfo = {file: string;
mutable ch:in_channel option;
+ proc: out_channel;
chars: Buffer.t;
mutable lines: string list}
let watchers : watcherinfo RootMap.t ref = ref RootMap.empty
@@ -106,12 +104,29 @@ let readChanges wi =
(* Wait for change file to be built *)
debug (fun() -> Util.msg
"Waiting for change file %s\n"
- (System.fspathToPrintString wi.file))
+ wi.file)
end
else
(* Watcher running and channel built: go ahead and read *)
readAvailableLinesFromWatcher wi
+let watcherRunning archHash =
+ RootMap.mem archHash !watchers &&
+ let wi = RootMap.find archHash !watchers in
+ match Unix.waitpid [Unix.WNOHANG] (System.process_out_pid wi.proc) with
+ | (0, _) -> true
+ | _ | exception Unix.Unix_error (ECHILD, _, _) ->
+ watchers := RootMap.remove archHash !watchers;
+ begin
+ try ignore (System.close_process_out wi.proc)
+ with Unix.Unix_error _ -> ()
+ end;
+ begin match wi.ch with
+ | Some ch -> close_in_noerr ch
+ | None -> ()
+ end;
+ false
+
let getChanges archHash =
if StringSet.mem archHash !newWatchers then
Fswatch.getChanges archHash
@@ -120,6 +135,7 @@ let getChanges archHash =
readChanges wi;
let res = wi.lines in
wi.lines <- [];
+ ignore (watcherRunning archHash); (* Clean up if necessary *)
List.map Path.fromString (trim_duplicates res)
end
@@ -129,15 +145,15 @@ let start archHash fspath =
else if Fswatch.start archHash then begin
newWatchers := StringSet.add archHash !newWatchers;
true
- end else if not (RootMap.mem archHash !watchers) then begin
+ end else if not (watcherRunning archHash) then begin
(* Watcher process not running *)
match watchercmd archHash (Fspath.toString fspath) with
Some (changefile,cmd) ->
debug (fun() -> Util.msg
"Starting watcher on fspath %s\n"
(Fspath.toDebugString fspath));
- let _ = System.open_process_out cmd in
- let wi = {file = changefile; ch = None;
+ let proc = System.open_process_out cmd in
+ let wi = {file = changefile; ch = None; proc;
lines = []; chars = Buffer.create 80} in
watchers := RootMap.add archHash wi !watchers;
true
@@ -149,11 +165,24 @@ let start archHash fspath =
true
end
+let running archHash =
+ if StringSet.mem archHash !newWatchers then begin
+ if Fswatch.running archHash then true
+ else begin
+ newWatchers := StringSet.remove archHash !newWatchers;
+ false
+ end
+ end else false
+ ||
+ watcherRunning archHash
+
let wait archHash =
if StringSet.mem archHash !newWatchers then
Fswatch.wait archHash
else if not (RootMap.mem archHash !watchers) then
raise (Util.Fatal "No file monitoring helper program found")
+ else if not (watcherRunning archHash) then
+ raise (Util.Fatal "File monitoring helper program not running")
else begin
let wi = RootMap.find archHash !watchers in
let rec loop () =
@@ -161,7 +190,15 @@ let wait archHash =
if wi.lines = [] then begin
debug (fun() -> Util.msg "Sleeping for %d seconds...\n" watchinterval);
Lwt.bind (Lwt_unix.sleep (float watchinterval)) (fun () ->
- loop ())
+ if watcherRunning archHash then
+ loop ()
+ else
+ (* Instead of immediately restarting the watcher, the only sensible
+ thing to do is to do a full scan (which will happen automatically
+ if the update scanner notices that watcher is not running). We
+ don't know if any updates have been missed and can no longer rely
+ on the watcher only. *)
+ Lwt.return ())
end else
Lwt.return ()
in
diff --git a/src/fswatchold.mli b/src/fswatchold.mli
index cb19564..a97aceb 100644
--- a/src/fswatchold.mli
+++ b/src/fswatchold.mli
@@ -1,4 +1,5 @@
val start : string -> Fspath.t -> bool
+val running : string -> bool
val getChanges : string -> Path.t list
val wait : string -> unit Lwt.t
diff --git a/src/globals.ml b/src/globals.ml
index a1a5cfc..f1d9328 100644
--- a/src/globals.ml
+++ b/src/globals.ml
@@ -26,6 +26,7 @@ let debug = Trace.debug "globals"
let rawroots =
Prefs.createStringList "root"
+ ~category:(`Basic `Sync)
"root of a replica (should be used exactly twice)"
("Each use of this preference names the root of one of the replicas "
^ "for Unison to synchronize. Exactly two roots are needed, so normal "
@@ -44,21 +45,36 @@ let setRawRoots l = Prefs.set rawroots (Safelist.rev l)
let rawRoots () = Safelist.rev (Prefs.read rawroots)
+let parsedClrootCache = ref []
+
+let parsedClRawRoots () =
+ let key = Prefs.read rawroots in
+ match List.assq_opt key !parsedClrootCache with
+ | Some x -> x
+ | None -> let x = Safelist.map Clroot.parseRoot (rawRoots ()) in
+ parsedClrootCache := (key, x) :: !parsedClrootCache; x
+
+let wrongNumRootsExn roots =
+ Util.Fatal (Printf.sprintf "Wrong number of roots: \
+ 2 expected, but %d provided (%s)\n(Maybe you specified \
+ roots both on the command line and in the profile?)"
+ (Safelist.length roots)
+ (String.concat ", " roots))
+
let rawRootPair () =
match rawRoots () with
[r1; r2] -> (r1, r2)
- | _ -> assert false
+ | roots -> raise (wrongNumRootsExn roots)
let theroots = ref []
+let uninstallRoots () = theroots := []; parsedClrootCache := []
+
open Lwt
let installRoots termInteract =
+ let () = uninstallRoots () in (* Clear out potential old roots *)
let roots = rawRoots () in
- if Safelist.length roots <> 2 then
- raise (Util.Fatal (Printf.sprintf
- "Wrong number of roots: 2 expected, but %d provided (%s)\n(Maybe you specified roots both on the command line and in the profile?)"
- (Safelist.length roots)
- (String.concat ", " roots) ));
+ if Safelist.length roots <> 2 then raise (wrongNumRootsExn roots);
Safelist.fold_right
(fun r cont ->
Remote.canonizeRoot r (Clroot.parseRoot r) termInteract
@@ -66,16 +82,26 @@ let installRoots termInteract =
cont >>= (fun l ->
return (r' :: l))))
roots (return []) >>= (fun roots' ->
+ let () = match roots' with
+ | [r1; r2] when r1 = r2 ->
+ raise (Util.Fatal (Printf.sprintf
+ ("That's no good, the roots appear to be the same! Here's "
+ ^^ "what I found:\nFirst root: %s\nSecond root: %s")
+ (Common.root2string r1) (Common.root2string r2)))
+ | _ -> ()
+ in
theroots := roots';
- return ())
+ Negotiate.features (Common.sortRoots roots') >>=
+ return)
(* Alternate interface, should replace old interface eventually *)
let installRoots2 () =
debug (fun () -> Util.msg "Installing roots...");
+ let () = uninstallRoots () in (* Clear out potential old roots *)
let roots = rawRoots () in
theroots :=
Safelist.map Remote.canonize ((Safelist.map Clroot.parseRoot) roots);
- theroots := !theroots
+ Lwt.ignore_result (Negotiate.features (Common.sortRoots !theroots) >>= return)
let roots () =
match !theroots with
@@ -129,27 +155,9 @@ let allRootsMapWithWaitingAction f wa =
(rootsInCanonicalOrder ()) >>= (fun l ->
return (Safelist.map snd (reorderCanonicalListToUsersOrder l)))
-let replicaHostnames () =
- Safelist.map
- (function (Local, _) -> ""
- | (Remote h,_) -> h)
- (rootsList())
-
-let allHostsIter f =
- let rec iter l =
- match l with
- [] ->
- return ()
- | root :: rem ->
- f root >>= (fun () ->
- iter rem)
- in
- iter (replicaHostnames ())
-
-let allHostsMap f = Safelist.map f (replicaHostnames())
-
let paths =
Prefs.create "path" []
+ ~category:(`Basic `Sync)
"path to synchronize"
("When no \\verb|path| preference is given, Unison will simply synchronize "
^ "the two entire replicas, beginning from the given pair of roots. "
@@ -160,6 +168,7 @@ let paths =
^ "are not regular expressions.")
(fun oldpaths string -> Safelist.append oldpaths [Path.fromString string])
(fun l -> Safelist.map Path.toString l)
+ Umarshal.(list Path.m)
(* FIX: this does weird things in case-insensitive mode... *)
let globPath lr p =
@@ -194,33 +203,36 @@ let expandWildcardPaths() =
(*****************************************************************************)
let propagatePrefsTo =
- Remote.registerHostCmd
- "installPrefs"
- (fun prefs -> return (Prefs.load prefs))
+ Remote.registerRootCmdWithConnection
+ "installPrefs" Prefs.mdumpedPrefs Umarshal.unit
+ (fun conn prefs -> return (Prefs.load prefs (Remote.connectionVersion conn)))
let propagatePrefs () =
- let prefs = Prefs.dump() in
- let toHost root =
- match root with
- (Local, _) -> return ()
- | (Remote host,_) ->
- propagatePrefsTo host prefs
+ let toRoot = function
+ | (Local, _) -> return ()
+ | (Remote _, _) as root ->
+ let rpcVer = Remote.(connectionVersion (connectionOfRoot root)) in
+ let prefs = Prefs.dump rpcVer in
+ propagatePrefsTo root root prefs
in
- allRootsIter toHost
+ allRootsIter toRoot
(*****************************************************************************)
(* PREFERENCES AND PREDICATES *)
(*****************************************************************************)
let batch =
- Prefs.createBool "batch" false "batch mode: ask no questions at all"
+ Prefs.createBool "batch" false
+ ~category:(`Basic `Syncprocess)
+ "batch mode: ask no questions at all"
("When this is set to {\\tt true}, the user "
^ "interface will ask no questions at all. Non-conflicting changes "
^ "will be propagated; conflicts will be skipped.")
let confirmBigDeletes =
Prefs.createBool "confirmbigdel" true
- "!ask about whole-replica (or path) deletes"
+ ~category:(`Advanced `Syncprocess)
+ "ask about whole-replica (or path) deletes"
("When this is set to {\\tt true}, Unison will request an extra confirmation if it appears "
^ "that the entire replica has been deleted, before propagating the change. If the {\\tt batch} "
^ "flag is also set, synchronization will be aborted. When the {\\tt path} preference is used, "
@@ -231,6 +243,7 @@ let () = Prefs.alias confirmBigDeletes "confirmbigdeletes"
let ignorePred =
Pred.create "ignore"
+ ~category:(`Basic `Sync)
("Including the preference \\texttt{-ignore \\ARG{pathspec}} causes Unison to "
^ "completely ignore paths that match \\ARG{pathspec} (as well as their "
^ "children). This is useful for avoiding synchronizing temporary "
@@ -241,6 +254,7 @@ let ignorePred =
let ignorenotPred =
Pred.create "ignorenot"
+ ~category:(`Basic `Sync)
("This preference overrides the preference \\texttt{ignore}.
It gives a list of patterns
(in the same format as
@@ -259,7 +273,9 @@ let ignorenotPred =
synchronized will not work. Instead, you should use the {\\tt path}
preference to choose particular paths to synchronize.")
-let atomic = Pred.create "atomic" ~advanced:true
+let atomic = Pred.create "atomic"
+ ~category:(`Advanced `Sync)
+ ~local:true
("This preference specifies paths for directories whose "
^ "contents will be considered as a group rather than individually when "
^ "they are both modified. "
@@ -276,7 +292,8 @@ let addRegexpToIgnore re =
Pred.intern ignorePred newRE
let merge =
- Pred.create "merge" ~advanced:true
+ Pred.create "merge"
+ ~category:(`Advanced `Sync)
("This preference can be used to run a merge program which will create "
^ "a new version for each of the files and the backup, "
^ "with the last backup and both replicas. "
@@ -290,19 +307,25 @@ let shouldMerge p = Pred.test merge (Path.toString p)
let mergeCmdForPath p = Pred.assoc merge (Path.toString p)
let someHostIsRunningWindows =
- Prefs.createBool "someHostIsRunningWindows" false "*" ""
+ Prefs.createBool "someHostIsRunningWindows" false
+ ~category:(`Internal `Pseudo)
+ "*" ""
let allHostsAreRunningWindows =
- Prefs.createBool "allHostsAreRunningWindows" false "*" ""
+ Prefs.createBool "allHostsAreRunningWindows" false
+ ~category:(`Internal `Pseudo)
+ "*" ""
let fatFilesystem =
- Prefs.createBool "fat" ~local:true false
+ Prefs.createBool "fat" false
+ ~category:(`Advanced `Syncprocess)
+ ~local:true
"use appropriate options for FAT filesystems"
("When this is set to {\\tt true}, Unison will use appropriate options \
to synchronize efficiently and without error a replica located on a \
FAT filesystem on a non-Windows machine: \
do not synchronize permissions ({\\tt perms = 0}); \
- never use chmod ({\tt dontchmod = true}); \
+ never use chmod ({\\tt dontchmod = true}); \
treat filenames as case insensitive ({\\tt ignorecase = true}); \
do not attempt to synchronize symbolic links ({\\tt links = false}); \
ignore inode number changes when detecting updates \
diff --git a/src/globals.mli b/src/globals.mli
index 440f12d..ba22673 100644
--- a/src/globals.mli
+++ b/src/globals.mli
@@ -10,12 +10,18 @@ val rawRoots : unit -> string list
val setRawRoots : string list -> unit
val rawRootPair : unit -> string * string
+(* Same as [rawRoots], parsed as clroots *)
+val parsedClRawRoots : unit -> Clroot.clroot list
+
(* Parse and canonize roots from their raw names *)
-val installRoots : (string -> string -> string) option -> unit Lwt.t
+val installRoots : (string -> Terminal.termInteract) option -> unit Lwt.t
(* An alternate method (under development?) *)
val installRoots2 : unit -> unit
+(* Clear previously installed roots; typically used when switching profiles *)
+val uninstallRoots : unit -> unit
+
(* The roots of the synchronization (with names canonized, but in the same *)
(* order as the user gave them) *)
val roots : unit -> Common.root * Common.root
@@ -55,12 +61,6 @@ val paths : Path.t list Prefs.t
(* Expand any paths ending with * *)
val expandWildcardPaths : unit -> unit
-(* Run a command on all hosts in roots *)
-val allHostsIter : (string -> unit Lwt.t) -> unit Lwt.t
-
-(* Run a command on all hosts in roots and collect results *)
-val allHostsMap : (string -> 'a) -> 'a list
-
(* Make sure that the server has the same settings for its preferences as we
do locally. Should be called whenever the local preferences have
changed. (This isn't conceptually a part of this module, but it can't
diff --git a/src/hash_compat.c b/src/hash_compat.c
index 34221d1..152bb46 100644
--- a/src/hash_compat.c
+++ b/src/hash_compat.c
@@ -1,7 +1,10 @@
/* The pre-OCaml 4.00 hash implementation */
/* FIXME: This is included for backwards compatibility only and must be
- * REMVOED at next Unison version increase. The removal of this will
- * break Unison version compatibility. */
+ * REMOVED when a new hash function included in a stable release has been
+ * available for a few years. The removal of this function will break
+ * Unison version compatibility. There must be plenty of time given
+ * for users to upgrade (most users don't compile themselves and are at
+ * mercy of whatever package repositories they use). */
/* Code copied from OCaml sources */
/**************************************************************************/
@@ -19,17 +22,8 @@
/* */
/**************************************************************************/
-#define CAML_NAME_SPACE
#include <caml/mlvalues.h>
#include <caml/custom.h>
-#ifndef Bytes_val /* Hack to know that we are on OCaml < 4.06.
- #include <caml/version.h> is not always found, for some reason. */
-extern value caml_hash_univ_param(value count, value limit, value obj);
-CAMLprim value unsn_hash_univ_param(value count, value limit, value obj)
-{
- return caml_hash_univ_param(count, limit, obj);
-}
-#else
#include <caml/address_class.h>
struct hash_state {
@@ -169,4 +163,3 @@ static void hash_aux(struct hash_state* h, value obj)
break;
}
}
-#endif
diff --git a/src/linkgtk2.ml b/src/linkgtk3.ml
similarity index 88%
rename from src/linkgtk2.ml
rename to src/linkgtk3.ml
index ddc889d..c527ae4 100644
--- a/src/linkgtk2.ml
+++ b/src/linkgtk3.ml
@@ -1,4 +1,4 @@
-(* Unison file synchronizer: src/linkgtk2.ml *)
+(* Unison file synchronizer: src/linkgtk3.ml *)
(* Copyright 1999-2020, Benjamin C. Pierce
This program is free software: you can redistribute it and/or modify
@@ -16,4 +16,4 @@
*)
-module TopLevel = Main.Body(Uigtk2.Body)
+module TopLevel = Main.Body(Uigtk3.Body)
diff --git a/src/lock.ml b/src/lock.ml
index 99c8e14..5c22e33 100644
--- a/src/lock.ml
+++ b/src/lock.ml
@@ -33,7 +33,7 @@ let create name mode =
false
let rec unique name i mode =
- let nm = System.fspathAddSuffixToFinalName name (string_of_int i) in
+ let nm = name ^ (string_of_int i) in
if create nm mode then nm else
(* highly unlikely *)
unique name (i + 1) mode
diff --git a/src/lock.mli b/src/lock.mli
index 2006e65..4f9ee40 100644
--- a/src/lock.mli
+++ b/src/lock.mli
@@ -4,6 +4,6 @@
(* A simple utility module for setting and releasing inter-process locks
using entries in the filesystem. *)
-val acquire : System.fspath -> bool
-val release : System.fspath -> unit
-val is_locked : System.fspath -> bool
+val acquire : string -> bool
+val release : string -> unit
+val is_locked : string -> bool
diff --git a/src/lwt/META b/src/lwt/META
deleted file mode 100644
index 9b6acde..0000000
--- a/src/lwt/META
+++ /dev/null
@@ -1,4 +0,0 @@
-requires = "unix"
-version = "0.1"
-archive(byte) = "lwt.cma"
-archive(native) = "lwt.cmxa"
diff --git a/src/lwt/Makefile b/src/lwt/Makefile
deleted file mode 100644
index 3cee865..0000000
--- a/src/lwt/Makefile
+++ /dev/null
@@ -1,55 +0,0 @@
-
-NAME = lwt
-
-OCAMLC = ocamlfind ocamlc -g
-OCAMLOPT = ocamlfind ocamlopt
-OCAMLDEP = ocamldep
-
-OBJECTS = pqueue.cmo lwt.cmo lwt_util.cmo lwt_unix.cmo
-XOBJECTS = $(OBJECTS:cmo=cmx)
-
-ARCHIVE = $(NAME).cma
-XARCHIVE = $(NAME).cmxa
-
-REQUIRES =
-PREDICATES =
-
-all: $(ARCHIVE)
-opt: $(XARCHIVE)
-
-$(ARCHIVE): $(OBJECTS)
- $(OCAMLC) -a -o $(ARCHIVE) -package "$(REQUIRES)" -linkpkg \
- -predicates "$(PREDICATES)" $(OBJECTS)
-$(XARCHIVE): $(XOBJECTS)
- $(OCAMLOPT) -a -o $(XARCHIVE) -package "$(REQUIRES)" -linkpkg \
- -predicates "$(PREDICATES)" $(XOBJECTS)
-
-.SUFFIXES: .cmo .cmi .cmx .ml .mli
-
-.ml.cmo:
- $(OCAMLC) -package "$(REQUIRES)" -predicates "$(PREDICATES)" \
- -c $<
-.mli.cmi:
- $(OCAMLC) -package "$(REQUIRES)" -predicates "$(PREDICATES)" \
- -c $<
-.ml.cmx:
- $(OCAMLOPT) -package "$(REQUIRES)" -predicates "$(PREDICATES)" \
- -c $<
-
-depend: *.ml *.mli
- $(OCAMLDEP) *.ml *.mli > depend
-include depend
-
-install: all
- { test ! -f $(XARCHIVE) || extra="$(XARCHIVE) "`basename $(XARCHIVE) .cmxa`.a; }; \
- ocamlfind install $(NAME) *.mli *.cmi $(ARCHIVE) META $$extra
-
-uninstall:
- ocamlfind remove $(NAME)
-
-clean::
- $(RM) -f *.cmi *.cmo *.cmx *.cma *.cmxa *.a *.o *~ *.bak
- $(RM) -f win/*.cm[ioxa] win/*.cmxa win/*.a win/*.o win/*~ win/*.bak
-
-clean::
- cd example && $(MAKE) clean
diff --git a/src/lwt/depend b/src/lwt/depend
deleted file mode 100644
index cf0dfde..0000000
--- a/src/lwt/depend
+++ /dev/null
@@ -1,12 +0,0 @@
-lwt.cmo : lwt.cmi
-lwt.cmx : lwt.cmi
-lwt.cmi :
-lwt_unix.cmo : lwt_unix.cmi
-lwt_unix.cmx : lwt_unix.cmi
-lwt_unix.cmi : lwt.cmi
-lwt_util.cmo : lwt.cmi lwt_util.cmi
-lwt_util.cmx : lwt.cmx lwt_util.cmi
-lwt_util.cmi : lwt.cmi
-pqueue.cmo : pqueue.cmi
-pqueue.cmx : pqueue.cmi
-pqueue.cmi :
diff --git a/src/lwt/example/Makefile b/src/lwt/example/Makefile
deleted file mode 100644
index 766efa5..0000000
--- a/src/lwt/example/Makefile
+++ /dev/null
@@ -1,12 +0,0 @@
-all: relay start_editor
-
-OCAMLC = ocamlfind ocamlc
-
-relay: relay.ml
- $(OCAMLC) -o relay -linkpkg -package lwt relay.ml -cclib -s
-
-start_editor : editor.ml
- $(OCAMLC) -o start_editor -linkpkg -package lwt editor.ml -cclib -s
-
-clean:
- rm -f *.cmi *.cmo *~ relay start_editor
diff --git a/src/lwt/example/editor.ml b/src/lwt/example/editor.ml
deleted file mode 100644
index 0995528..0000000
--- a/src/lwt/example/editor.ml
+++ /dev/null
@@ -1,3 +0,0 @@
-let _ =
- let editor = try Sys.getenv "EDITOR" with Not_found -> "emacs" in
- Lwt_unix.run (Lwt_unix.system editor)
diff --git a/src/lwt/example/relay.ml b/src/lwt/example/relay.ml
deleted file mode 100644
index 9cdd337..0000000
--- a/src/lwt/example/relay.ml
+++ /dev/null
@@ -1,55 +0,0 @@
-
-(* Usage: relay <listening_port> <dest_port> *)
-
-(* This program waits for a connection on <listening_port>. It then
- connect to <dest_port> and relay everything it receives in either
- side to the other side. It exists when either side closes the
- connection. *)
-
-let listening_port = int_of_string Sys.argv.(1)
-let dest_port = int_of_string Sys.argv.(2)
-
-open Lwt
-
-let rec really_write out_ch buffer pos len =
- Lwt_unix.write out_ch buffer pos len >>= (fun len' ->
- if len = len' then return () else
- really_write out_ch buffer (pos + len') (len - len'))
-
-let relay in_ch out_ch =
- let rec relay_rec previous_write =
- let buffer = Bytes.create 8192 in
- (* Read some data from the input socket *)
- Lwt_unix.read in_ch buffer 0 8192 >>= (fun len ->
- (* If we read nothing, this means that the connection has been
- closed. In this case, we stop relaying. *)
- if len = 0 then return () else begin
- (* Otherwise, we write the data to the ouput socket *)
- let write =
- (* First wait for the previous write to terminate *)
- previous_write >>= (fun () ->
- (* Then write the contents of the buffer *)
- really_write out_ch buffer 0 len)
- in
- relay_rec write
- end)
- in
- relay_rec (return ())
-
-let new_socket () = Lwt_unix.socket Unix.PF_INET Unix.SOCK_STREAM 0
-let local_addr num = Unix.ADDR_INET (Unix.inet_addr_any, num)
-
-let _ =
- Lwt_unix.run
- ((* Initialize the listening address *)
- new_socket () >>= (fun listening_socket ->
- Unix.setsockopt listening_socket Unix.SO_REUSEADDR true;
- Unix.bind listening_socket (local_addr listening_port);
- Unix.listen listening_socket 1;
- (* Wait for a connection *)
- Lwt_unix.accept listening_socket >>= (fun (inp, _) ->
- (* Connect to the destination port *)
- new_socket () >>= (fun out ->
- Lwt_unix.connect out (local_addr dest_port) >>= (fun () ->
- (* Start relaying *)
- Lwt.choose [relay inp out; relay out inp])))))
diff --git a/src/lwt/generic/lwt_unix_impl.ml b/src/lwt/generic/lwt_unix_impl.ml
index 238ce04..9ebf761 100644
--- a/src/lwt/generic/lwt_unix_impl.ml
+++ b/src/lwt/generic/lwt_unix_impl.ml
@@ -1,6 +1,6 @@
(*
Non-blocking I/O and select does not (fully) work under Windows.
-The libray therefore does not use them under Windows, and will
+The library therefore does not use them under Windows, and will
therefore have the following limitations:
- No read will be performed while there are some threads ready to run
or waiting to write;
@@ -14,9 +14,6 @@ therefore have the following limitations:
- [connect] is blocking
*)
let windows_hack = Sys.os_type <> "Unix"
-let recent_ocaml =
- Scanf.sscanf Sys.ocaml_version "%d.%d"
- (fun maj min -> (maj = 3 && min >= 11) || maj > 3)
module SleepQueue =
Pqueue.Make (struct
@@ -63,12 +60,6 @@ let of_unix_file_descr fd = if not windows_hack then Unix.set_nonblock fd; fd
let inputs = ref []
let outputs = ref []
-let wait_children = ref []
-
-let child_exited = ref false
-let _ =
- if not windows_hack then
- ignore(Sys.signal Sys.sigchld (Sys.Signal_handle (fun _ -> child_exited := true)))
let bad_fd fd =
try ignore (Unix.LargeFile.fstat fd); false with
@@ -82,9 +73,6 @@ let wrap_syscall queue fd cont syscall =
with
Exit
| Unix.Unix_error ((Unix.EAGAIN | Unix.EWOULDBLOCK | Unix.EINTR), _, _) ->
- (* EINTR because we are catching SIG_CHLD hence the system call
- might be interrupted to handle the signal; this lets us restart
- the system call eventually. *)
None
| e ->
queue := List.remove_assoc fd !queue;
@@ -119,12 +107,7 @@ let rec run thread =
let infds = List.map fst !inputs in
let outfds = List.map fst !outputs in
let (readers, writers, _) =
- if windows_hack && not recent_ocaml then
- let writers = outfds in
- let readers =
- if delay = 0. || writers <> [] then [] else infds in
- (readers, writers, [])
- else if infds = [] && outfds = [] && delay = 0. then
+ if infds = [] && outfds = [] && delay = 0. then
([], [], [])
else
try
@@ -138,11 +121,6 @@ let rec run thread =
([], [], [])
| Unix.Unix_error (Unix.EBADF, _, _) ->
(List.filter bad_fd infds, List.filter bad_fd outfds, [])
- | Unix.Unix_error (Unix.EPIPE, _, _)
- when windows_hack && recent_ocaml ->
- (* Workaround for a bug in Ocaml 3.11: select fails with an
- EPIPE error when the file descriptor is remotely closed *)
- (infds, [], [])
in
restart_threads !event_counter now;
List.iter
@@ -155,7 +133,7 @@ let rec run thread =
| `Accept res ->
wrap_syscall inputs fd res
(fun () ->
- let (s, _) as v = Unix.accept fd in
+ let (s, _) as v = Unix.accept ~cloexec:true fd in
if not windows_hack then Unix.set_nonblock s;
v)
| `Wait res ->
@@ -184,17 +162,6 @@ let rec run thread =
with Not_found ->
())
writers;
- if !child_exited then begin
- child_exited := false;
- List.iter
- (fun (id, (res, flags, pid)) ->
- wrap_syscall wait_children id res
- (fun () ->
- let (pid', _) as v = Unix.waitpid flags pid in
- if pid' = 0 then raise Exit;
- v))
- !wait_children
- end;
run thread
(****)
@@ -223,8 +190,7 @@ let read ch buf pos len =
let write ch buf pos len =
try
- if windows_hack && recent_ocaml then
- raise (Unix.Unix_error (Unix.EAGAIN, "", ""));
+ if windows_hack then raise (Unix.Unix_error (Unix.EAGAIN, "", ""));
Lwt.return (Unix.write ch buf pos len)
with
Unix.Unix_error ((Unix.EAGAIN | Unix.EWOULDBLOCK), _, _) ->
@@ -236,8 +202,7 @@ let write ch buf pos len =
let write_substring ch buf pos len =
try
- if windows_hack && recent_ocaml then
- raise (Unix.Unix_error (Unix.EAGAIN, "", ""));
+ if windows_hack then raise (Unix.Unix_error (Unix.EAGAIN, "", ""));
Lwt.return (Unix.write_substring ch buf pos len)
with
Unix.Unix_error ((Unix.EAGAIN | Unix.EWOULDBLOCK), _, _) ->
@@ -247,30 +212,20 @@ let write_substring ch buf pos len =
| e ->
Lwt.fail e
-(*
-let pipe () =
- let (in_fd, out_fd) as fd_pair = Unix.pipe() in
- if not windows_hack then begin
- Unix.set_nonblock in_fd;
- Unix.set_nonblock out_fd
- end;
- fd_pair
-*)
-
-let pipe_in () =
- let (in_fd, out_fd) as fd_pair = Unix.pipe() in
+let pipe_in ?cloexec () =
+ let (in_fd, out_fd) as fd_pair = Unix.pipe ?cloexec () in
if not windows_hack then
Unix.set_nonblock in_fd;
fd_pair
-let pipe_out () =
- let (in_fd, out_fd) as fd_pair = Unix.pipe() in
+let pipe_out ?cloexec () =
+ let (in_fd, out_fd) as fd_pair = Unix.pipe ?cloexec () in
if not windows_hack then
Unix.set_nonblock out_fd;
fd_pair
-let socket dom typ proto =
- let s = Unix.socket dom typ proto in
+let socket ?cloexec dom typ proto =
+ let s = Unix.socket ?cloexec dom typ proto in
if not windows_hack then Unix.set_nonblock s;
s
@@ -308,35 +263,6 @@ let connect s addr =
| e ->
Lwt.fail e
-let ids = ref 0
-let new_id () = incr ids; !ids
-
-let _waitpid flags pid =
- try
- Lwt.return (Unix.waitpid flags pid)
- with e ->
- Lwt.fail e
-
-let waitpid flags pid =
- if List.mem Unix.WNOHANG flags || windows_hack then
- _waitpid flags pid
- else
- let flags = Unix.WNOHANG :: flags in
- Lwt.bind (_waitpid flags pid) (fun ((pid', _) as res) ->
- if pid' <> 0 then
- Lwt.return res
- else
- let res = Lwt.wait () in
- wait_children := (new_id (), (res, flags, pid)) :: !wait_children;
- res)
-
-let wait () = waitpid [] (-1)
-
-let system cmd =
- match Unix.fork () with
- 0 -> Unix.execv "/bin/sh" [| "/bin/sh"; "-c"; cmd |]
- | id -> Lwt.bind (waitpid [] id) (fun (pid, status) -> Lwt.return status)
-
(****)
type lwt_in_channel = in_channel
@@ -361,31 +287,6 @@ let rec input_char ic =
| e ->
Lwt.fail e
-let stdlib_input = input
-let rec input ic s ofs len =
- try
- Lwt.return (stdlib_input ic s ofs len)
- with
- Sys_blocked_io ->
- Lwt.bind (wait_inchan ic) (fun () -> input ic s ofs len)
- | e ->
- Lwt.fail e
-
-let rec unsafe_really_input ic s ofs len =
- if len <= 0 then
- Lwt.return ()
- else begin
- Lwt.bind (input ic s ofs len) (fun r ->
- if r = 0
- then Lwt.fail End_of_file
- else unsafe_really_input ic s (ofs+r) (len-r))
- end
-
-let really_input ic s ofs len =
- if ofs < 0 || len < 0 || ofs > Bytes.length s - len
- then Lwt.fail (Invalid_argument "really_input")
- else unsafe_really_input ic s ofs len
-
let input_line ic =
let buf = ref (Bytes.create 128) in
let pos = ref 0 in
@@ -416,113 +317,3 @@ let input_line ic =
let res = Bytes.create !pos in
Bytes.blit !buf 0 res 0 !pos;
Lwt.return (Bytes.to_string res))
-
-(****)
-
-type popen_process =
- Process of in_channel * out_channel
- | Process_in of in_channel
- | Process_out of out_channel
- | Process_full of in_channel * out_channel * in_channel
-
-let popen_processes = (Hashtbl.create 7 : (popen_process, int) Hashtbl.t)
-
-let open_proc cmd proc input output toclose =
- match Unix.fork () with
- 0 -> if input <> Unix.stdin then begin
- Unix.dup2 input Unix.stdin;
- Unix.close input
- end;
- if output <> Unix.stdout then begin
- Unix.dup2 output Unix.stdout;
- Unix.close output
- end;
- List.iter Unix.close toclose;
- Unix.execv "/bin/sh" [| "/bin/sh"; "-c"; cmd |]
- | id -> Hashtbl.add popen_processes proc id
-
-let open_process_in cmd =
- let (in_read, in_write) = pipe_in () in
- let inchan = Unix.in_channel_of_descr in_read in
- open_proc cmd (Process_in inchan) Unix.stdin in_write [in_read];
- Unix.close in_write;
- Lwt.return inchan
-
-let open_process_out cmd =
- let (out_read, out_write) = pipe_out () in
- let outchan = Unix.out_channel_of_descr out_write in
- open_proc cmd (Process_out outchan) out_read Unix.stdout [out_write];
- Unix.close out_read;
- Lwt.return outchan
-
-let open_process cmd =
- let (in_read, in_write) = pipe_in () in
- let (out_read, out_write) = pipe_out () in
- let inchan = Unix.in_channel_of_descr in_read in
- let outchan = Unix.out_channel_of_descr out_write in
- open_proc cmd (Process(inchan, outchan)) out_read in_write
- [in_read; out_write];
- Unix.close out_read;
- Unix.close in_write;
- Lwt.return (inchan, outchan)
-
-(* FIX: Subprocesses that use /dev/tty to print things on the terminal
- will NOT have this output captured and returned to the caller of this
- function. There's an argument that this is correct, but if we are
- running from a GUI the user may not be looking at any terminal and it
- will appear that the process is just hanging. This can be fixed, in
- principle, by writing a little C code that opens /dev/tty and then uses
- the TIOCNOTTY ioctl control to detach the terminal. *)
-
-let open_proc_full cmd env proc input output error toclose =
- match Unix.fork () with
- 0 -> Unix.dup2 input Unix.stdin; Unix.close input;
- Unix.dup2 output Unix.stdout; Unix.close output;
- Unix.dup2 error Unix.stderr; Unix.close error;
- List.iter Unix.close toclose;
- Unix.execve "/bin/sh" [| "/bin/sh"; "-c"; cmd |] env
- | id -> Hashtbl.add popen_processes proc id
-
-let open_process_full cmd env =
- let (in_read, in_write) = pipe_in () in
- let (out_read, out_write) = pipe_out () in
- let (err_read, err_write) = pipe_in () in
- let inchan = Unix.in_channel_of_descr in_read in
- let outchan = Unix.out_channel_of_descr out_write in
- let errchan = Unix.in_channel_of_descr err_read in
- open_proc_full cmd env (Process_full(inchan, outchan, errchan))
- out_read in_write err_write [in_write; out_read; err_read];
- Unix.close out_read;
- Unix.close in_write;
- Unix.close err_write;
- Lwt.return (inchan, outchan, errchan)
-
-let find_proc_id fun_name proc =
- try
- let pid = Hashtbl.find popen_processes proc in
- Hashtbl.remove popen_processes proc;
- pid
- with Not_found ->
- raise (Unix.Unix_error (Unix.EBADF, fun_name, ""))
-
-let close_process_in inchan =
- let pid = find_proc_id "close_process_in" (Process_in inchan) in
- close_in inchan;
- Lwt.bind (waitpid [] pid) (fun (_, status) -> Lwt.return status)
-
-let close_process_out outchan =
- let pid = find_proc_id "close_process_out" (Process_out outchan) in
- close_out outchan;
- Lwt.bind (waitpid [] pid) (fun (_, status) -> Lwt.return status)
-
-let close_process (inchan, outchan) =
- let pid = find_proc_id "close_process" (Process(inchan, outchan)) in
- close_in inchan; close_out outchan;
- Lwt.bind (waitpid [] pid) (fun (_, status) -> Lwt.return status)
-
-let close_process_full (outchan, inchan, errchan) =
- let pid =
- find_proc_id "close_process_full"
- (Process_full(outchan, inchan, errchan)) in
- close_out inchan; close_in outchan; close_in errchan;
- Lwt.bind (waitpid [] pid) (fun (_, status) -> Lwt.return status)
diff --git a/src/lwt/lwt.ml b/src/lwt/lwt.ml
index aa84933..a273702 100644
--- a/src/lwt/lwt.ml
+++ b/src/lwt/lwt.ml
@@ -53,20 +53,6 @@ let rec connect t t' =
end
end
-(* similar to [connect t t']; does nothing instead of raising exception when
- * [t] is not asleep
- *)
-let rec try_connect t t' =
- if t.state <> Sleep then
- ()
- else if t'.state = Sleep then
- add_waiter t' (fun () -> try_connect t t')
- else begin
- t.state <- t'.state;
- List.iter (fun f -> f ()) t.waiters;
- t.waiters <- []
- end
-
(* apply function, reifying explicit exceptions into the thread type
* apply: ('a -(exn)-> 'b t) -> ('a -(n)-> 'b t)
* semantically a natural transformation TE -> T, where T is the thread
@@ -155,6 +141,19 @@ let choose l =
nth_ready l (Random.int !ready)
else
let res = wait () in
- (* XXX We may leak memory here, if we repeatedly select the same event *)
- List.iter (fun x -> try_connect res x) l;
+ (* All waiters for this [choose] need to be remembered and cleared
+ out once one of the threads finishes, to not leak memory. *)
+ let waits = ref [] in
+ let choose_done x =
+ List.iter (fun (t, waiter) ->
+ t.waiters <- List.filter (fun f -> f !=(*phys*) waiter) t.waiters)
+ !waits;
+ connect res x
+ in
+ let remember_waiter x =
+ let waiter () = choose_done x in
+ waits := (x, waiter) :: !waits;
+ waiter
+ in
+ List.iter (fun x -> remember_waiter x |> add_waiter x) l;
res
diff --git a/src/lwt/lwt.mli b/src/lwt/lwt.mli
index 9cb84cb..c1f3c7d 100644
--- a/src/lwt/lwt.mli
+++ b/src/lwt/lwt.mli
@@ -41,12 +41,12 @@ val try_bind : (unit -> 'a t) -> ('a -> 'b t) -> (exn -> 'b t) -> 'b t
val choose : 'a t list -> 'a t
(* [choose l] behaves as the first thread in [l] to terminate.
- If several threads are already terminated, one is choosen
+ If several threads are already terminated, one is chosen
at random. *)
val ignore_result : 'a t -> unit
(* [ignore_result t] start the thread [t] and ignores its result
- value if the thread terminates sucessfully. However, if the
+ value if the thread terminates successfully. However, if the
thread [t] fails, the exception is raised instead of being
ignored.
You should use this function if you want to start a thread
diff --git a/src/lwt/lwt_unix.mli b/src/lwt/lwt_unix.mli
index a29a6c8..61860e0 100644
--- a/src/lwt/lwt_unix.mli
+++ b/src/lwt/lwt_unix.mli
@@ -39,10 +39,10 @@ val write : file_descr -> bytes -> int -> int -> int Lwt.t
val write_substring : file_descr -> string -> int -> int -> int Lwt.t
val wait_read : file_descr -> unit Lwt.t
val wait_write : file_descr -> unit Lwt.t
-val pipe_in : unit -> file_descr * Unix.file_descr
-val pipe_out : unit -> Unix.file_descr * file_descr
+val pipe_in : ?cloexec:bool -> unit -> file_descr * Unix.file_descr
+val pipe_out : ?cloexec:bool -> unit -> Unix.file_descr * file_descr
val socket :
- Unix.socket_domain -> Unix.socket_type -> int -> file_descr
+ ?cloexec:bool -> Unix.socket_domain -> Unix.socket_type -> int -> file_descr
val bind : file_descr -> Unix.sockaddr -> unit
val setsockopt : file_descr -> Unix.socket_bool_option -> bool -> unit
val accept : file_descr -> (file_descr * Unix.sockaddr) Lwt.t
diff --git a/src/lwt/lwt_unix_stubs.c b/src/lwt/lwt_unix_stubs.c
index 256d868..081f7d0 100644
--- a/src/lwt/lwt_unix_stubs.c
+++ b/src/lwt/lwt_unix_stubs.c
@@ -9,13 +9,26 @@
#include <caml/fail.h>
#include <caml/bigarray.h>
#include <caml/callback.h>
+#include <caml/unixsupport.h>
+#include <caml/socketaddr.h>
+#include <caml/version.h>
+#if OCAML_VERSION < 41300
+#define CAML_INTERNALS /* was needed from OCaml 4.06 to 4.12 */
+#endif
+#include <caml/osdeps.h>
+
+#if OCAML_VERSION_MAJOR < 5
+#define caml_unix_cloexec_p unix_cloexec_p
+#define caml_unix_error_of_code unix_error_of_code
+#define caml_uerror uerror
+#define caml_win32_maperr win32_maperr
+#define caml_win32_alloc_handle win_alloc_handle
+#define caml_win32_alloc_socket win_alloc_socket
+#endif
//#define D(x) x
#define D(x) while(0){}
-#define UNIX_BUFFER_SIZE 16384
-#define Nothing ((value) 0)
-
typedef struct
{
OVERLAPPED overlapped;
@@ -23,57 +36,36 @@ typedef struct
long action;
} completionData;
-struct filedescr {
- union {
- HANDLE handle;
- SOCKET socket;
- } fd;
- enum { KIND_HANDLE, KIND_SOCKET } kind;
- int crt_fd;
-};
-#define Handle_val(v) (((struct filedescr *) Data_custom_val(v))->fd.handle)
-#define Socket_val(v) (((struct filedescr *) Data_custom_val(v))->fd.socket)
-
-extern void win32_maperr (DWORD errcode);
-extern void uerror (char * cmdname, value arg);
-extern value unix_error_of_code (int errcode);
-extern value win_alloc_handle (HANDLE h);
-extern value win_alloc_socket(SOCKET);
-extern void get_sockaddr (value mladdr,
- struct sockaddr * addr /*out*/,
- int * addr_len /*out*/);
-
-#define Array_data(a, i) (((char *) a->data) + Long_val(i))
+#define Array_data(a, i) (((char *) Caml_ba_data_val(a)) + Long_val(i))
#ifndef Bytes_val
#define Bytes_val(x) ((unsigned char *) Bp_val(x))
#endif
-CAMLprim value ml_blit_string_to_buffer
+CAMLprim value ml_blit_bytes_to_buffer
(value s, value i, value a, value j, value l)
{
- const char *src = String_val(s) + Int_val(i);
- char *dest = Array_data(Bigarray_val(a), j);
+ CAMLparam5(s, i, a, j, l);
+ unsigned char *src = Bytes_val(s) + Long_val(i);
+ char *dest = Array_data(a, j);
memcpy(dest, src, Long_val(l));
- return Val_unit;
+ CAMLreturn(Val_unit);
}
-CAMLprim value ml_blit_bytes_to_buffer
+CAMLprim value ml_blit_string_to_buffer
(value s, value i, value a, value j, value l)
{
- char *src = Bytes_val(s) + Int_val(i);
- char *dest = Array_data(Bigarray_val(a), j);
- memcpy(dest, src, Long_val(l));
- return Val_unit;
+ return ml_blit_bytes_to_buffer(s, i, a, j, l);
}
CAMLprim value ml_blit_buffer_to_bytes
(value a, value i, value s, value j, value l)
{
- char *src = Array_data(Bigarray_val(a), i);
- char *dest = Bytes_val(s) + Long_val(j);
+ CAMLparam5(a, i, s, j, l);
+ char *src = Array_data(a, i);
+ unsigned char *dest = Bytes_val(s) + Long_val(j);
memcpy(dest, src, Long_val(l));
- return Val_unit;
+ CAMLreturn(Val_unit);
}
/****/
@@ -98,10 +90,10 @@ static void invoke_completion_callback
err = Val_long(0);
if (errCode != NO_ERROR) {
len = -1;
- win32_maperr (errCode);
- err = unix_error_of_code(errno);
+ caml_win32_maperr(errCode);
+ err = caml_unix_error_of_code(errno);
}
- name = copy_string (action_name[action]);
+ name = caml_copy_string(action_name[action]);
D(printf("Action %s completed: id %ld -> len %ld / err %d (errCode %ld)\n",
action_name[action], id, len, errno, errCode));
args[0] = Val_long(id);
@@ -110,6 +102,7 @@ static void invoke_completion_callback
args[3] = name;
caml_callbackN(completionCallback, 4, args);
D(printf("Callback performed\n"));
+ CAMLreturn0;
}
typedef struct {
@@ -175,8 +168,8 @@ static HANDLE get_helper_thread (value threads, int kind) {
h = CreateThread (NULL, 0, helper_thread, NULL, 0, NULL);
if (h == NULL) {
- win32_maperr (GetLastError ());
- uerror("createHelperThread", Nothing);
+ caml_win32_maperr(GetLastError());
+ caml_uerror("createHelperThread", Nothing);
}
Field(threads, kind) = (value) h;
return h;
@@ -256,11 +249,10 @@ static VOID CALLBACK perform_io_on_thread(ULONG_PTR param) {
static void thread_io
(long action, long id, value threads, HANDLE h, char * buf, long len) {
- struct caml_bigarray *buf_arr = Bigarray_val(buf);
ioInfo * info = GlobalAlloc(GPTR, sizeof(ioInfo));
if (info == NULL) {
errno = ENOMEM;
- uerror(action_name[action], Nothing);
+ caml_uerror(action_name[action], Nothing);
}
info->action = action;
@@ -289,7 +281,7 @@ static void overlapped_action(long action, long id,
completionData * d = GlobalAlloc(GPTR, sizeof(completionData));
if (d == NULL) {
errno = ENOMEM;
- uerror(action_name[action], Nothing);
+ caml_uerror(action_name[action], Nothing);
}
d->id = id;
d->action = action;
@@ -303,10 +295,10 @@ static void overlapped_action(long action, long id,
if (!res) {
err = GetLastError ();
if (err != ERROR_IO_PENDING) {
- win32_maperr (err);
+ caml_win32_maperr(err);
D(printf("Action %s failed: id %ld -> err %d (errCode %ld)\n",
action_name[action], id, errno, err));
- uerror("ReadFileEx", Nothing);
+ caml_uerror("ReadFileEx", Nothing);
}
}
}
@@ -327,29 +319,27 @@ CAMLprim value win_wrap_overlapped (value fd) {
CAMLprim value win_read
(value fd, value buf, value ofs, value len, value id) {
- CAMLparam4(fd, buf, ofs, len);
- struct caml_bigarray *buf_arr = Bigarray_val(buf);
+ CAMLparam5(fd, buf, ofs, len, id);
if (Field(fd, 1) == Val_long(0))
overlapped_action (READ_OVERLAPPED, Long_val(id), Handle(fd),
- Array_data (buf_arr, ofs), Long_val(len));
+ Array_data(buf, ofs), Long_val(len));
else
thread_io (READ, Long_val(id), Field(fd, 1), Handle(fd),
- Array_data (buf_arr, ofs), Long_val(len));
+ Array_data(buf, ofs), Long_val(len));
CAMLreturn (Val_unit);
}
CAMLprim value win_write
(value fd, value buf, value ofs, value len, value id) {
- CAMLparam4(fd, buf, ofs, len);
- struct caml_bigarray *buf_arr = Bigarray_val(buf);
+ CAMLparam5(fd, buf, ofs, len, id);
if (Field(fd, 1) == Val_long(0))
overlapped_action (WRITE_OVERLAPPED, Long_val(id), Handle(fd),
- Array_data (buf_arr, ofs), Long_val(len));
+ Array_data(buf, ofs), Long_val(len));
else
thread_io (WRITE, Long_val(id), Field(fd, 1), Handle(fd),
- Array_data (buf_arr, ofs), Long_val(len));
+ Array_data(buf, ofs), Long_val(len));
CAMLreturn (Val_unit);
}
@@ -369,46 +359,47 @@ static void after_connect (SOCKET s) {
static HANDLE events[MAXIMUM_WAIT_OBJECTS];
//static OVERLAPPED oData[MAXIMUM_WAIT_OBJECTS];
-CAMLprim value win_register_wait (value socket, value kind, value idx) {
- CAMLparam3(socket, kind, idx);
- long i = Long_val(idx);
+CAMLprim value win_register_wait (value socket, value kind) {
+ CAMLparam2(socket, kind);
+ HANDLE h;
long mask;
- D(printf("Register: i %ld, kind %ld\n", Long_val(i), Long_val(kind)));
- events[i] = CreateEvent(NULL, TRUE, FALSE, NULL);
+ D(printf("Register: %lx, kind %ld\n", (long)(Socket_val(socket)), Long_val(kind)));
+ h = CreateEvent(NULL, TRUE, FALSE, NULL);
mask = (Long_val(kind) == 0) ? FD_CONNECT : FD_ACCEPT;
- if (WSAEventSelect(Socket_val(socket), events[i], mask) == SOCKET_ERROR) {
- win32_maperr(WSAGetLastError ());
- uerror("WSAEventSelect", Nothing);
+ if (WSAEventSelect(Socket_val(socket), h, mask) == SOCKET_ERROR) {
+ caml_win32_maperr(WSAGetLastError());
+ caml_uerror("WSAEventSelect", Nothing);
}
- CAMLreturn (Val_unit);
+ CAMLreturn(caml_win32_alloc_handle(h));
}
-CAMLprim value win_check_connection (value socket, value kind, value idx) {
- CAMLparam3 (socket, kind, idx);
+CAMLprim value win_check_connection (value socket, value kind, value h) {
+ CAMLparam3 (socket, kind, h);
WSANETWORKEVENTS evs;
- int res, err, i = Long_val(idx);
+ int res, err;
- D(printf("Check connection... %d\n", i));
+ D(printf("Check connection... socket = %lx; h = %lx\n",
+ (long)(Socket_val(socket)), Handle_val(h)));
if (WSAEnumNetworkEvents(Socket_val(socket), NULL, &evs)) {
- win32_maperr(WSAGetLastError ());
- uerror("WSAEnumNetworkEvents", Nothing);
+ caml_win32_maperr(WSAGetLastError());
+ caml_uerror("WSAEnumNetworkEvents", Nothing);
}
if (WSAEventSelect(Socket_val(socket), NULL, 0) == SOCKET_ERROR) {
- win32_maperr(WSAGetLastError ());
- uerror("WSAEventSelect", Nothing);
+ caml_win32_maperr(WSAGetLastError());
+ caml_uerror("WSAEventSelect", Nothing);
}
- if (!CloseHandle(events[i])) {
- win32_maperr(GetLastError ());
- uerror("CloseHandle", Nothing);
+ if (!CloseHandle(Handle_val(h))) {
+ caml_win32_maperr(GetLastError());
+ caml_uerror("CloseHandle", Nothing);
}
err =
evs.iErrorCode[(Long_val(kind) == 0) ? FD_CONNECT_BIT : FD_ACCEPT_BIT];
D(printf("Check connection: %ld, err %d\n", evs.lNetworkEvents, err));
if (err != 0) {
- win32_maperr(err);
- uerror("check_connection", Nothing);
+ caml_win32_maperr(err);
+ caml_uerror("check_connection", Nothing);
}
CAMLreturn (Val_unit);
}
@@ -423,7 +414,7 @@ CAMLprim value init_lwt (value callback) {
int i;
D(printf("Init...\n"));
- register_global_root (&completionCallback);
+ caml_register_global_root(&completionCallback);
completionCallback = callback;
dummyEvent = CreateEvent(NULL, TRUE, FALSE, NULL); // Dummy event
@@ -446,14 +437,16 @@ CAMLprim value init_lwt (value callback) {
CAMLreturn (Val_long (MAXIMUM_WAIT_OBJECTS));
}
-CAMLprim value win_wait (value timeout, value event_count) {
- CAMLparam2(timeout, event_count);
+CAMLprim value win_wait (value timeout, value event_list) {
+ CAMLparam2(timeout, event_list);
DWORD t, t2;
DWORD res;
- long ret, n = Long_val(event_count);
+ long ret, n;
t = Long_val(timeout);
if (t < 0) t = INFINITE;
t2 = (compN > 0) ? 0 : t;
+ for (n = 0; event_list != Val_emptylist; event_list = Field(event_list, 1))
+ events[n++] = Handle_val(Field(event_list, 0));
D(printf("Waiting: %ld events, timeout %ldms -> %ldms\n", n, t, t2));
res =
(n > 0) ?
@@ -473,8 +466,8 @@ CAMLprim value win_wait (value timeout, value event_count) {
case WAIT_FAILED:
D(printf("Wait failed\n"));
ret = 0;
- win32_maperr (GetLastError ());
- uerror("WaitForMultipleObjectsEx", Nothing);
+ caml_win32_maperr(GetLastError());
+ caml_uerror("WaitForMultipleObjectsEx", Nothing);
break;
default:
ret = res;
@@ -487,7 +480,7 @@ CAMLprim value win_wait (value timeout, value event_count) {
static long pipeSerial;
-value win_pipe(long readMode, long writeMode) {
+value win_pipe(int cloexec, long readMode, long writeMode) {
CAMLparam0();
SECURITY_ATTRIBUTES attr;
HANDLE readh, writeh;
@@ -496,7 +489,7 @@ value win_pipe(long readMode, long writeMode) {
attr.nLength = sizeof(attr);
attr.lpSecurityDescriptor = NULL;
- attr.bInheritHandle = TRUE;
+ attr.bInheritHandle = cloexec ? FALSE : TRUE;
sprintf(name, "\\\\.\\Pipe\\UnisonAnonPipe.%08lx.%08lx",
GetCurrentProcessId(), pipeSerial++);
@@ -507,8 +500,8 @@ value win_pipe(long readMode, long writeMode) {
1, UNIX_BUFFER_SIZE, UNIX_BUFFER_SIZE, 0, &attr);
if (readh == INVALID_HANDLE_VALUE) {
- win32_maperr(GetLastError());
- uerror("CreateNamedPipe", Nothing);
+ caml_win32_maperr(GetLastError());
+ caml_uerror("CreateNamedPipe", Nothing);
return FALSE;
}
@@ -518,39 +511,39 @@ value win_pipe(long readMode, long writeMode) {
FILE_ATTRIBUTE_NORMAL | writeMode, NULL);
if (writeh == INVALID_HANDLE_VALUE) {
- win32_maperr(GetLastError());
+ caml_win32_maperr(GetLastError());
CloseHandle(readh);
- uerror("CreateFile", Nothing);
+ caml_uerror("CreateFile", Nothing);
return FALSE;
}
- readfd = win_alloc_handle(readh);
- writefd = win_alloc_handle(writeh);
- res = alloc_small(2, 0);
- Store_field(res, 0, readfd);
- Store_field(res, 1, writefd);
+ readfd = caml_win32_alloc_handle(readh);
+ writefd = caml_win32_alloc_handle(writeh);
+ res = caml_alloc_small(2, 0);
+ Field(res, 0) = readfd;
+ Field(res, 1) = writefd;
CAMLreturn (res);
}
-CAMLprim value win_pipe_in (value unit) {
+CAMLprim value win_pipe_in (value cloexec, value unit) {
CAMLparam0();
- CAMLreturn (win_pipe (FILE_FLAG_OVERLAPPED, 0));
+ CAMLreturn (win_pipe (caml_unix_cloexec_p(cloexec), FILE_FLAG_OVERLAPPED, 0));
}
-CAMLprim value win_pipe_out (value unit) {
+CAMLprim value win_pipe_out (value cloexec, value unit) {
CAMLparam0();
- CAMLreturn (win_pipe (0, FILE_FLAG_OVERLAPPED));
+ CAMLreturn (win_pipe (caml_unix_cloexec_p(cloexec), 0, FILE_FLAG_OVERLAPPED));
}
static int socket_domain_table[] = {
- PF_UNIX, PF_INET
+ PF_UNIX, PF_INET, PF_INET6
};
static int socket_type_table[] = {
SOCK_STREAM, SOCK_DGRAM, SOCK_RAW, SOCK_SEQPACKET
};
-CAMLprim value win_socket (value domain, value type, value proto) {
+CAMLprim value win_socket (value cloexec, value domain, value type, value proto) {
CAMLparam3(domain, type, proto);
SOCKET s;
@@ -560,10 +553,13 @@ CAMLprim value win_socket (value domain, value type, value proto) {
NULL, 0, WSA_FLAG_OVERLAPPED);
D(printf("Created socket %lx\n", (long)s));
if (s == INVALID_SOCKET) {
- win32_maperr(WSAGetLastError ());
- uerror("WSASocket", Nothing);
+ caml_win32_maperr(WSAGetLastError());
+ caml_uerror("WSASocket", Nothing);
}
- CAMLreturn(win_alloc_socket(s));
+ /* Ignore errors */
+ SetHandleInformation((HANDLE) s, HANDLE_FLAG_INHERIT,
+ unix_cloexec_p(cloexec) ? 0 : HANDLE_FLAG_INHERIT);
+ CAMLreturn(caml_win32_alloc_socket(s));
}
/*
@@ -623,19 +619,18 @@ static int notify_filter_flags[8] = {
CAMLprim value win_readdirtorychanges
(value fd_val, value buf_val, value recursive, value flags, value id_val) {
CAMLparam5(fd_val, buf_val, recursive, flags, id_val);
- struct caml_bigarray *buf_arr = Bigarray_val(buf_val);
long id = Long_val(id_val);
HANDLE fd = Handle_val(fd_val);
- char * buf = Array_data (buf_arr, 0);
- long len = buf_arr->dim[0];
+ char * buf = Array_data(buf_val, 0);
+ long len = Caml_ba_array_val(buf_val)->dim[0];
long action = READDIRECTORYCHANGES;
BOOL res;
long err;
- int notify_filter = convert_flag_list(flags, notify_filter_flags);
+ int notify_filter = caml_convert_flag_list(flags, notify_filter_flags);
completionData * d = GlobalAlloc(GPTR, sizeof(completionData));
if (d == NULL) {
errno = ENOMEM;
- uerror(action_name[action], Nothing);
+ caml_uerror(action_name[action], Nothing);
}
d->id = id;
d->action = action;
@@ -649,10 +644,10 @@ CAMLprim value win_readdirtorychanges
if (!res) {
err = GetLastError ();
if (err != ERROR_IO_PENDING) {
- win32_maperr (err);
+ caml_win32_maperr(err);
D(printf("Action %s failed: id %ld -> err %d (errCode %ld)\n",
action_name[action], id, errno, err));
- uerror("ReadDirectoryChangesW", Nothing);
+ caml_uerror("ReadDirectoryChangesW", Nothing);
}
}
CAMLreturn (Val_unit);
@@ -661,17 +656,18 @@ CAMLprim value win_readdirtorychanges
CAMLprim value win_parse_directory_changes (value buf_val) {
CAMLparam1(buf_val);
CAMLlocal4(lst, tmp, elt, filename);
- struct caml_bigarray *buf_arr = Bigarray_val(buf_val);
- char * pos = Array_data (buf_arr, 0);
+ char * pos = Array_data(buf_val, 0);
FILE_NOTIFY_INFORMATION * entry;
+ wchar_t *namebuf;
lst = Val_long(0);
while (1) {
entry = (FILE_NOTIFY_INFORMATION *)pos;
+ namebuf = calloc(entry->FileNameLength + 2, 1);
+ memmove(namebuf, entry->FileName, entry->FileNameLength);
elt = caml_alloc_tuple(2);
- filename = caml_alloc_string(entry->FileNameLength);
- memmove((char *)String_val(filename), entry->FileName, entry->FileNameLength);
- Store_field (elt, 0, filename);
+ Store_field (elt, 0, caml_copy_string_of_utf16(namebuf));
+ free(namebuf);
Store_field (elt, 1, Val_long(entry->Action - 1));
tmp = caml_alloc_tuple(2);
Store_field (tmp, 0, elt);
@@ -683,31 +679,34 @@ CAMLprim value win_parse_directory_changes (value buf_val) {
CAMLreturn(lst);
}
-CAMLprim value win_open_directory (value path, value wpath) {
- CAMLparam2 (path, wpath);
+CAMLprim value win_open_directory (value path) {
+ CAMLparam1 (path);
HANDLE h;
- h = CreateFileW((LPCWSTR) String_val(wpath),
+ wchar_t *wpath = caml_stat_strdup_to_utf16(String_val(path));
+
+ h = CreateFileW(wpath,
FILE_LIST_DIRECTORY,
FILE_SHARE_READ | FILE_SHARE_WRITE | FILE_SHARE_DELETE,
NULL,
OPEN_EXISTING,
FILE_FLAG_BACKUP_SEMANTICS | FILE_FLAG_OVERLAPPED,
NULL);
+ caml_stat_free(wpath);
if (h == INVALID_HANDLE_VALUE) {
- win32_maperr (GetLastError ());
- uerror("open", path);
+ caml_win32_maperr(GetLastError());
+ caml_uerror("open", path);
}
- CAMLreturn(win_alloc_handle(h));
+ CAMLreturn(caml_win32_alloc_handle(h));
}
-value copy_wstring(LPCWSTR s);
-
CAMLprim value win_long_path_name(value path) {
CAMLparam1(path);
+ wchar_t *wpath = caml_stat_strdup_to_utf16(String_val(path));
wchar_t lbuf[32768] = L"";
DWORD res;
- res = GetLongPathNameW((LPCWSTR) String_val(path), lbuf, 32768);
+ res = GetLongPathNameW(wpath, lbuf, 32768);
+ caml_stat_free(wpath);
- CAMLreturn(res == 0 || res > 32767 ? path : copy_wstring(lbuf));
+ CAMLreturn(res == 0 || res > 32767 ? path : caml_copy_string_of_utf16(lbuf));
}
diff --git a/src/lwt/lwt_util.ml b/src/lwt/lwt_util.ml
index 3e563a5..cf9b4ef 100644
--- a/src/lwt/lwt_util.ml
+++ b/src/lwt/lwt_util.ml
@@ -61,6 +61,8 @@ let make_region count = { size = count; count = 0; waiters = Queue.create () }
let resize_region reg sz = reg.size <- sz
+let purge_region reg = Queue.clear reg.waiters
+
let leave_region reg sz =
try
if reg.count - sz >= reg.size then raise Queue.Empty;
diff --git a/src/lwt/lwt_util.mli b/src/lwt/lwt_util.mli
index 7dbc435..da0d38a 100644
--- a/src/lwt/lwt_util.mli
+++ b/src/lwt/lwt_util.mli
@@ -43,3 +43,8 @@ val run_in_region : region -> int -> (unit -> 'a Lwt.t) -> 'a Lwt.t
(* [run_in_region reg size f] execute the thread produced by the
function [f] in the region [reg]. The thread is not started
before some room is available in the region. *)
+val purge_region : region -> unit
+ (* [purge_region reg] clear the queue of threads waiting to be
+ executed in the region [reg]. The waiting threads are not
+ woken (neither to execute nor to fail). Threads already being
+ executed in the region are not affected. *)
diff --git a/src/lwt/win/lwt_unix_impl.ml b/src/lwt/win/lwt_unix_impl.ml
index bccd2e2..fa0480f 100644
--- a/src/lwt/win/lwt_unix_impl.ml
+++ b/src/lwt/win/lwt_unix_impl.ml
@@ -84,19 +84,9 @@ external init_lwt :
let max_event_count = init_lwt actionCompleted
-let event_count = ref 0
-let free_list = Array.init max_event_count (fun i -> i)
-
-let acquire_event nm =
- if !event_count = max_event_count then
- raise (Unix.Unix_error (Unix.EAGAIN, nm, ""));
- let i = free_list.(!event_count) in
- incr event_count;
- i
-
-let release_event i =
- decr event_count;
- free_list.(!event_count) <- i
+let acquire_event l nm =
+ if List.length l = max_event_count then
+ raise (Unix.Unix_error (Unix.EAGAIN, nm, ""))
(****)
@@ -158,7 +148,6 @@ module IntTbl =
(struct type t = int let equal (x : int) y = x = y let hash x = x end)
let ioInFlight = IntTbl.create 17
-let connInFlight = IntTbl.create 17
let handleCompletionEvent (id, len, errno, name) =
if !d then Format.eprintf "Handling event %d (len %d)@." id len;
@@ -178,17 +167,21 @@ if !d then Format.eprintf "Handling event %d (len %d)@." id len;
else
Lwt.wakeup res len
+type handle
+
+let connInFlight = ref []
+
type kind = CONNECT | ACCEPT
-external win_wait : int -> int -> int = "win_wait"
+external win_wait : int -> handle list -> int = "win_wait"
external win_register_wait :
- Unix.file_descr -> kind -> int -> unit = "win_register_wait"
+ Unix.file_descr -> kind -> handle = "win_register_wait"
external win_check_connection :
- Unix.file_descr -> kind -> int -> unit = "win_check_connection"
+ Unix.file_descr -> kind -> handle -> unit = "win_check_connection"
-let handle_wait_event i ch kind cont action =
+let handle_wait_event h ch kind cont action =
if !d then prerr_endline "MMM";
let res =
try
@@ -196,20 +189,19 @@ if !d then prerr_endline "MMM";
with
Unix.Unix_error ((Unix.EAGAIN | Unix.EWOULDBLOCK | Unix.EINTR), _, _) ->
if !d then prerr_endline "NNN";
- win_register_wait ch.fd kind i;
+ let h' = win_register_wait ch.fd kind in
+ connInFlight := List.map (fun el -> if fst el <> h then el else (h', snd el)) !connInFlight;
None
| e ->
if !d then prerr_endline "OOO";
- release_event i;
- IntTbl.remove connInFlight i;
+ connInFlight := List.filter (fun (h', _) -> h' <> h) !connInFlight;
Lwt.wakeup_exn cont e;
None
in
match res with
Some v ->
if !d then prerr_endline "PPP";
- release_event i;
- IntTbl.remove connInFlight i;
+ connInFlight := List.filter (fun (h', _) -> h' <> h) !connInFlight;
Lwt.wakeup cont v
| None ->
()
@@ -237,7 +229,7 @@ if !d then Format.eprintf "DONE!@.";
if !d then Format.eprintf "vvv@.";
let i =
try
- win_wait (truncate (ceil (delay *. 1000.))) !event_count
+ win_wait (truncate (ceil (delay *. 1000.))) (List.map fst !connInFlight)
with
Sys.Break as e -> raise e
| _ -> assert false
@@ -250,94 +242,21 @@ if !d then Format.eprintf "threads restarted@.";
completionEvents := [];
List.iter handleCompletionEvent (List.rev ev);
if i >= 0 then begin
- let (kind, ch) =
- try IntTbl.find connInFlight i with Not_found -> assert false in
+ let (h, (kind, ch)) =
+ try List.nth !connInFlight i with Failure _ -> assert false in
match kind with
`CheckSocket res ->
if !d then prerr_endline "CHECK CONN";
- handle_wait_event i ch CONNECT res
- (fun () -> win_check_connection ch.fd CONNECT i)
+ handle_wait_event h ch CONNECT res
+ (fun () -> win_check_connection ch.fd CONNECT h)
| `Accept res ->
if !d then prerr_endline "ACCEPT";
- handle_wait_event i ch ACCEPT res
+ handle_wait_event h ch ACCEPT res
(fun () ->
- win_check_connection ch.fd ACCEPT i;
- let (v, info) = Unix.accept ch.fd in
+ win_check_connection ch.fd ACCEPT h;
+ let (v, info) = Unix.accept ~cloexec:true ch.fd in
(wrap_async v, info))
end;
-(*
- let infds = List.map fst !inputs in
- let outfds = List.map fst !outputs in
- let (readers, writers, _) =
- if windows_hack && not recent_ocaml then
- let writers = outfds in
- let readers =
- if delay = 0. || writers <> [] then [] else infds in
- (readers, writers, [])
- else if infds = [] && outfds = [] && delay = 0. then
- ([], [], [])
- else
- try
- let res = Unix.select infds outfds [] delay in
- if delay > 0. && !now <> -1. then now := !now +. delay;
- res
- with
- Unix.Unix_error (Unix.EINTR, _, _) ->
- ([], [], [])
- | Unix.Unix_error (Unix.EBADF, _, _) ->
- (List.filter bad_fd infds, List.filter bad_fd outfds, [])
- | Unix.Unix_error (Unix.EPIPE, _, _)
- when windows_hack && recent_ocaml ->
- (* Workaround for a bug in Ocaml 3.11: select fails with an
- EPIPE error when the file descriptor is remotely closed *)
- (infds, [], [])
- in
- restart_threads !event_counter now;
- List.iter
- (fun fd ->
- try
- match List.assoc fd !inputs with
- `Read (buf, pos, len, res) ->
- wrap_syscall inputs fd res
- (fun () -> Unix.read fd buf pos len)
- | `Accept res ->
- wrap_syscall inputs fd res
- (fun () ->
- let (s, i) = Unix.accept fd.fd in
- if not windows_hack then Unix.set_nonblock s;
- (wrap_async s, i))
- | `Wait res ->
- wrap_syscall inputs fd res (fun () -> ())
- with Not_found ->
- ())
- readers;
- List.iter
- (fun fd ->
- try
- match List.assoc fd !outputs with
- `Write (buf, pos, len, res) ->
- wrap_syscall outputs fd res
- (fun () -> Unix.write fd buf pos len)
- | `WriteSubstring (buf, pos, len, res) ->
- wrap_syscall outputs fd res
- (fun () -> Unix.write_substring fd buf pos len)
- | `Wait res ->
- wrap_syscall inputs fd res (fun () -> ())
- with Not_found ->
- ())
- writers;
- if !child_exited then begin
- child_exited := false;
- List.iter
- (fun (id, (res, flags, pid)) ->
- wrap_syscall wait_children id res
- (fun () ->
- let (pid', _) as v = Unix.waitpid flags pid in
- if pid' = 0 then raise Exit;
- v))
- !wait_children
- end;
-*)
run thread
(****)
@@ -387,23 +306,24 @@ if !d then Format.eprintf "Writing started@.";
res
external win_pipe_in :
- unit -> Unix.file_descr * Unix.file_descr = "win_pipe_in"
+ ?cloexec:bool -> unit -> Unix.file_descr * Unix.file_descr = "win_pipe_in"
external win_pipe_out :
- unit -> Unix.file_descr * Unix.file_descr = "win_pipe_out"
+ ?cloexec:bool -> unit -> Unix.file_descr * Unix.file_descr = "win_pipe_out"
-let pipe_in () =
- let (i, o) = if no_overlapped_io then Unix.pipe () else win_pipe_in () in
+let pipe_in ?cloexec () =
+ let (i, o) = if no_overlapped_io then Unix.pipe () else win_pipe_in ?cloexec () in
(wrap_async i, o)
-let pipe_out () =
- let (i, o) = if no_overlapped_io then Unix.pipe () else win_pipe_out () in
+let pipe_out ?cloexec () =
+ let (i, o) = if no_overlapped_io then Unix.pipe () else win_pipe_out ?cloexec () in
(i, wrap_async o)
-external win_socket :
+external win_socket : ?cloexec:bool ->
Unix.socket_domain -> Unix.socket_type -> int -> Unix.file_descr =
"win_socket"
-let socket d t p =
- let s = if no_overlapped_io then Unix.socket d t p else win_socket d t p in
+let socket ?cloexec d t p =
+ let s = if no_overlapped_io then Unix.socket ?cloexec d t p
+ else win_socket ?cloexec d t p in
Unix.set_nonblock s;
wrap_async s
@@ -418,16 +338,16 @@ let close ch = Unix.close ch.fd; kill_threads ch
let accept ch =
let res = Lwt.wait () in
- let i = acquire_event "accept" in
- IntTbl.add connInFlight i (`Accept res, ch);
- win_register_wait ch.fd ACCEPT i;
+ let () = acquire_event !connInFlight "accept" in
+ let h = win_register_wait ch.fd ACCEPT in
+ connInFlight := (h, (`Accept res, ch)) :: !connInFlight;
res
let check_socket ch =
let res = Lwt.wait () in
- let i = acquire_event "connect" in
- IntTbl.add connInFlight i (`CheckSocket res, ch);
- win_register_wait ch.fd CONNECT i;
+ let () = acquire_event !connInFlight "connect" in
+ let h = win_register_wait ch.fd CONNECT in
+ connInFlight := (h, (`CheckSocket res, ch)) :: !connInFlight;
res
let connect s addr =
@@ -444,227 +364,6 @@ if !d then prerr_endline "BBB";
if !d then prerr_endline "CCC";
Lwt.fail e
-(*
-let ids = ref 0
-let new_id () = incr ids; !ids
-
-let _waitpid flags pid =
- try
- Lwt.return (Unix.waitpid flags pid)
- with e ->
- Lwt.fail e
-
-let waitpid flags pid =
- if List.mem Unix.WNOHANG flags || windows_hack then
- _waitpid flags pid
- else
- let flags = Unix.WNOHANG :: flags in
- Lwt.bind (_waitpid flags pid) (fun ((pid', _) as res) ->
- if pid' <> 0 then
- Lwt.return res
- else
- let res = Lwt.wait () in
- wait_children := (new_id (), (res, flags, pid)) :: !wait_children;
- res)
-
-let wait () = waitpid [] (-1)
-
-let system cmd =
- match Unix.fork () with
- 0 -> Unix.execv "/bin/sh" [| "/bin/sh"; "-c"; cmd |]
- | id -> Lwt.bind (waitpid [] id) (fun (pid, status) -> Lwt.return status)
-*)
-
-(****)
-(*
-type lwt_in_channel = in_channel
-type lwt_out_channel = out_channel
-
-let intern_in_channel ch =
- Unix.set_nonblock (Unix.descr_of_in_channel ch); ch
-let intern_out_channel ch =
- Unix.set_nonblock (Unix.descr_of_out_channel ch); ch
-
-
-let wait_inchan ic = wait_read (Unix.descr_of_in_channel ic)
-let wait_outchan oc = wait_write (Unix.descr_of_out_channel oc)
-
-let rec input_char ic =
- try
- Lwt.return (Pervasives.input_char ic)
- with
- Sys_blocked_io ->
- Lwt.bind (wait_inchan ic) (fun () -> input_char ic)
- | e ->
- Lwt.fail e
-
-let rec input ic s ofs len =
- try
- Lwt.return (Pervasives.input ic s ofs len)
- with
- Sys_blocked_io ->
- Lwt.bind (wait_inchan ic) (fun () -> input ic s ofs len)
- | e ->
- Lwt.fail e
-
-let rec unsafe_really_input ic s ofs len =
- if len <= 0 then
- Lwt.return ()
- else begin
- Lwt.bind (input ic s ofs len) (fun r ->
- if r = 0
- then Lwt.fail End_of_file
- else unsafe_really_input ic s (ofs+r) (len-r))
- end
-
-let really_input ic s ofs len =
- if ofs < 0 || len < 0 || ofs > Bytes.length s - len
- then Lwt.fail (Invalid_argument "really_input")
- else unsafe_really_input ic s ofs len
-
-let input_line ic =
- let buf = ref (Bytes.create 128) in
- let pos = ref 0 in
- let rec loop () =
- if !pos = Bytes.length !buf then begin
- let newbuf = Bytes.create (2 * !pos) in
- Bytes.blit !buf 0 newbuf 0 !pos;
- buf := newbuf
- end;
- Lwt.bind (input_char ic) (fun c ->
- if c = '\n' then
- Lwt.return ()
- else begin
- Bytes.set !buf !pos c;
- incr pos;
- loop ()
- end)
- in
- Lwt.bind
- (Lwt.catch loop
- (fun e ->
- match e with
- End_of_file when !pos <> 0 ->
- Lwt.return ()
- | _ ->
- Lwt.fail e))
- (fun () ->
- let res = Bytes.create !pos in
- Bytes.blit !buf 0 res 0 !pos;
- Lwt.return (Bytes.to_string res))
-*)
-(****)
-
-(*
-type popen_process =
- Process of in_channel * out_channel
- | Process_in of in_channel
- | Process_out of out_channel
- | Process_full of in_channel * out_channel * in_channel
-
-let popen_processes = (Hashtbl.create 7 : (popen_process, int) Hashtbl.t)
-
-let open_proc cmd proc input output toclose =
- match Unix.fork () with
- 0 -> if input <> Unix.stdin then begin
- Unix.dup2 input Unix.stdin;
- Unix.close input
- end;
- if output <> Unix.stdout then begin
- Unix.dup2 output Unix.stdout;
- Unix.close output
- end;
- List.iter Unix.close toclose;
- Unix.execv "/bin/sh" [| "/bin/sh"; "-c"; cmd |]
- | id -> Hashtbl.add popen_processes proc id
-
-let open_process_in cmd =
- let (in_read, in_write) = pipe_in () in
- let inchan = Unix.in_channel_of_descr in_read in
- open_proc cmd (Process_in inchan) Unix.stdin in_write [in_read];
- Unix.close in_write;
- Lwt.return inchan
-
-let open_process_out cmd =
- let (out_read, out_write) = pipe_out () in
- let outchan = Unix.out_channel_of_descr out_write in
- open_proc cmd (Process_out outchan) out_read Unix.stdout [out_write];
- Unix.close out_read;
- Lwt.return outchan
-
-let open_process cmd =
- let (in_read, in_write) = pipe_in () in
- let (out_read, out_write) = pipe_out () in
- let inchan = Unix.in_channel_of_descr in_read in
- let outchan = Unix.out_channel_of_descr out_write in
- open_proc cmd (Process(inchan, outchan)) out_read in_write
- [in_read; out_write];
- Unix.close out_read;
- Unix.close in_write;
- Lwt.return (inchan, outchan)
-
-(* FIX: Subprocesses that use /dev/tty to print things on the terminal
- will NOT have this output captured and returned to the caller of this
- function. There's an argument that this is correct, but if we are
- running from a GUI the user may not be looking at any terminal and it
- will appear that the process is just hanging. This can be fixed, in
- principle, by writing a little C code that opens /dev/tty and then uses
- the TIOCNOTTY ioctl control to detach the terminal. *)
-
-let open_proc_full cmd env proc input output error toclose =
- match Unix.fork () with
- 0 -> Unix.dup2 input Unix.stdin; Unix.close input;
- Unix.dup2 output Unix.stdout; Unix.close output;
- Unix.dup2 error Unix.stderr; Unix.close error;
- List.iter Unix.close toclose;
- Unix.execve "/bin/sh" [| "/bin/sh"; "-c"; cmd |] env
- | id -> Hashtbl.add popen_processes proc id
-
-let open_process_full cmd env =
- let (in_read, in_write) = pipe_in () in
- let (out_read, out_write) = pipe_out () in
- let (err_read, err_write) = pipe_in () in
- let inchan = Unix.in_channel_of_descr in_read in
- let outchan = Unix.out_channel_of_descr out_write in
- let errchan = Unix.in_channel_of_descr err_read in
- open_proc_full cmd env (Process_full(inchan, outchan, errchan))
- out_read in_write err_write [in_write; out_read; err_read];
- Unix.close out_read;
- Unix.close in_write;
- Unix.close err_write;
- Lwt.return (inchan, outchan, errchan)
-
-let find_proc_id fun_name proc =
- try
- let pid = Hashtbl.find popen_processes proc in
- Hashtbl.remove popen_processes proc;
- pid
- with Not_found ->
- raise (Unix.Unix_error (Unix.EBADF, fun_name, ""))
-*)
-(*
-let close_process_in inchan =
- let pid = find_proc_id "close_process_in" (Process_in inchan) in
- close_in inchan;
- Lwt.bind (waitpid [] pid) (fun (_, status) -> Lwt.return status)
-
-let close_process_out outchan =
- let pid = find_proc_id "close_process_out" (Process_out outchan) in
- close_out outchan;
- Lwt.bind (waitpid [] pid) (fun (_, status) -> Lwt.return status)
-
-let close_process (inchan, outchan) =
- let pid = find_proc_id "close_process" (Process(inchan, outchan)) in
- close_in inchan; close_out outchan;
- Lwt.bind (waitpid [] pid) (fun (_, status) -> Lwt.return status)
-
-let close_process_full (outchan, inchan, errchan) =
- let pid =
- find_proc_id "close_process_full"
- (Process_full(outchan, inchan, errchan)) in
- close_out inchan; close_in outchan; close_in errchan;
- Lwt.bind (waitpid [] pid) (fun (_, status) -> Lwt.return status)
-*)
type lwt_in_channel
let input_line _ = assert false (*XXXXX*)
@@ -674,8 +373,8 @@ let intern_in_channel _ = assert false (*XXXXX*)
type directory_handle = Unix.file_descr
-external open_dir : string -> string -> directory_handle = "win_open_directory"
-let open_directory f = open_dir f (System_impl.Fs.W.epath f)
+external open_dir : string -> directory_handle = "win_open_directory"
+let open_directory f = open_dir (System_win.extendedPath f)
type notify_filter_flag =
FILE_NOTIFY_CHANGE_FILE_NAME | FILE_NOTIFY_CHANGE_DIR_NAME
@@ -707,9 +406,7 @@ if !d then Format.eprintf "Reading started@.";
if len = 0 then
Lwt.return []
else
- Lwt.return (List.rev_map (fun (nm, act) ->
- (System_impl.Fs.W.path8 nm, act))
- (parse_directory_changes buf)))
+ Lwt.return (List.rev (parse_directory_changes buf)))
let close_dir = Unix.close
@@ -718,12 +415,10 @@ external long_name : string -> string = "win_long_path_name"
let longpathname root path =
(* Parameter [path] can be relative. Result value must then also be relative.
Input parameter to [long_name] must always be absolute path. *)
- let epath = System_impl.Fs.W.epath (Filename.concat root path)
- and root = System_impl.Fs.W.epath (Filename.concat root "") in
- let root = String.sub root 0 (String.length root - 2) in (* Remove trailing \000\000 *)
+ let epath = System_win.extendedPath (Filename.concat root path)
+ and root = System_win.extendedPath (Filename.concat root "") in
let start = String.length root
and ln = long_name epath in
- let n =
try
(* The assumption is that [root] does not change in [long_name]. The
Windows fsmonitor operates under this assumption, so it is ok here.
@@ -732,4 +427,3 @@ let longpathname root path =
String.sub ln start (String.length ln - start)
with
| Invalid_argument _ -> ln
- in System_impl.Fs.W.path8 n
diff --git a/src/main.ml b/src/main.ml
index 411bd2e..c48c769 100644
--- a/src/main.ml
+++ b/src/main.ml
@@ -57,13 +57,18 @@
let versionPrefName = "version"
let printVersionAndExit =
- Prefs.createBool versionPrefName false "print version and exit"
+ Prefs.createBool versionPrefName false
+ ~category:(`Basic `General)
+ ~cli_only:true
+ "print version and exit"
("Print the current version number and exit. "
^ "(This option only makes sense on the command line.)")
let docsPrefName = "doc"
let docs =
Prefs.createString docsPrefName ""
+ ~category:(`Basic `General)
+ ~cli_only:true
"show documentation ('-doc topics' lists topics)"
( "The command-line argument \\texttt{-doc \\ARG{secname}} causes unison to "
^ "display section \\ARG{secname} of the manual on the standard output "
@@ -76,34 +81,57 @@ let docs =
let prefsdocsPrefName = "prefsdocs"
let prefsdocs =
Prefs.createBool prefsdocsPrefName false
+ ~category:(`Internal `Devel)
+ ~cli_only:true
"*show full documentation for all preferences (and then exit)"
""
+let prefsmanPrefName = "prefsman"
+let prefsman =
+ Prefs.createString prefsmanPrefName ""
+ ~category:(`Internal `Devel)
+ ~cli_only:true
+ "*show manpage documentation for all preferences (and then exit)"
+ ""
+
let serverPrefName = "server"
let server =
- Prefs.createBool serverPrefName false "*normal or server mode" ""
+ Prefs.createBool serverPrefName false
+ ~category:(`Internal `Other)
+ ~cli_only:true
+ "*normal or server mode" ""
let socketPrefName = "socket"
let socket =
- Prefs.create socketPrefName None
- "!act as a server on a socket" ""
- (fun _ -> fun i ->
- (try
- Some(int_of_string i)
- with Failure _ ->
- raise(Prefs.IllegalValue "-socket must be followed by a number")))
- (function None -> [] | Some(i) -> [string_of_int i]) ;;
-
-let serverHostName = "host"
+ Prefs.createString socketPrefName ""
+ ~category:(`Advanced `Remote)
+ ~cli_only:true
+ "act as a server on a socket"
+ ("Start " ^ Uutil.myName ^ " as a server listening on a TCP socket "
+ ^ "(with TCP port number as argument) or a local socket (aka Unix "
+ ^ "domain socket) (with socket path as argument).")
+
+let serverHostNameAlias = "host"
+let serverHostName = "listen"
let serverHost =
Prefs.createString serverHostName ""
- "!bind the socket to this host name in server socket mode" ""
+ ~category:(`Advanced `Remote)
+ ~cli_only:true
+ "listen on this name or addr in server socket mode (can repeat)"
+ ("When acting as a server on a TCP socket, Unison will by default listen "
+ ^ "on \"any\" address (0.0.0.0 and [::]). This command-line argument "
+ ^ "allows to specify a different listening address and can be repeated "
+ ^ "to listen on multiple addresses. Listening address can be specified "
+ ^ "as a host name or an IP address.")
+let () = Prefs.alias serverHost serverHostNameAlias
(* User preference for which UI to use if there is a choice *)
let uiPrefName = "ui"
let interface =
Prefs.create uiPrefName Uicommon.Graphic
- "!select UI ('text' or 'graphic'); command-line only"
+ ~category:(`Advanced `General)
+ ~cli_only:true
+ "select UI ('text' or 'graphic'); command-line only"
("This preference selects either the graphical or the textual user "
^ "interface. Legal values are \\verb|graphic| or \\verb|text|. "
^ "\n\nBecause this option is processed specially during Unison's "
@@ -123,7 +151,8 @@ let interface =
graphic -> graphic user interface\n"
^other^ " is not a legal value")))
(function Uicommon.Text -> ["text"]
- | Uicommon.Graphic -> ["graphic"]);;
+ | Uicommon.Graphic -> ["graphic"])
+ Uicommon.minterface
let catch_all f =
try
@@ -135,6 +164,13 @@ let catch_all f =
with e ->
Util.msg "Unison server failed: %s\n" (Uicommon.exn2string e); exit 1;;
+let gui_safe_printf fmt =
+ Printf.ksprintf (fun s ->
+ if System.has_stdout ~info:s then Printf.printf "%s" s) fmt
+
+let verify_stdout () =
+ if not (System.has_stdout ~info:"") then exit 37
+
let init () = begin
ignore (Gc.set {(Gc.get ()) with Gc.max_overhead = 150});
(* Make sure exception descriptions include backtraces *)
@@ -144,20 +180,31 @@ let init () = begin
(* Print version if requested *)
if Util.StringMap.mem versionPrefName argv then begin
- Printf.printf "%s version %s\n" Uutil.myName Uutil.myVersion;
+ gui_safe_printf "%s version %s\n" Uutil.myName Uutil.myVersion;
exit 0
end;
(* Print docs for all preferences if requested (this is used when building
the manual) *)
if Util.StringMap.mem prefsdocsPrefName argv then begin
- Prefs.printFullDocs();
+ Prefs.printFullDocs `TeX;
+ exit 0
+ end;
+
+ if Util.StringMap.mem prefsmanPrefName argv then begin
+ begin match Util.StringMap.find prefsmanPrefName argv with
+ | "short" :: _ -> Prefs.printUsageForMan ()
+ | "full" :: _ -> Prefs.printFullDocs `man
+ | _ -> ()
+ end;
exit 0
end;
(* Display documentation if requested *)
begin try
- begin match Util.StringMap.find docsPrefName argv with
+ let docv = Util.StringMap.find docsPrefName argv in
+ verify_stdout ();
+ begin match docv with
[] ->
assert false
| "topics"::_ ->
@@ -205,13 +252,8 @@ let init () = begin
catch_all (fun () ->
Os.createUnisonDir();
Remote.waitOnPort
- (begin try
- match Util.StringMap.find serverHostName argv with
- [] -> None
- | s :: _ -> Some s
- with Not_found ->
- None
- end)
+ ((try Util.StringMap.find serverHostName argv with Not_found -> []) @
+ (try Util.StringMap.find serverHostNameAlias argv with Not_found -> []))
i);
exit 0
with Not_found -> () end;
@@ -237,8 +279,8 @@ module Body = functor (Ui : Uicommon.UI) -> struct
Ui.start
(try
(match Util.StringMap.find uiPrefName argv with
- "text"::_ -> Uicommon.Text
+ | "text"::_ -> verify_stdout (); Uicommon.Text
| "graphic"::_ -> Uicommon.Graphic
- | _ -> Prefs.printUsage Uicommon.usageMsg; exit 1)
+ | _ -> verify_stdout (); Prefs.printUsage Uicommon.usageMsg; exit 1)
with Not_found -> Ui.defaultUi)
end
diff --git a/src/name.ml b/src/name.ml
index b816ccd..f0c6116 100644
--- a/src/name.ml
+++ b/src/name.ml
@@ -20,6 +20,8 @@
INCREMENT "UPDATE.ARCHIVEFORMAT" *)
type t = string
+let m = Umarshal.string
+
let compare n1 n2 = (Case.ops())#compare n1 n2
let eq a b = (0 = (compare a b))
diff --git a/src/name.mli b/src/name.mli
index d2cb26c..a4fe896 100644
--- a/src/name.mli
+++ b/src/name.mli
@@ -3,6 +3,8 @@
type t
+val m : t Umarshal.t
+
val fromString : string -> t
val toString : t -> string
diff --git a/src/negotiate.ml b/src/negotiate.ml
new file mode 100644
index 0000000..471343f
--- /dev/null
+++ b/src/negotiate.ml
@@ -0,0 +1,84 @@
+(* Unison file synchronizer: src/negotiate.ml *)
+(* Copyright 2021, Tõivo Leedjärv
+
+ This program is free software: you can redistribute it and/or modify
+ it under the terms of the GNU General Public License as published by
+ the Free Software Foundation, either version 3 of the License, or
+ (at your option) any later version.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with this program. If not, see <http://www.gnu.org/licenses/>.
+*)
+
+let (>>=) = Lwt.bind
+
+let debug = Util.debug "features"
+
+let debugFeatures name features =
+ debug (fun () ->
+ Util.msg "%s:\n" name;
+ Safelist.iter (fun n -> Util.msg " - %s\n" n) features)
+
+let getCommonFeaturesLocal (root, features) =
+ Features.resetEnabled ();
+ let supportedFeatures = Features.all () in
+ debugFeatures "Supported features" supportedFeatures;
+ debugFeatures "Received features for feature negotiation" features;
+ let common = Features.inter features supportedFeatures in
+ debugFeatures "Selected common features" common;
+ try
+ let () = Features.validate common in
+ let () = Features.setEnabled common in
+ Lwt.return common
+ with
+ | e -> Lwt.fail e
+
+let m = Umarshal.(list string)
+
+let negotiateFeaturesRpcName = "negotiateFeatures"
+let getCommonFeaturesRemote =
+ Remote.registerRootCmd negotiateFeaturesRpcName m m getCommonFeaturesLocal
+
+let getCommonFeaturesOnRoot features = function
+ | (Common.Local, _) -> Lwt.return features
+ | root -> getCommonFeaturesRemote root features
+
+let commonFeatures root fts =
+ getCommonFeaturesOnRoot fts root >>= fun common ->
+ let rn = "Common features for root " ^ Common.root2string root in
+ debugFeatures rn common;
+ try
+ let () = Features.validate common in
+ Lwt.return common
+ with
+ | e -> Lwt.fail e
+
+let allRootsSupportFeatures roots =
+ let aux k r =
+ let supp = Remote.commandAvailable r negotiateFeaturesRpcName in
+ k >>= fun k' ->
+ supp >>= fun supp' ->
+ Lwt.return (k' && supp')
+ in
+ Safelist.fold_left aux (Lwt.return true) roots
+
+let features roots =
+ Features.resetEnabled ();
+ let supportedFeatures = Features.all () in
+ debugFeatures "Supported features" supportedFeatures;
+ allRootsSupportFeatures roots >>= (fun supported ->
+ if not supported then begin
+ debug (fun () -> Util.msg "The server does not support \"features\".\n");
+ Lwt.return (Features.empty)
+ end else
+ Safelist.fold_left (fun fts r -> fts >>= commonFeatures r)
+ (Lwt.return supportedFeatures) roots
+ ) >>= fun common ->
+ debugFeatures "Enabled features" common;
+ Lwt.return (Features.setEnabled common)
+
diff --git a/src/linkgtk.ml b/src/negotiate.mli
similarity index 83%
rename from src/linkgtk.ml
rename to src/negotiate.mli
index a777593..ae5b96a 100644
--- a/src/linkgtk.ml
+++ b/src/negotiate.mli
@@ -1,5 +1,5 @@
-(* Unison file synchronizer: src/linkgtk.ml *)
-(* Copyright 1999-2020, Benjamin C. Pierce
+(* Unison file synchronizer: src/negotiate.mli *)
+(* Copyright 2021, Tõivo Leedjärv
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
@@ -15,5 +15,5 @@
along with this program. If not, see <http://www.gnu.org/licenses/>.
*)
+val features : Common.root list -> unit Lwt.t
-module TopLevel = Main.Body(Uigtk.Body)
diff --git a/src/os.ml b/src/os.ml
index 89895dc..48fbb11 100644
--- a/src/os.ml
+++ b/src/os.ml
@@ -30,8 +30,9 @@ let localCanonicalHostName =
let clientHostName : string Prefs.t =
Prefs.createString "clientHostName" localCanonicalHostName
- "!set host name of client"
- ("When specified, the host name of the client will not be guessed" ^
+ ~category:(`Advanced `Remote)
+ "set host name of client"
+ ("When specified, the host name of the client will not be guessed " ^
"and the provided host name will be used to find the archive.")
let serverHostName = localCanonicalHostName
@@ -59,7 +60,7 @@ let isTempFile file =
(*****************************************************************************)
let exists fspath path =
- (Fileinfo.get false fspath path).Fileinfo.typ <> `ABSENT
+ Fileinfo.getType false fspath path <> `ABSENT
let readLink fspath path =
Util.convertUnixErrorsToTransient
@@ -136,7 +137,7 @@ let rec childrenOf fspath path =
else if isTempFile file then begin
if Util.endswith file !tempFileSuffix then begin
let p = Path.child path filename in
- let i = Fileinfo.get false fspath p in
+ let i = Fileinfo.getBasic false fspath p in
let secondsinthirtydays = 2592000.0 in
if Props.time i.Fileinfo.desc +. secondsinthirtydays < Util.time()
then begin
@@ -163,7 +164,7 @@ and delete fspath path =
"deleting"
(fun () ->
let absolutePath = Fspath.concat fspath path in
- match (Fileinfo.get false fspath path).Fileinfo.typ with
+ match Fileinfo.getType false fspath path with
`DIRECTORY ->
begin try
Fs.chmod absolutePath 0o700
@@ -190,8 +191,10 @@ and delete fspath path =
| `ABSENT ->
())
-let renameFspath fname source target =
+let rename fname sourcefspath sourcepath targetfspath targetpath =
+ let source = Fspath.concat sourcefspath sourcepath in
let source' = Fspath.toPrintString source in
+ let target = Fspath.concat targetfspath targetpath in
let target' = Fspath.toPrintString target in
if source = target then
raise (Util.Transient ("Rename ("^fname^"): identical source and target " ^ source'));
@@ -208,11 +211,6 @@ let renameFspath fname source target =
Fs.unlink targetDouble
end)
-let rename fname sourcefspath sourcepath targetfspath targetpath =
- let source = Fspath.concat sourcefspath sourcepath in
- let target = Fspath.concat targetfspath targetpath in
- renameFspath fname source target
-
let symlink =
if Fs.hasSymlink () then
fun fspath path l ->
@@ -234,12 +232,12 @@ let symlink =
))
(* Create a new directory, using the permissions from the given props *)
-let createDir fspath path props =
+let createDir fspath path perms =
Util.convertUnixErrorsToTransient
"creating directory"
(fun () ->
let absolutePath = Fspath.concat fspath path in
- Fs.mkdir absolutePath (Props.perms props))
+ Fs.mkdir absolutePath perms)
(*****************************************************************************)
(* FINGERPRINTS *)
@@ -247,9 +245,11 @@ let createDir fspath path props =
type fullfingerprint = Fingerprint.t * Fingerprint.t
-let fingerprint fspath path info =
+let mfullfingerprint = Umarshal.(prod2 Fingerprint.m Fingerprint.m id id)
+
+let fingerprint fspath path typ =
(Fingerprint.file fspath path,
- Osx.ressFingerprint fspath path info.Fileinfo.osX)
+ Osx.ressFingerprint fspath path typ)
let pseudoFingerprint path size =
(Fingerprint.pseudo path size, Fingerprint.dummy)
@@ -275,7 +275,7 @@ let safeFingerprint fspath path info optFp =
in
let ressFp =
match optRessFp with
- None -> Osx.ressFingerprint fspath path info.Fileinfo.osX
+ None -> Osx.ressFingerprint fspath path info.Fileinfo.typ
| Some ress -> ress
in
let (info', dataUnchanged, ressUnchanged) =
@@ -318,7 +318,7 @@ let createUnisonDir() =
with Unix.Unix_error(_) ->
Util.convertUnixErrorsToFatal
(Printf.sprintf "creating unison directory %s"
- (System.fspathToPrintString Util.unisonDir))
+ Util.unisonDir)
(fun () ->
ignore (System.mkdir Util.unisonDir 0o700))
diff --git a/src/os.mli b/src/os.mli
index 8c08804..48b17a8 100644
--- a/src/os.mli
+++ b/src/os.mli
@@ -16,9 +16,8 @@ val childrenOf : Fspath.t -> Path.local -> Name.t list
val readLink : Fspath.t -> Path.local -> string
val symlink : Fspath.t -> Path.local -> string -> unit
-val renameFspath : string -> Fspath.t -> Fspath.t -> unit
val rename : string -> Fspath.t -> Path.local -> Fspath.t -> Path.local -> unit
-val createDir : Fspath.t -> Path.local -> Props.t -> unit
+val createDir : Fspath.t -> Path.local -> int -> unit
val delete : Fspath.t -> Path.local -> unit
(* We define a new type of fingerprints here so that clients of
@@ -28,6 +27,7 @@ val delete : Fspath.t -> Path.local -> unit
is a pair of the main file's fingerprint and the resource fork fingerprint,
if any. *)
type fullfingerprint
+val mfullfingerprint : fullfingerprint Umarshal.t
val fullfingerprint_to_string : fullfingerprint -> string
val reasonForFingerprintMismatch : fullfingerprint -> fullfingerprint -> string
val fullfingerprint_dummy : fullfingerprint
@@ -43,7 +43,7 @@ val safeFingerprint :
(* current fileinfo, fingerprint and fork info *)
val fingerprint :
Fspath.t -> Path.local -> (* coordinates of file to fingerprint *)
- Fileinfo.t -> (* old fileinfo *)
+ Fileinfo.typ -> (* old fileinfo *)
fullfingerprint (* current fingerprint *)
val pseudoFingerprint :
diff --git a/src/osx.ml b/src/osx.ml
index 4364d2a..a3d1c7f 100644
--- a/src/osx.ml
+++ b/src/osx.ml
@@ -32,7 +32,8 @@ let isMacOSX = isMacOSXPred ()
let rsrcSync =
Prefs.createBoolWithDefault "rsrc"
- "!synchronize resource forks (true/false/default)"
+ ~category:(`Advanced `Sync)
+ "synchronize resource forks (true/false/default)"
"When set to {\\tt true}, this flag causes Unison to synchronize \
resource forks and HFS meta-data. On filesystems that do not \
natively support resource forks, this data is stored in \
@@ -46,6 +47,7 @@ let rsrcSync =
to the other host during initialization *)
let rsrc =
Prefs.createBool "rsrc-aux" false
+ ~category:(`Internal `Pseudo)
"*synchronize resource forks and HFS meta-data" ""
let init b =
@@ -179,8 +181,21 @@ type 'a ressInfo =
| HfsRess of Uutil.Filesize.t
| AppleDoubleRess of int * float * float * Uutil.Filesize.t * 'a
+let mressInfo m = Umarshal.(sum3 unit Uutil.Filesize.m
+ (prod5 int float float Uutil.Filesize.m m id id)
+ (function
+ | NoRess -> I31 ()
+ | HfsRess a -> I32 a
+ | AppleDoubleRess (a, b, c, d, e) -> I33 (a, b, c, d, e))
+ (function
+ | I31 () -> NoRess
+ | I32 a -> HfsRess a
+ | I33 (a, b, c, d, e) -> AppleDoubleRess (a, b, c, d, e)))
+
type ressStamp = unit ressInfo
+let mressStamp = mressInfo Umarshal.unit
+
let ressStampToString r =
match r with
NoRess ->
@@ -195,10 +210,14 @@ type info =
{ ressInfo : (Fspath.t * int64) ressInfo;
finfo : string }
+let minfo = Umarshal.(prod2 (mressInfo (prod2 Fspath.m int64 id id)) string
+ (fun {ressInfo; finfo} -> ressInfo, finfo)
+ (fun (ressInfo, finfo) -> {ressInfo; finfo}))
+
external getFileInfosInternal :
- System.fspath -> bool -> string * int64 = "getFileInfos"
+ string -> bool -> string * int64 = "getFileInfos"
external setFileInfosInternal :
- System.fspath -> string -> unit = "setFileInfos"
+ string -> string -> unit = "setFileInfos"
let defaultInfos typ =
match typ with
@@ -244,7 +263,7 @@ let getFileInfos dataFspath dataPath typ =
try
let (fInfo, rsrcLength) =
getFileInfosInternal
- (Fspath.toSysPath (Fspath.concat dataFspath dataPath))
+ (Fspath.toString (Fspath.concat dataFspath dataPath))
(typ = `FILE)
in
{ ressInfo =
@@ -255,7 +274,8 @@ let getFileInfos dataFspath dataPath typ =
(* Not a HFS volume. Look for an AppleDouble file *)
try
let (workingDir, realPath) =
- Fspath.findWorkingDir dataFspath dataPath in
+ try Fspath.findWorkingDir dataFspath dataPath with
+ | Util.Transient _ -> raise Not_found in
let (doubleFspath, inch, entries) =
openDouble workingDir realPath in
let (rsrcOffset, rsrcLength) =
@@ -342,18 +362,21 @@ let setFileInfos dataFspath dataPath finfo =
assert (finfo <> "");
Util.convertUnixErrorsToTransient "setting file information" (fun () ->
try
- let p = Fspath.toSysPath (Fspath.concat dataFspath dataPath) in
+ let p = Fspath.toString (Fspath.concat dataFspath dataPath) in
let (fullFinfo, _) = getFileInfosInternal p false in
setFileInfosInternal p (insertInfo (Bytes.of_string fullFinfo) finfo)
- with Unix.Unix_error ((Unix.EOPNOTSUPP | Unix.ENOSYS), _, _) ->
+ with Unix.Unix_error ((EOPNOTSUPP | ENOSYS | EUNKNOWNERR 93), _, _) ->
+ (* ENOATTR (93) is returned on msdos/exfat fs since macOS 13 *)
(* Not an HFS volume. Look for an AppleDouble file *)
let (workingDir, realPath) = Fspath.findWorkingDir dataFspath dataPath in
begin try
let (doubleFspath, inch, entries) = openDouble workingDir realPath in
begin try
let (ofs, len) = Safelist.assoc `FINFO entries in
- if len < finfoLength then
- fail dataFspath dataPath doubleFspath "bad finder info";
+ if len < finfoLength then begin
+ close_in_noerr inch;
+ fail dataFspath dataPath doubleFspath "bad finder info"
+ end;
let fullFinfo =
protect
(fun () ->
@@ -452,7 +475,12 @@ let stamp info =
| AppleDoubleRess (inode, mtime, ctime, len, _) ->
AppleDoubleRess (inode, mtime, ctime, len, ())
-let ressFingerprint fspath path info =
+let ressFingerprint fspath path typ =
+ (* This function used to get ready-made info passed in. (Re-)getting the
+ info here may consume one or a few additional syscalls. This is not
+ thought to be a problem unless there are hundreds of thousands of files
+ with resource forks. That is really unlikely. *)
+ let info = getFileInfos fspath path typ in
match info.ressInfo with
NoRess ->
Fingerprint.dummy
@@ -481,7 +509,7 @@ let openRessIn fspath path =
Unix.in_channel_of_descr
(Fs.openfile
(Fspath.concat fspath (ressPath path))
- [Unix.O_RDONLY] 0o444)
+ [Unix.O_RDONLY; O_CLOEXEC] 0o444)
with Unix.Unix_error ((Unix.ENOENT | Unix.ENOTDIR), _, _) ->
let (doublePath, inch, entries) = openDouble fspath path in
try
@@ -499,7 +527,7 @@ let openRessOut fspath path length =
let p = Fspath.concat fspath (ressPath path) in
debug (fun () -> Util.msg "openRessOut %s\n" (Fspath.toString p));
Unix.out_channel_of_descr
- (Fs.openfile p [Unix.O_WRONLY;Unix.O_CREAT] 0o600)
+ (Fs.openfile p [Unix.O_WRONLY; O_CREAT; O_CLOEXEC] 0o600)
with Unix.Unix_error ((Unix.ENOENT | Unix.ENOTDIR), _, _) ->
debug (fun () -> Util.msg "Opening AppleDouble file for resource fork\n");
let path = Fspath.appleDouble (Fspath.concat fspath path) in
diff --git a/src/osx.mli b/src/osx.mli
index c7a67f8..55c6c8d 100644
--- a/src/osx.mli
+++ b/src/osx.mli
@@ -12,6 +12,9 @@ type info =
{ ressInfo : (Fspath.t * int64) ressInfo;
finfo : string }
+val mressStamp : ressStamp Umarshal.t
+val minfo : info Umarshal.t
+
val defaultInfos : [> `DIRECTORY | `FILE ] -> info
val getFileInfos : Fspath.t -> Path.local -> [> `DIRECTORY | `FILE ] -> info
@@ -20,7 +23,7 @@ val setFileInfos : Fspath.t -> Path.local -> string -> unit
val ressUnchanged :
'a ressInfo -> 'b ressInfo -> float option -> bool -> bool
-val ressFingerprint : Fspath.t -> Path.local -> info -> Fingerprint.t
+val ressFingerprint : Fspath.t -> Path.local -> [> `DIRECTORY | `FILE ] -> Fingerprint.t
val ressLength : 'a ressInfo -> Uutil.Filesize.t
val ressDummy : ressStamp
diff --git a/src/osxsupport.c b/src/osxsupport.c
index 6fe0267..7de66f7 100644
--- a/src/osxsupport.c
+++ b/src/osxsupport.c
@@ -4,6 +4,7 @@
#include <caml/mlvalues.h>
#include <caml/alloc.h>
#include <caml/memory.h>
+#include <caml/unixsupport.h>
#ifdef __APPLE__
#include <sys/types.h>
#include <sys/stat.h>
@@ -15,21 +16,25 @@
#endif
#include <errno.h>
-extern void unix_error (int errcode, char * cmdname, value arg) Noreturn;
-extern void uerror (char * cmdname, value arg) Noreturn;
+#include <caml/version.h>
+#if OCAML_VERSION_MAJOR < 5
+#define caml_unix_error unix_error
+#define caml_uerror uerror
+#endif
CAMLprim value isMacOSX (value nothing) {
+ CAMLparam0();
#ifdef __APPLE__
- return Val_true;
+ CAMLreturn(Val_true);
#else
- return Val_false;
+ CAMLreturn(Val_false);
#endif
}
CAMLprim value getFileInfos (value path, value need_size) {
#ifdef __APPLE__
- CAMLparam1(path);
+ CAMLparam2(path, need_size);
CAMLlocal3(res, fInfo, length);
int retcode;
struct attrlist attrList;
@@ -54,24 +59,24 @@ CAMLprim value getFileInfos (value path, value need_size) {
retcode = getattrlist(String_val (path), &attrList, &attrBuf,
sizeof attrBuf, options);
- if (retcode == -1) uerror("getattrlist", path);
+ if (retcode == -1) caml_uerror("getattrlist", path);
if (Bool_val (need_size)) {
if (attrBuf.length != sizeof attrBuf)
- unix_error (EINVAL, "getattrlist", path);
+ caml_unix_error(EINVAL, "getattrlist", path);
} else {
if (attrBuf.length != sizeof (u_int32_t) + 32)
- unix_error (EINVAL, "getattrlist", path);
+ caml_unix_error(EINVAL, "getattrlist", path);
}
fInfo = caml_alloc_string (32);
memcpy ((char *) String_val (fInfo), attrBuf.finderInfo, 32);
if (Bool_val (need_size))
- length = copy_int64 (attrBuf.rsrcLength);
+ length = caml_copy_int64(attrBuf.rsrcLength);
else
- length = copy_int64 (0);
+ length = caml_copy_int64(0);
- res = alloc_small (2, 0);
+ res = caml_alloc_small(2, 0);
Field (res, 0) = fInfo;
Field (res, 1) = length;
@@ -79,7 +84,7 @@ CAMLprim value getFileInfos (value path, value need_size) {
#else
- unix_error (ENOSYS, "getattrlist", path);
+ caml_unix_error(ENOSYS, "getattrlist", path);
#endif
}
@@ -114,9 +119,9 @@ CAMLprim value setFileInfos (value path, value fInfo) {
if file is read-only. Try making it writable temporarily. */
struct stat st;
int r = stat(String_val(path), &st);
- if (r == -1) uerror("setattrlist", path);
+ if (r == -1) caml_uerror("setattrlist", path);
r = chmod(String_val(path), st.st_mode | S_IWUSR);
- if (r == -1) uerror("setattrlist", path);
+ if (r == -1) caml_uerror("setattrlist", path);
/* Try again */
retcode = setattrlist(String_val (path), &attrList, attrBuf.finderInfo,
sizeof attrBuf.finderInfo, options);
@@ -124,13 +129,13 @@ CAMLprim value setFileInfos (value path, value fInfo) {
chmod(String_val(path), st.st_mode);
}
- if (retcode == -1) uerror("setattrlist", path);
+ if (retcode == -1) caml_uerror("setattrlist", path);
CAMLreturn (Val_unit);
#else
- unix_error (ENOSYS, "setattrlist", path);
+ caml_unix_error(ENOSYS, "setattrlist", path);
#endif
}
diff --git a/src/path.ml b/src/path.ml
index 147fee2..1970734 100644
--- a/src/path.ml
+++ b/src/path.ml
@@ -22,6 +22,10 @@ type 'a path = string
type t = string
type local = string
+let mpath = Umarshal.string
+let m = mpath
+let mlocal = mpath
+
let pathSeparatorChar = '/'
let pathSeparatorString = "/"
@@ -211,7 +215,8 @@ let addPrefixToFinalName path prefix =
prefix ^ path
(* Pref controlling whether symlinks are followed. *)
-let followPred = Pred.create ~advanced:true "follow"
+let followPred = Pred.create "follow"
+ ~category:(`Advanced `Sync)
("Including the preference \\texttt{-follow \\ARG{pathspec}} causes Unison to \
treat symbolic links matching \\ARG{pathspec} as `invisible' and \
behave as if the object pointed to by the link had appeared literally \
@@ -221,8 +226,7 @@ let followPred = Pred.create ~advanced:true "follow"
described in \\sectionref{pathspec}{Path Specification}.")
let followLink path =
- (Util.osType = `Unix || Util.isCygwin)
- && Pred.test followPred (toString path)
+ Pred.test followPred (toString path)
let forceLocal p = p
let makeGlobal p = p
diff --git a/src/path.mli b/src/path.mli
index 8c6cf9a..f01356d 100644
--- a/src/path.mli
+++ b/src/path.mli
@@ -12,6 +12,10 @@ type t = [`Global] path
sensitive filesystem) *)
type local = [`Local] path
+val mpath : 'a path Umarshal.t
+val m : t Umarshal.t
+val mlocal : local Umarshal.t
+
val empty : 'a path
val length : t -> int
val isEmpty : local -> bool
diff --git a/src/pixmaps.ml b/src/pixmaps.ml
index 857995f..1eeb213 100644
--- a/src/pixmaps.ml
+++ b/src/pixmaps.ml
@@ -251,23 +251,6 @@ let copyBAblack_asym = [|
"............................"
|]
-(***********************************************************************)
-(* Busy-Interactive mous pointer *)
-(***********************************************************************)
-
-let left_ptr_watch = "\
-\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\
-\x0c\x00\x00\x00\x1c\x00\x00\x00\x3c\x00\x00\x00\
-\x7c\x00\x00\x00\xfc\x00\x00\x00\xfc\x01\x00\x00\
-\xfc\x3b\x00\x00\x7c\x38\x00\x00\x6c\x54\x00\x00\
-\xc4\xdc\x00\x00\xc0\x44\x00\x00\x80\x39\x00\x00\
-\x80\x39\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\
-\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\
-\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\
-\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\
-\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\
-\x00\x00\x00\x00\x00\x00\x00\x00"
-
(***********************************************************************)
(* Unison icon *)
diff --git a/src/pred.ml b/src/pred.ml
index 10fd578..520f5ca 100644
--- a/src/pred.ml
+++ b/src/pred.ml
@@ -98,16 +98,15 @@ let compile_pattern clause =
end in
(compiled, v)
-let create name ?(local=false) ?(advanced=false) fulldoc =
+let create name ~category ?(local=false) ?send ?(initial = []) fulldoc =
let pref =
- Prefs.create name ~local []
- ((if advanced then "!" else "")
- ^ "add a pattern to the " ^ name ^ " list")
+ Prefs.create name ~category ~local ?send initial
+ ("add a pattern to the " ^ name ^ " list")
fulldoc
(fun oldList string ->
ignore (compile_pattern string); (* Check well-formedness *)
string :: oldList)
- (fun l -> l) in
+ (fun l -> l) Umarshal.(list string) in
{pref = pref; name = name;
last_pref = []; default = []; last_def = []; last_mode = (Case.ops())#mode;
compiled = Rx.empty; associated_strings = []}
diff --git a/src/pred.mli b/src/pred.mli
index 7329988..cd915b2 100644
--- a/src/pred.mli
+++ b/src/pred.mli
@@ -30,9 +30,22 @@ type t
val mapSeparator : string
-(* Create a new predicate and register it with the preference module. The first
- arg is the name of the predicate; the second is full (latex) documentation. *)
-val create : string -> ?local:bool -> ?advanced:bool -> string -> t
+(* Create a new predicate and register it with the preference module. *)
+val create :
+ string (* Name of the predicate *)
+ -> category:Prefs.group
+ -> ?local:bool
+ -> ?send:(unit -> bool)
+ -> ?initial:string list (* Initial value for the "current patterns", separate
+ from the persistent default patterns that are
+ modified by [addDefaultPatterns]. User preferences
+ will be added to this value, but this value is not
+ persistent when the associated preference is cleared
+ (for example, [intern] will overwrite it). This
+ value will be returned by [extern] (if it hasn't
+ been cleared before). *)
+ -> string (* Full (latex) documentation *)
+ -> t
(* Check whether a given path matches one of the default or current patterns *)
val test : t -> string -> bool
diff --git a/src/props.ml b/src/props.ml
index 4a502e7..469d621 100644
--- a/src/props.ml
+++ b/src/props.ml
@@ -17,9 +17,11 @@
let debug = Util.debug "props"
+let debugverbose = Util.debug "props+"
module type S = sig
type t
+ val m : t Umarshal.t
val dummy : t
val hash : t -> int -> int
val similar : t -> t -> bool
@@ -28,9 +30,8 @@ module type S = sig
val diff : t -> t -> t
val toString : t -> string
val syncedPartsToString : t -> string
- val set : Fspath.t -> Path.local -> [`Set | `Update] -> t -> unit
- val get : Unix.LargeFile.stats -> Osx.info -> t
- val init : bool -> unit
+ val set : Fspath.t -> t -> unit
+ val get : Unix.LargeFile.stats -> t
end
(* Nb: the syncedPartsToString call is only used for archive dumping, for *)
@@ -44,10 +45,12 @@ module Perm : sig
val fileSafe : t
val dirDefault : t
val extract : t -> int
+ val set : Fspath.t -> [`Set | `Update] -> t -> unit
val check : Fspath.t -> Path.local -> Unix.LargeFile.stats -> t -> unit
val validatePrefs : unit -> unit
val permMask : int Prefs.t
val dontChmod : bool Prefs.t
+ val init : bool -> unit
end = struct
(* We introduce a type, Perm.t, that holds a file's permissions along with *)
@@ -66,6 +69,8 @@ end = struct
(* "UPDATE.ARCHIVEFORMAT" *)
type t = int * int
+let m = Umarshal.(prod2 int int id id)
+
(* This allows us to export NullPerm while keeping the type perm abstract *)
let dummy = (0, 0)
@@ -79,17 +84,18 @@ let wind_mask =
let permMask =
Prefs.createInt "perms"
(0o777 (* rwxrwxrwx *) + 0o1000 (* Sticky bit *))
+ ~category:(`Basic `Sync)
"part of the permissions which is synchronized"
"The integer value of this preference is a mask indicating which \
permission bits should be synchronized. It is set by default to \
$0o1777$: all bits but the set-uid and set-gid bits are \
- synchronised (synchronizing theses latter bits can be a security \
+ synchronised (synchronizing these latter bits can be a security \
hazard). If you want to synchronize all bits, you can set the \
value of this preference to $-1$. If one of the replica is on \
a FAT [Windows] filesystem, you should consider using the \
- {\tt fat} preference instead of this preference. If you need \
+ {\\tt fat} preference instead of this preference. If you need \
Unison not to set permissions at all, set the value of this \
- preference to $0$ and set the preference {\tt dontchmod} to {\tt true}."
+ preference to $0$ and set the preference {\\tt dontchmod} to {\\tt true}."
(* Os-specific local conventions on file permissions *)
let (fileDefault, dirDefault, fileSafe, dirSafe) =
@@ -194,7 +200,8 @@ let syncedPartsToString =
let dontChmod =
Prefs.createBool "dontchmod"
false
- "!when set, never use the chmod system call"
+ ~category:(`Advanced `Syncprocess)
+ "when set, never use the chmod system call"
( "By default, Unison uses the 'chmod' system call to set the permission bits"
^ " of files after it has copied them. But in some circumstances (and under "
^ " some operating systems), the chmod call always fails. Setting this "
@@ -204,7 +211,7 @@ let validatePrefs () =
if Prefs.read dontChmod && (Prefs.read permMask <> 0) then raise (Util.Fatal
"If the 'dontchmod' preference is set, the 'perms' preference should be 0")
-let set fspath path kind (fp, mask) =
+let set abspath kind (fp, mask) =
(* BCP: removed "|| kind <> `Update" on 10/2005, but reinserted it on 11/2008.
I'd removed it to make Dale Worley happy -- he wanted a way to make sure that
Unison would never call chmod, and setting prefs to 0 seemed like a reasonable
@@ -214,7 +221,6 @@ let set fspath path kind (fp, mask) =
Util.convertUnixErrorsToTransient
"setting permissions"
(fun () ->
- let abspath = Fspath.concat fspath path in
debug
(fun() ->
Util.msg "Setting permissions for %s to %s (%s)\n"
@@ -233,7 +239,7 @@ let set fspath path kind (fp, mask) =
or else set preference \"perms\" to 0 and \
preference \"dontchmod\" to true to avoid this error")))
-let get stats _ = (stats.Unix.LargeFile.st_perm, Prefs.read permMask)
+let get stats = (stats.Unix.LargeFile.st_perm, Prefs.read permMask)
let check fspath path stats (fp, mask) =
let fp' = stats.Unix.LargeFile.st_perm in
@@ -273,7 +279,8 @@ end
let numericIds =
Prefs.createBool "numericids" false
- "!don't map uid/gid values by user/group names"
+ ~category:(`Advanced `Syncprocess)
+ "don't map uid/gid values by user/group names"
"When this flag is set to \\verb|true|, groups and users are \
synchronized numerically, rather than by name. \n\
\n\
@@ -291,13 +298,26 @@ module Id (M : sig
val syncedPartsToString : int -> string
val set : Fspath.t -> int -> unit
val get : Unix.LargeFile.stats -> int
-end) : S = struct
+end) : sig
+ include S
+ val init : bool -> unit
+end = struct
type t =
IdIgnored
| IdNamed of string
| IdNumeric of int
+let m = Umarshal.(sum3 unit string int
+ (function
+ | IdIgnored -> I31 ()
+ | IdNamed a -> I32 a
+ | IdNumeric a -> I33 a)
+ (function
+ | I31 () -> IdIgnored
+ | I32 a -> IdNamed a
+ | I33 a -> IdNumeric a))
+
let dummy = IdIgnored
let hash id h =
@@ -348,7 +368,7 @@ let extern id =
Hashtbl.add tbl nm id;
id
-let set fspath path kind id =
+let set abspath id =
match extern id with
-1 ->
()
@@ -356,12 +376,11 @@ let set fspath path kind id =
Util.convertUnixErrorsToTransient
"setting file ownership"
(fun () ->
- let abspath = Fspath.concat fspath path in
M.set abspath id)
let tbl = Hashtbl.create 17
-let get stats _ =
+let get stats =
if not (Prefs.read M.sync) then IdIgnored else
let id = M.get stats in
if id = 0 || Prefs.read numericIds then IdNumeric id else
@@ -381,8 +400,9 @@ end
module Uid = Id (struct
let sync =
- Prefs.createBool "owner"
- false "synchronize owner"
+ Prefs.createBool "owner" false
+ ~category:(`Basic `Sync)
+ "synchronize owner"
("When this flag is set to \\verb|true|, the owner attributes "
^ "of the files are synchronized. "
^ "Whether the owner names or the owner identifiers are synchronized"
@@ -402,8 +422,9 @@ end)
module Gid = Id (struct
let sync =
- Prefs.createBool "group"
- false "synchronize group attributes"
+ Prefs.createBool "group" false
+ ~category:(`Basic `Sync)
+ "synchronize group attributes"
("When this flag is set to \\verb|true|, the group attributes "
^ "of the files are synchronized. "
^ "Whether the group names or the group identifiers are synchronized "
@@ -434,13 +455,22 @@ module Time : sig
end = struct
let sync =
- Prefs.createBool "times"
- false "synchronize modification times"
+ Prefs.createBool "times" false
+ ~category:(`Basic `Sync)
+ "synchronize modification times"
"When this flag is set to \\verb|true|, \
file modification times (but not directory modtimes) are propagated."
type t = Synced of float | NotSynced of float
+let m = Umarshal.(sum2 float float
+ (function
+ | Synced a -> I21 a
+ | NotSynced a -> I22 a)
+ (function
+ | I21 a -> Synced a
+ | I22 a -> NotSynced a))
+
let dummy = NotSynced 0.
let extract t = match t with Synced v -> v | NotSynced v -> v
@@ -491,7 +521,7 @@ let override t t' =
let replace t v =
match t with
- Synced _ -> t
+ Synced _ -> Synced v
| NotSynced _ -> NotSynced v
let strip t =
@@ -509,36 +539,13 @@ let syncedPartsToString t = match t with
(* FIX: Probably there should be a check here that prevents us from ever *)
(* setting a file's modtime into the future. *)
-let set fspath path kind t =
+let set abspath t =
match t with
Synced v ->
Util.convertUnixErrorsToTransient
"setting modification time"
(fun () ->
- let abspath = Fspath.concat fspath path in
- if not (Fs.canSetTime abspath) then
- begin
- (* Nb. This workaround was proposed by Dmitry Bely, to
- work around the fact that Unix.utimes fails on readonly
- files under windows. I'm [bcp] a little bit uncomfortable
- with it for two reasons: (1) if we crash in the middle,
- the permissions might be left in a bad state, and (2) I
- don't understand the Win32 permissions model enough to
- know whether it will always work -- e.g., what if the
- UID of the unison process is not the same as that of the
- file itself (under Unix, this case would fail, but we
- certainly don't want to make it WORLD-writable, even
- briefly!). *)
- let oldPerms =
- (Fs.lstat abspath).Unix.LargeFile.st_perm in
- Util.finalize
- (fun()->
- Fs.chmod abspath 0o600;
- Fs.utimes abspath (if v = 0. then 1e-12 else v) v)
- (* See comment about this statement further below *)
- (fun()-> Fs.chmod abspath oldPerms)
- end
- else if false then begin
+ if false then begin
(* A special hack for Rasmus, who has a special situation that
requires the utimes-setting program to run 'setuid root'
(and we do not want all of Unison to run setuid, so we just
@@ -555,7 +562,7 @@ let set fspath path kind t =
let cmd = "/usr/local/bin/sudo -u root /usr/bin/touch -m -a -t "
^ tstr ^ " " ^ Fspath.quotes abspath in
Util.msg "Running external program to set utimes:\n %s\n" cmd;
- let (r,_) = Lwt_unix.run (External.runExternalProgram cmd) in
+ let r = System.close_process_in (System.open_process_in cmd) in
if r<>(Unix.WEXITED 0) then raise (Util.Transient "External time-setting command failed")
end else
Fs.utimes abspath (if v = 0. then 1e-12 else v) v)
@@ -569,7 +576,7 @@ let set fspath path kind t =
| _ ->
()
-let get stats _ =
+let get stats =
let v = stats.Unix.LargeFile.st_mtime in
if stats.Unix.LargeFile.st_kind = Unix.S_REG && Prefs.read sync then
Synced v
@@ -603,18 +610,23 @@ let same p p' =
let delta = extract p -. extract p' in
delta = 0. || delta = 3600. || delta = -3600.
-let init _ = ()
-
end
(* ------------------------------------------------------------------------- *)
(* Type and creator *)
(* ------------------------------------------------------------------------- *)
-module TypeCreator : S = struct
+module TypeCreator :
+ sig
+ include S
+ val set : Fspath.t -> Path.local -> t -> unit
+ val get : Unix.LargeFile.stats -> Osx.info -> t
+ end = struct
type t = string option
+let m = Umarshal.(option string)
+
let dummy = None
let hash t h = Uutil.hash2 (Uutil.hash t) h
@@ -642,7 +654,7 @@ let toString t =
let syncedPartsToString = toString
-let set fspath path kind t =
+let set fspath path t =
match t with
None -> ()
| Some t -> Osx.setFileInfos fspath path t
@@ -657,7 +669,612 @@ let get stats info =
else
None
-let init _ = ()
+end
+
+(* ------------------------------------------------------------------------- *)
+(* Change time *)
+(* ------------------------------------------------------------------------- *)
+
+(* ctime itself is never synchronized. It is only leveraged for faster
+ metadata update detection; and stored in archive for this purpose. *)
+
+module CTime : sig
+ type t
+ val m : t Umarshal.t
+ val dummy : t
+ val override : t -> t -> t
+ val get : Unix.LargeFile.stats -> t
+ val same_time : t -> t -> bool
+end = struct
+
+type t = float
+
+let m = Umarshal.float
+
+let dummy = -1.
+
+(* Currently [override] does not work for ctime because the real on-disk
+ ctime will inevitably change when the final props are set on disk by
+ [Files.setProp] or the final rename after copying is done in [Files.copy]
+ (these happen after [override]). There is no [stat] done after these
+ operations, so this final ctime will not get stored in the archive.
+ It is not a major issue and doesn't break anything. The only side-effect is
+ that at next updates scan the entire set of metadata for this file/dir is
+ scanned (as if fastcheck was disabled); which may even be a good thing.
+ Not worth changing or adding the cost of an additional [stat]. But if it
+ is changed in future then the proper ctime value must be extracted in
+ [Props.get']. *)
+let override t t' = t
+
+let get stats = stats.Unix.LargeFile.st_ctime
+
+let same_time t t' = System.hasCorrectCTime && t = t'
+
+end
+
+(* ------------------------------------------------------------------------- *)
+(* Extended attributes (xattr) *)
+(* ------------------------------------------------------------------------- *)
+
+let featXattrValid = ref (fun _ _ -> None)
+
+let featXattr =
+ Features.register "Sync: xattr" ~arcFormatChange:true
+ (Some (fun a b -> !featXattrValid a b))
+
+let xattrEnabled () = Features.enabled featXattr
+
+let syncXattrs =
+ Prefs.createBool "xattrs" false
+ ~category:(`Advanced `Sync)
+ ~send:xattrEnabled
+ "synchronize extended attributes (xattrs)"
+ ("When this flag is set to \\verb|true|, the extended attributes of \
+ files and directories are synchronized. System extended attributes \
+ are not synchronized.")
+
+let () = featXattrValid :=
+ fun _ enabledThis ->
+ if not enabledThis && Prefs.read syncXattrs then
+ Some ("You have requested synchronization of extended attributes (the \
+ \"xattrs\" preference) but the server does not support this.")
+ else None
+
+let xattrIgnorePred =
+ Pred.create "xattrignore"
+ ~category:(`Advanced `Sync)
+ ~send:xattrEnabled
+ (* By default ignore the Linux xattr security and trusted namespaces *)
+ ~initial:["Regex !(security|trusted)[.].*"; "Path !system.posix_acl_*"]
+ ("Preference \\texttt{-xattrignore \\ARG{namespec}} causes Unison to \
+ ignore extended attributes with names that match \\ARG{namespec}. \
+ This can be used to exclude extended attributes that would fail \
+ synchronization due to lack of permissions or technical differences \
+ at replicas. The syntax of \\ARG{namespec} is the same as used \
+ for path specification (described in \
+ \\sectionref{pathspec}{Path Specification}); prefer the \\verb|Path| \
+ and \\verb|Regex| forms over the \\verb|Name| form. The pattern is \
+ applied to the {\\em name} of extended attribute, not to path. \
+ {\\em On Linux}, attributes in the security and trusted namespaces \
+ are ignored by default (this is achieved by pattern \\texttt{Regex \
+ !(security|trusted)[.].*}); also attributes used to store POSIX ACL \
+ are ignored by default (this is achieved by pattern \\texttt{Path \
+ !system.posix\\_acl\\_*}). To sync attributes in one or both of \
+ these namespaces, see the \\verb|xattrignorenot| preference. \
+ Note that the namespace name must be prefixed with a \"!\" (applies \
+ on Linux only). All names not prefixed with a \"!\" are taken \
+ as strictly belonging to the user namespace and therefore the \
+ \"!user.\" prefix is never used.")
+
+let xattrIgnorenotPred =
+ Pred.create "xattrignorenot"
+ ~category:(`Advanced `Sync)
+ ~send:xattrEnabled
+ ("This preference overrides the preference \\texttt{xattrignore}. \
+ It gives a list of patterns (in the same format as \
+ \\verb|xattrignore|) for extended attributes that should {\\em not} \
+ be ignored, whether or not they happen to match one of the \
+ \\verb|xattrignore| patterns. It is possible to synchronize only \
+ desired attributes by ignoring all attributes (for example, by \
+ setting \\verb|xattrignore| to \\texttt{Path *} and then adding \
+ \\verb|xattrignorenot| for extended attributes that should be \
+ synchronized. \
+ {\\em On Linux}, attributes in the security and trusted namespaces \
+ are ignored by default. To sync attributes in one or both of these \
+ namespaces, you may add an \\verb|xattrignorenot| pattern like \
+ \\texttt{Path !security.*} to sync all attributes in the \
+ security namespace, or \\texttt{Path !security.selinux} to sync \
+ a specific attribute in an otherwise ignored namespace. A pattern \
+ like \\texttt{Path !system.posix\\_acl\\_*} can be used to sync \
+ POSIX ACLs on Linux. \
+ Note that the namespace name must be prefixed with a \"!\" (applies \
+ on Linux only). All names not prefixed with a \"!\" are taken \
+ as strictly belonging to the user namespace and therefore the \
+ \"!user.\" prefix is never used.")
+
+module Xattr : sig
+ include S
+ val ctimeDetect : bool
+ val get : Fspath.t -> Unix.LargeFile.stats -> t
+ val readAll : Fspath.t -> t -> t
+ val getAll : t -> t
+ val purge : t -> t
+ val check : Fspath.t -> Path.local -> Unix.LargeFile.stats -> t -> unit
+ module Data : Propsdata.S
+end = struct
+
+module Size = Uutil.Filesize
+
+module Data = Propsdata.Xattr
+
+module Cache = struct
+ let get key = Data.find_opt key
+
+ let add key value =
+ (* Cache relatively small data in a relatively small quantity to keep
+ the memory pressure and network traffic at updates scanning low.
+
+ There is no cache management. Once it's full, it's full. This can be
+ enhanced in future, if needed. *)
+ if String.length value < 1024 && Data.length () < 200 then
+ Data.add key value;
+ value
+end
+
+type attrvalue =
+ | String of string
+ | Hash of string
+ | Loaded of (string * string) (* full value, hash *)
+
+let mattrvalue = Umarshal.(sum3 string string (prod2 string string id id)
+ (function
+ | String v -> I31 v
+ | Hash v -> I32 v
+ | Loaded v -> I33 v)
+ (function
+ | I31 v -> String v
+ | I32 v -> Hash v
+ | I33 v -> Loaded v))
+
+type attrlist = (string * attrvalue) list
+
+let mattrlist = Umarshal.(list (prod2 string mattrvalue id id))
+
+type sizeandattrs = attrlist * Uutil.Filesize.t
+
+let msizeandattrs = Umarshal.(prod2 mattrlist Uutil.Filesize.m id id)
+
+(* None indicates xattrs are not supported. This is not synchronized.
+ * An empty list means xattrs are supported but there are none on the file.
+ * This will be synchronized. *)
+type t = sizeandattrs option
+
+let dummy = None
+
+let m = Umarshal.cond xattrEnabled dummy Umarshal.(option msizeandattrs)
+
+let ctimeDetect = System.xattrUpdatesCTime
+
+(* Since [hash] is supposed to be run after [purge] (resulting in the
+ data that is stored in the archives) then we don't need to take
+ into account the difference between Hash and Loaded.
+
+ The attribute list must be sorted to get a stable hash. The list
+ is sorted once, when retrieving it from fs. If sorting conditions
+ are changed in future then this hash function may have to be
+ changed to retain backwards compatibility. *)
+let hash t h = if Prefs.read syncXattrs then Uutil.hash2 (Uutil.hash t) h else h
+
+let attrToString = function
+ | (n, String v) ->
+ Printf.sprintf "Name: %s Value: %s" n (String.escaped v)
+ | (n, Hash h) ->
+ Printf.sprintf "Name: %s Fingerprint: %s" n (Digest.to_hex h)
+ | (n, Loaded (_, h)) ->
+ Printf.sprintf "Name: %s Fingerprint: %s" n (Digest.to_hex h)
+
+let toString' style = function
+ | Some ([], _) -> "0 xattrs"
+ | Some ([(n, _) as x], z) ->
+ Printf.sprintf "1 xattr (%s bytes)%s" (Size.toString z)
+ (match style with
+ | `Summary -> ""
+ | `Simple -> ": " ^ n
+ | `Verbose -> ": " ^ attrToString x)
+ | Some (l, z) ->
+ Printf.sprintf "%u xattrs (%s bytes)%s" (Safelist.length l) (Size.toString z)
+ (match style with
+ | `Summary -> ""
+ | `Simple -> ": " ^ (String.concat ", " (Safelist.map (fun (n, _) -> n) l))
+ | `Verbose -> "\n " ^ (String.concat "\n " (Safelist.map attrToString l)))
+ | None -> ""
+
+let toString = function
+ | None -> ""
+ | t -> " " ^ toString' `Summary t
+
+let syncedPartsToString t = " " ^ toString' `Simple t
+
+let toDebugString t = toString' `Simple t
+
+let toStringVerb t = toString' `Verbose t
+
+let attrEqual (n, v) (n', v') =
+ String.equal n n' &&
+ match v, v' with
+ | String a, String b
+ | String a, Loaded (b, _)
+ | Hash a, Hash b
+ | Hash a, Loaded (_, b)
+ | Loaded (a, _), String b
+ | Loaded (_, a), Hash b
+ | Loaded (_, a), Loaded (_, b) -> String.equal a b
+ | String s, Hash h
+ | Hash h, String s -> String.equal h (Digest.string s)
+
+let rec attrlist_mem x = function
+ | [] -> false
+ | a :: l -> attrEqual a x || attrlist_mem x l
+
+let similar t t' =
+ not (Prefs.read syncXattrs)
+ ||
+ match t, t' with
+ | None, None -> true
+ | Some (l, z), Some (l', z') ->
+ Int64.equal (Size.toInt64 z) (Size.toInt64 z') &&
+ Safelist.length l = Safelist.length l' &&
+ Safelist.for_all (fun m -> attrlist_mem m l') l
+ | _ -> false
+
+let override t t' = t'
+
+let strip t = if Prefs.read syncXattrs then t else None
+
+let diff t t' = if similar t t' then None else t'
+
+let wrapFail default f =
+ try f () with
+ | Fs.XattrNotSupported -> default
+ | Failure msg ->
+ raise (Util.Transient (msg ^
+ ". You can set preference \"xattrs\" to false to avoid this error."))
+
+let optMap f = function None -> None | Some x -> Some (f x)
+let optAttrsMap f = optMap (fun (l, z) -> (Safelist.map f l, z))
+
+let purge t =
+ optAttrsMap (function (n, Loaded (_, h)) -> (n, Hash h) | x -> x) t
+
+let readAll path t =
+ let f = function
+ | (n, Hash h) ->
+ debugverbose (fun () ->
+ Util.msg "Reading xattr %s for %s\n" n (Fspath.toDebugString path));
+ let v' =
+ match Cache.get h with
+ | Some v ->
+ debugverbose (fun () -> Util.msg "Read xattr %s from cache\n" n);
+ v
+ | None ->
+ let v = Fs.xattr_get path n in
+ if Digest.string v <> h then
+ raise (Util.Transient (
+ Printf.sprintf "The value of extended attribute '%s' has \
+ changed on source file %s" n (Fspath.toPrintString path)))
+ else
+ Cache.add h v
+ in
+ (n, Loaded (v', h))
+ | x -> x
+ in
+ if Prefs.read syncXattrs then
+ wrapFail t (fun () -> optAttrsMap f t)
+ else
+ t
+
+let getAll t =
+ let f = function
+ | (n, Hash h) ->
+ begin match Cache.get h with
+ | Some v ->
+ debugverbose (fun () -> Util.msg "Got xattr %s from cache\n" n);
+ (n, Loaded (v, h))
+ | None -> raise Not_found
+ end
+ | x -> x
+ in
+ if Prefs.read syncXattrs then
+ wrapFail t (fun () -> optAttrsMap f t)
+ else
+ t
+
+let skipIgnoredXattr l =
+ Safelist.filter (fun (n, _) ->
+ let keep =
+ not (Pred.test xattrIgnorePred n) || (Pred.test xattrIgnorenotPred n) in
+ debugverbose (fun () ->
+ Util.msg "Xattr: attribute %s %s\n" n
+ (if keep then "not ignored" else "IGNORED by user request"));
+ keep) l
+
+let getXattrs path =
+ let sumSize total (_, len) = total + len in (* No fear of overflow *)
+ let xattrNameCompare (a, _) (b, _) = String.compare a b in
+ let sortXattrs = Safelist.sort xattrNameCompare in
+ let readXattr (n, len) =
+ if len > 16777211 then (* Max length of strings on 32-bit OCaml *)
+ failwith ("The value of extended attribute '" ^ n ^
+ "' is larger than 16 MB. This is currently not supported") else
+ let v = Fs.xattr_get path n in
+ let value =
+ if len <= 32 then String v
+ else
+ let h = Digest.string v in
+ let _ = Cache.add h v in
+ Hash h
+ in
+ (n, value)
+ in
+ wrapFail None (fun () ->
+ let names = Fs.xattr_list path |> skipIgnoredXattr |> sortXattrs in
+ let size = Size.ofInt (Safelist.fold_left sumSize 0 names) in
+ Some (Safelist.map readXattr names, size))
+
+let setXattrs path t =
+ match t with
+ | Some (l, _) -> begin
+ match getXattrs path with
+ | Some (xattrs0, _) -> begin
+ try
+ let xattrs = skipIgnoredXattr l in
+ xattrs |> Safelist.iter (fun ((n, v) as m) ->
+ if not (attrlist_mem m xattrs0) then
+ begin
+ debugverbose (fun () -> Util.msg "Writing xattr: %s\n" n);
+ match v with
+ | String x | Loaded (x, _) -> Fs.xattr_set path n x
+ | Hash _ -> () (* This should not happen; just skip it *)
+ end);
+ xattrs0 |> Safelist.iter (fun (n, _) ->
+ if not (Safelist.exists (fun (n', _) -> n' = n) xattrs) then
+ begin
+ debugverbose (fun () -> Util.msg "Removing xattr: %s\n" n);
+ Fs.xattr_remove path n
+ end)
+ with
+ | Fs.XattrNotSupported ->
+ raise (Util.Transient ("Extended attributes are not supported. \
+ You can set preference \"xattrs\" to false \
+ to avoid this error."))
+ | Failure msg ->
+ raise (Util.Transient (msg ^
+ ". You can set preference \"xattrs\" to false \
+ to avoid this error. You can add a 'debug' preference \
+ with value \"props+\" to see more details."))
+ end
+ | _ -> ()
+ end
+ | _ -> ()
+
+let set abspath t =
+ match t with
+ | Some _ when Prefs.read syncXattrs ->
+ debug (fun () ->
+ Util.msg "Setting xattrs for %s (%s)\n"
+ (Fspath.toDebugString abspath) (toDebugString t));
+ setXattrs abspath t
+ | _ -> ()
+
+let get abspath stats =
+ if Prefs.read syncXattrs &&
+ (stats.Unix.LargeFile.st_kind = Unix.S_REG ||
+ stats.Unix.LargeFile.st_kind = Unix.S_DIR)
+ (* Theoretically could sync xattrs on symlinks (if C stubs are
+ enhanced accordingly). However, in the current implementation
+ there are no props stored for symlinks in the archive. *)
+ then
+ let xattrs = getXattrs abspath in
+ debug (fun () ->
+ Util.msg "Xattr: got %s for %s\n"
+ (toDebugString xattrs) (Fspath.toDebugString abspath));
+ xattrs
+ else
+ None
+
+let check fspath path stats t =
+ match t with
+ | None -> ()
+ | Some _ ->
+ let abspath = Fspath.concat fspath path in
+ let t' = get abspath stats in
+ if not (similar t t') then
+ let msg = Format.sprintf ("Failed to set requested extended attributes \
+ on %s.\nThe following attributes were requested to be set:\n%s\n\
+ Actual attributes after setting:\n%s")
+ (Fspath.toPrintString abspath) (toStringVerb t) (toStringVerb t') in
+ raise (Util.Transient msg)
+
+end
+
+(* ------------------------------------------------------------------------- *)
+(* ACL *)
+(* ------------------------------------------------------------------------- *)
+
+let featACLValid = ref (fun _ _ -> None)
+
+let featACL =
+ Features.register "Sync: ACL" ~arcFormatChange:true
+ (Some (fun a b -> !featACLValid a b))
+
+let aclEnabled () = Features.enabled featACL
+
+let syncACL =
+ Prefs.createBool "acl" false
+ ~category:(`Advanced `Sync)
+ ~send:aclEnabled
+ "synchronize ACLs"
+ ("When this flag is set to \\verb|true|, the ACLs of files and \
+ directories are synchronized. The type of ACLs depends on the \
+ platform and filesystem support. On Unix-like platforms it \
+ can be NFSv4 ACLs, for example.")
+
+let () = featACLValid :=
+ fun _ enabledThis ->
+ if not enabledThis && Prefs.read syncACL then
+ Some ("You have requested synchronization of ACLs (the \
+ \"acl\" preference) but the server does not support this.")
+ else None
+
+module ACL : sig
+ include S
+ val get : Fspath.t -> Unix.LargeFile.stats -> t
+ val check : Fspath.t -> Path.local -> Unix.LargeFile.stats -> t -> unit
+ module Data : sig
+ include Propsdata.S
+ val keep : t -> unit
+ end
+end = struct
+
+module Data = struct
+ include Propsdata.ACL
+
+ let keep = function
+ | None | Some "" -> ()
+ | Some s -> keep s (* [keep] of Propsdata.ACL *)
+end
+
+(* The result value of this function must be deterministic for its input
+ (over both roots, and over time, as long as it is the same archive). *)
+let deflate acl =
+ if acl = "" then acl
+ else begin
+ let key = Digest.string acl in
+ Data.add key acl;
+ key
+ end
+
+let inflate t = if t = "" then t else Data.find t
+
+(* None indicates ACLs are not supported. This is not synchronized.
+ An empty string represents a trivial/removed ACL. This will be
+ synchronized. *)
+type t = string option
+
+let dummy = None
+
+let m = Umarshal.cond aclEnabled dummy Umarshal.(option string)
+
+let hash t h = if Prefs.read syncACL then Uutil.hash2 (Uutil.hash t) h else h
+
+let toString = function
+ | Some "" -> " <trivial ACL>"
+ | Some s -> " A=" ^ (inflate s)
+ | None -> if not (Prefs.read syncACL) then "" else " !No ACL support!"
+
+let syncedPartsToString = toString
+
+let aclIds = Str.regexp
+ "\\(\\(user\\|group\\):\\)[^:]+:\\([^:]+:[^:]+:[^:]+:[0-9]+\\($\\|,\\)\\)"
+let removeAclNames s =
+ Str.global_replace aclIds "\\1\\3" (inflate s)
+
+let similar2 t t' =
+ Prefs.read numericIds
+ &&
+ (* Try to strip out the user/group names and compare only numeric ids.
+ Format of ACE is expected to be as follows:
+ user:name:rw------------:------I:allow:1300 *)
+ String.equal (removeAclNames t) (removeAclNames t')
+
+let similar t t' =
+ not (Prefs.read syncACL)
+ ||
+ (* This is a direct string comparison. It does not take into account
+ changes in ACE ordering because ACE ordering is considered to be
+ significant and different ordering means different ACL. *)
+ let result =
+ match t, t' with
+ | None, None -> true
+ | Some acl, Some acl' when String.equal acl acl' -> true
+ | Some acl, Some acl' -> similar2 acl acl'
+ | _ -> false in
+ debugverbose (fun () ->
+ Util.msg "Comparing ACLs |%s| and |%s| => %s%s\n"
+ (toString t) (toString t')
+ (match result with true -> "same" | false -> "different")
+ (if Prefs.read numericIds then
+ " (comparing numeric user/group ids)" else ""));
+ result
+
+let override t t' = t'
+
+let strip t = if Prefs.read syncACL then t else None
+
+let diff t t' = if similar t t' then None else t'
+
+let wrapFail f =
+ try f () with
+ | Failure msg ->
+ raise (Util.Transient (msg ^
+ ". You can set preference \"acl\" to false to avoid this error."))
+
+let getACLAsText path =
+ wrapFail (fun () ->
+ match Fs.acl_get_text path with
+ | "-1" -> None (* "-1" is used as a special code for no ACL support *)
+ | acl -> Some (deflate acl))
+
+let setACLFromText path t =
+ match t with
+ | Some acl -> wrapFail (fun () -> Fs.acl_set_text path (inflate acl))
+ | _ -> ()
+
+let set abspath t =
+ match t with
+ | Some _ when Prefs.read syncACL ->
+ debug (fun () ->
+ Util.msg "Setting ACL for %s from text |%s|\n"
+ (Fspath.toDebugString abspath) (toString t));
+ setACLFromText abspath t
+ | _ -> ()
+
+let get abspath stats =
+ if Prefs.read syncACL &&
+ (stats.Unix.LargeFile.st_kind = Unix.S_REG ||
+ stats.Unix.LargeFile.st_kind = Unix.S_DIR)
+ (* Theoretically could sync ACLs on symlinks (if C stubs are
+ enhanced accordingly). However, in the current implementation
+ there are no props stored for symlinks in the archive. *)
+ then
+ let acltext = getACLAsText abspath in
+ debug (fun () ->
+ Util.msg "Got text ACL |%s| for %s\n"
+ (toString acltext) (Fspath.toDebugString abspath));
+ acltext
+ else
+ None
+
+let check fspath path stats acl =
+ match acl with
+ | None -> ()
+ | Some _ ->
+ let abspath = Fspath.concat fspath path in
+ let acl' = get abspath stats in
+ if not (similar acl acl') then
+ let msg = Format.sprintf
+ "Failed to set ACL of file %s to\n%s\n\
+ The ACL was instead set to\n%s\n\
+ The filesystem probably does not have full ACL support or \
+ the synchronized ACL is of different type, or there \
+ are other incompatibilities between systems. \
+ If this is a filesystem without correct ACL support, you \
+ should set the \"acl\" preference to false.%s"
+ (Fspath.toPrintString abspath) (toString acl) (toString acl')
+ (if Prefs.read numericIds then "" else " Or, you may want to \
+ try setting the \"numericids\" preference to true if the \
+ user/group names don't match on both systems.") in
+ raise (Util.Transient msg)
end
@@ -665,7 +1282,12 @@ end
(* Properties *)
(* ------------------------------------------------------------------------- *)
-type t =
+(* IMPORTANT!
+ This is the 2.51-compatible version of type [Props.t]. It must always remain
+ exactly the same as the type [Props.t] in version 2.51.5. This means that if
+ any of the types it is composed of changes then for each changed type also a
+ 2.51-compatible version must be created. *)
+type t251 =
{ perm : Perm.t;
uid : Uid.t;
gid : Gid.t;
@@ -673,14 +1295,82 @@ type t =
typeCreator : TypeCreator.t;
length : Uutil.Filesize.t }
+type t =
+ { perm : Perm.t;
+ uid : Uid.t;
+ gid : Gid.t;
+ time : Time.t;
+ typeCreator : TypeCreator.t;
+ length : Uutil.Filesize.t;
+ ctime : CTime.t;
+ xattr : Xattr.t;
+ acl : ACL.t;
+ }
+
+type _ props = t
+type basic = [`Basic] props
+type x = [`ExtLoaded] props
+
+let m = Umarshal.(prod4
+ (prod6 Perm.m Uid.m Gid.m Time.m TypeCreator.m Uutil.Filesize.m id id)
+ (cond (fun () -> xattrEnabled () || aclEnabled ()) CTime.dummy CTime.m)
+ Xattr.m
+ ACL.m
+ (fun {perm; uid; gid; time; typeCreator; length; ctime; xattr; acl} ->
+ ((perm, uid, gid, time, typeCreator, length), ctime, xattr, acl))
+ (fun ((perm, uid, gid, time, typeCreator, length), ctime, xattr, acl) ->
+ {perm; uid; gid; time; typeCreator; length; ctime; xattr; acl}))
+
+let mbasic = m
+let mx = m
+
+let to_compat251 (p : t) : t251 =
+ { perm = p.perm;
+ uid = p.uid;
+ gid = p.gid;
+ time = p.time;
+ typeCreator = p.typeCreator;
+ length = p.length }
+
+let of_compat251 (p : t251) : t =
+ { perm = p.perm;
+ uid = p.uid;
+ gid = p.gid;
+ time = p.time;
+ typeCreator = p.typeCreator;
+ length = p.length;
+ ctime = CTime.dummy;
+ xattr = Xattr.dummy;
+ acl = ACL.dummy;
+ }
+
let template perm =
{ perm = perm; uid = Uid.dummy; gid = Gid.dummy;
time = Time.dummy; typeCreator = TypeCreator.dummy;
- length = Uutil.Filesize.dummy }
+ length = Uutil.Filesize.dummy;
+ ctime = CTime.dummy;
+ xattr = Xattr.dummy;
+ acl = ACL.dummy;
+ }
let dummy = template Perm.dummy
let hash p h =
+ h
+ |> ACL.hash p.acl
+ |> Xattr.hash p.xattr
+ |> TypeCreator.hash p.typeCreator
+ |> Time.hash p.time
+ |> Gid.hash p.gid
+ |> Uid.hash p.uid
+ |> Perm.hash p.perm
+
+(* IMPORTANT!
+ This is the 2.51-compatible version of [hash]. It must always produce exactly
+ the same result as the [hash] in version 2.51.5.
+ If code changes elsewhere make this function produce a different result then
+ it must be updated accordingly to again return the 2.51-compatible result. *)
+let hash251 (p : t251) h =
Perm.hash p.perm
(Uid.hash p.uid
(Gid.hash p.gid
@@ -697,6 +1387,10 @@ let similar p p' =
Time.similar p.time p'.time
&&
TypeCreator.similar p.typeCreator p'.typeCreator
+ &&
+ Xattr.similar p.xattr p'.xattr
+ &&
+ ACL.similar p.acl p'.acl
let override p p' =
{ perm = Perm.override p.perm p'.perm;
@@ -704,7 +1398,11 @@ let override p p' =
gid = Gid.override p.gid p'.gid;
time = Time.override p.time p'.time;
typeCreator = TypeCreator.override p.typeCreator p'.typeCreator;
- length = p'.length }
+ length = p'.length;
+ ctime = CTime.override p.ctime p'.ctime;
+ xattr = Xattr.override p.xattr p'.xattr;
+ acl = ACL.override p.acl p'.acl;
+ }
let strip p =
{ perm = Perm.strip p.perm;
@@ -712,29 +1410,37 @@ let strip p =
gid = Gid.strip p.gid;
time = Time.strip p.time;
typeCreator = TypeCreator.strip p.typeCreator;
- length = p.length }
+ length = p.length;
+ ctime = p.ctime;
+ xattr = Xattr.strip p.xattr;
+ acl = ACL.strip p.acl;
+ }
let toString p =
Printf.sprintf
- "modified on %s size %-9.0f %s%s%s%s"
+ "modified on %s size %-9.0f %s%s%s%s%s%s"
(Time.toString p.time)
(Uutil.Filesize.toFloat p.length)
(Perm.toString p.perm)
(Uid.toString p.uid)
(Gid.toString p.gid)
+ (Xattr.toString p.xattr)
(TypeCreator.toString p.typeCreator)
+ (ACL.toString p.acl)
let syncedPartsToString p =
let tm = Time.syncedPartsToString p.time in
Printf.sprintf
- "%s%s size %-9.0f %s%s%s%s"
+ "%s%s size %-9.0f %s%s%s%s%s%s"
(if tm = "" then "" else "modified at ")
tm
(Uutil.Filesize.toFloat p.length)
(Perm.syncedPartsToString p.perm)
(Uid.syncedPartsToString p.uid)
(Gid.syncedPartsToString p.gid)
+ (Xattr.syncedPartsToString p.xattr)
(TypeCreator.syncedPartsToString p.typeCreator)
+ (ACL.syncedPartsToString p.acl)
let diff p p' =
{ perm = Perm.diff p.perm p'.perm;
@@ -742,49 +1448,94 @@ let diff p p' =
gid = Gid.diff p.gid p'.gid;
time = Time.diff p.time p'.time;
typeCreator = TypeCreator.diff p.typeCreator p'.typeCreator;
- length = p'.length }
-
-let get stats infos =
- { perm = Perm.get stats infos;
- uid = Uid.get stats infos;
- gid = Gid.get stats infos;
- time = Time.get stats infos;
- typeCreator = TypeCreator.get stats infos;
+ length = p'.length;
+ ctime = p'.ctime;
+ xattr = Xattr.diff p.xattr p'.xattr;
+ acl = ACL.diff p.acl p'.acl;
+ }
+
+let get' stats =
+ { perm = Perm.get stats;
+ uid = Uid.get stats;
+ gid = Gid.get stats;
+ time = Time.get stats;
+ typeCreator = TypeCreator.dummy;
length =
if stats.Unix.LargeFile.st_kind = Unix.S_REG then
Uutil.Filesize.fromStats stats
else
- Uutil.Filesize.zero }
+ Uutil.Filesize.zero;
+ ctime = CTime.dummy;
+ xattr = Xattr.dummy;
+ acl = ACL.dummy;
+ }
+
+(* Important note about [fspath] and [path] arguments to [get]:
+ If the path points to a symlink then the [stats] argument may be the
+ result of either stat(2) or lstat(2) on said path. When this distinction
+ is important then it can be easily checked by seeing if [stats.st_kind]
+ is S_LNK or not. If it is not S_LNK then any syscalls/functions on this
+ path are expected to follow symlinks (and not follow otherwise). *)
+let get ?(archProps = dummy) fspath path stats infos =
+ let abspath = Fspath.concat fspath path in
+ (* Note for future: ctime could very well be included in [get'] but it
+ does not seem necessary at the moment. See the comment at
+ [CTime.override]. *)
+ let ctime = CTime.get stats in
+ let ctimeChanged = not (CTime.same_time ctime archProps.ctime) in
+ let props = get' stats in
+ { props with
+ typeCreator = TypeCreator.get stats infos;
+ ctime;
+ xattr =
+ if ctimeChanged || not Xattr.ctimeDetect then Xattr.get abspath stats
+ else archProps.xattr;
+ acl =
+ if ctimeChanged then ACL.get abspath stats
+ else archProps.acl;
+ }
+
+let getWithRess stats osXinfo =
+ let props = get' stats in
+ { props with
+ typeCreator = TypeCreator.get stats osXinfo;
+ }
let set fspath path kind p =
- Uid.set fspath path kind p.uid;
- Gid.set fspath path kind p.gid;
- TypeCreator.set fspath path kind p.typeCreator;
- Time.set fspath path kind p.time;
- Perm.set fspath path kind p.perm
+ let abspath = Fspath.concat fspath path in
+ Uid.set abspath p.uid;
+ Gid.set abspath p.gid;
+ TypeCreator.set fspath path p.typeCreator;
+ Xattr.set abspath p.xattr;
+ Time.set abspath p.time;
+ Perm.set abspath kind p.perm;
+ (* ACLs must always be set after chmod,
+ * otherwise chmod may replace the ACL. *)
+ ACL.set abspath p.acl
(* Paranoid checks *)
let check fspath path stats p =
+ ACL.check fspath path stats p.acl;
+ Xattr.check fspath path stats p.xattr;
Time.check fspath path stats p.time;
Perm.check fspath path stats p.perm
let init someHostIsRunningWindows =
Perm.init someHostIsRunningWindows;
Uid.init someHostIsRunningWindows;
- Gid.init someHostIsRunningWindows;
- Time.init someHostIsRunningWindows;
- TypeCreator.init someHostIsRunningWindows
+ Gid.init someHostIsRunningWindows
let fileDefault = template Perm.fileDefault
let fileSafe = template Perm.fileSafe
let dirDefault = template Perm.dirDefault
let same_time p p' = Time.same p.time p'.time
+let same_ctime p p' = CTime.same_time p.ctime p'.ctime
let length p = p.length
let setLength p l = {p with length=l}
let time p = Time.extract p.time
-let setTime p t = {p with time = Time.replace p.time t}
+let setTime p p' = {p with time = Time.replace p.time (time p'); ctime = p'.ctime}
let perms p = Perm.extract p.perm
@@ -794,6 +1545,72 @@ let dontChmod = Perm.dontChmod
let validatePrefs = Perm.validatePrefs
+let loadExtData fspath path p =
+ let abspath = Fspath.concat fspath path in
+ { p with
+ xattr = Xattr.readAll abspath p.xattr;
+ }
+
+let purgeExtData p =
+ { p with
+ xattr = Xattr.purge p.xattr;
+ }
+
+let withExtData p =
+ { p with
+ xattr = Xattr.getAll p.xattr;
+ }
+
+(* ------------------------------------------------------------------------- *)
+(* Shared data for props *)
+(* ------------------------------------------------------------------------- *)
+
+module Data = struct
+
+ type e = string * (string * string) list
+ type d = e list
+
+ let m = Umarshal.(list (prod2 string (list (prod2 string string id id)) id id))
+
+ let enabled () =
+ xattrEnabled () || aclEnabled ()
+
+ let extract k pd = try Safelist.assoc k pd with Not_found -> []
+
+ let extern kind =
+ let add_nonempty k v pd =
+ match v with
+ | [] -> pd
+ | _ -> (k, v) :: pd
+ in
+ []
+ |> add_nonempty "xattr" (Xattr.Data.get kind)
+ |> add_nonempty "ACL" (ACL.Data.get kind)
+
+ let intern pd =
+ Xattr.Data.set (extract "xattr" pd);
+ ACL.Data.set (extract "ACL" pd);
+ ()
+
+ let merge pd =
+ Xattr.Data.merge (extract "xattr" pd);
+ ACL.Data.merge (extract "ACL" pd);
+ ()
+
+ let gcInit () =
+ Xattr.Data.clear `Kept;
+ ACL.Data.clear `Kept;
+ ()
+
+ let gcKeep p =
+ (* Xattr data cache is not persisted *)
+ ACL.Data.keep p.acl;
+ ()
+
+ let gcDone () = extern `Kept
+
+end
+
(* ------------------------------------------------------------------------- *)
(* Directory change stamps *)
(* ------------------------------------------------------------------------- *)
@@ -803,6 +1620,8 @@ let validatePrefs = Perm.validatePrefs
type dirChangedStamp = Uutil.Filesize.t
+let mdirChangedStamp = Uutil.Filesize.m
+
let freshDirStamp () =
let t =
(Unix.gettimeofday () +. sqrt 2. *. float (Unix.getpid ())) *. 1000.
diff --git a/src/props.mli b/src/props.mli
index e881c39..636d8eb 100644
--- a/src/props.mli
+++ b/src/props.mli
@@ -3,41 +3,86 @@
(* File properties: time, permission, length, etc. *)
-type t
-val dummy : t
+type t251
+type _ props
+type basic = [`Basic] props
+type t = [`Full] props
+type x = [`ExtLoaded] props
+val m : t Umarshal.t
+val mbasic : basic Umarshal.t
+val mx : x Umarshal.t
+val to_compat251 : _ props -> t251
+val of_compat251 : t251 -> _ props
+val dummy : _ props
val hash : t -> int -> int
+val hash251 : t251 -> int -> int
val similar : t -> t -> bool
-val override : t -> t -> t
+val override : _ props -> 'a props -> 'a props
val strip : t -> t
-val diff : t -> t -> t
+val diff : t -> x -> x
val toString : t -> string
val syncedPartsToString : t -> string
-val set : Fspath.t -> Path.local -> [`Set | `Update] -> t -> unit
-val get : Unix.LargeFile.stats -> Osx.info -> t
-val check : Fspath.t -> Path.local -> Unix.LargeFile.stats -> t -> unit
+val set : Fspath.t -> Path.local -> [`Set | `Update] -> x -> unit
+val get' : Unix.LargeFile.stats -> basic
+val get : ?archProps:t -> Fspath.t -> Path.local -> Unix.LargeFile.stats -> Osx.info -> t
+val getWithRess : Unix.LargeFile.stats -> Osx.info -> basic
+val check : Fspath.t -> Path.local -> Unix.LargeFile.stats -> x -> unit
val init : bool -> unit
-val same_time : t -> t -> bool
-val length : t -> Uutil.Filesize.t
+val loadExtData : Fspath.t -> Path.local -> t -> x
+val purgeExtData : x -> t
+val withExtData : t -> x
+(* [withExtData] will raise Not_found if some ext data is missing. In that
+ case, [loadExtData] must be used to load any missing ext data. *)
+
+val same_time : _ props -> t -> bool
+val same_ctime : _ props -> t -> bool
+val length : _ props -> Uutil.Filesize.t
val setLength : t -> Uutil.Filesize.t -> t
-val time : t -> float
-val setTime : t -> float -> t
-val perms : t -> int
+val time : _ props -> float
+val setTime : t -> _ props -> t
+val perms : _ props -> int
-val fileDefault : t
+val fileDefault : basic
val fileSafe : t
-val dirDefault : t
+val dirDefault : basic
val syncModtimes : bool Prefs.t
val permMask : int Prefs.t
val dontChmod : bool Prefs.t
+val syncXattrs : bool Prefs.t
+val syncACL : bool Prefs.t
+
+val aclEnabled : unit -> bool
+val xattrEnabled : unit -> bool
+
+val xattrIgnorePred : Pred.t
+val xattrIgnorenotPred : Pred.t
(* We are reusing the directory length to store a flag indicating that
the directory is unchanged *)
type dirChangedStamp
+val mdirChangedStamp : dirChangedStamp Umarshal.t
val freshDirStamp : unit -> dirChangedStamp
val changedDirStamp : dirChangedStamp
val setDirChangeFlag : t -> dirChangedStamp -> int -> t * bool
val dirMarkedUnchanged : t -> dirChangedStamp -> int -> bool
val validatePrefs: unit -> unit
+
+module Data : sig
+ type e
+ type d = e list
+
+ val m : d Umarshal.t
+
+ val enabled : unit -> bool
+
+ val extern : [`New] -> d
+ val intern : d -> unit
+ val merge : d -> unit
+
+ val gcInit : unit -> unit
+ val gcKeep : t -> unit
+ val gcDone : unit -> d
+end
diff --git a/src/props_acl.c b/src/props_acl.c
new file mode 100644
index 0000000..b3a3bba
--- /dev/null
+++ b/src/props_acl.c
@@ -0,0 +1,821 @@
+/* Unison file synchronizer: src/props_acl.c */
+/* Copyright 2020-2022, Tõivo Leedjärv
+
+ This program is free software: you can redistribute it and/or modify
+ it under the terms of the GNU General Public License as published by
+ the Free Software Foundation, either version 3 of the License, or
+ (at your option) any later version.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with this program. If not, see <http://www.gnu.org/licenses/>.
+*/
+
+/* Supporting POSIX draft ACLs is not a goal, but may incidentally work
+ * on some platforms. Only NFSv4 ACLs and Windows ACLs are intended to be
+ * supported.
+ *
+ * On Solarish, both NFSv4 ACLs and POSIX draft ACLs are supported.
+ * There is even support for cross-synchronizing between NFSv4 and
+ * POSIX draft ACLs, but this support is currently disabled in props.ml
+ * by checking if the resulting ACL matches the requested ACL (the check
+ * fails with cross-synchronization).
+ *
+ * On FreeBSD and NetBSD, NFSv4 ACLs are supported. There is only limited
+ * support for synchronizing POSIX draft ACLs (no default ACLs).
+ *
+ * On Darwin, extended ACLs are supported.
+ *
+ * On Windows, NTFS ACLs are supported via SDDL format. Only explicit
+ * ACEs are synchronized, ignoring inherited ACEs completely. Users and
+ * groups are represented as SID strings in SDDL, not as names.
+ */
+
+/* The external interface is defined as follows. Every supported platform
+ * must implement this interface. ACL format can be platform-specific,
+ * which will prevent cross-platform synchronization but still allows
+ * synchronization within the platform.
+ *
+ *
+ * SET the ACL
+ * ===========
+ * unit unison_acl_from_text(String path, String acl)
+ *
+ * Set the requested ACL on the requested file or directory. The ACL
+ * must be in the same format as that returned by unison_acl_to_text().
+ * Empty string ACL means <no ACL> and results in removal of any
+ * existing ACL on the requested file or directory.
+ * Symbolic links are followed.
+ *
+ * Input parameters
+ * path - absolute path of a file or directory
+ * acl - text representation of ACL to set on the path
+ *
+ * Return value
+ * No return value.
+ *
+ * Exceptions
+ * There are no mandatory exception conditions.
+ * Failure MAY voluntarily be raised for example when:
+ * Can't access file to set/remove ACL
+ * ACL not supported
+ * Error setting ACL
+ * Error removing ACL
+ * Error converting ACL from text
+ *
+ *
+ * GET the ACL
+ * ===========
+ * String unison_acl_to_text(String path)
+ *
+ * Get the current ACL on the requested file or directory. The ACL
+ * must be returned as a stable and deterministic text representation
+ * that meets the following criteria:
+ * - with multiple requests on the same file, the representation is
+ * always the same, unless the underlying ACL changes;
+ * - the same ACL on different files has the same representation.
+ * Symbolic links are followed.
+ *
+ * Input parameters
+ * path - absolute path of a file or directory
+ *
+ * Return value
+ * The text representation of the ACL;
+ * or the value of macro UNSN_ACL_EMPTY (or empty string "") meaning
+ * <no ACL> (or only trivial ACL)
+ * or the value of macro UNSN_ACL_NOT_SUPPORTED (currently "-1") if
+ * ACL is not supported on the requested path.
+ *
+ * Exceptions
+ * Failure MUST be raised when:
+ * Can't access file to get ACL
+ * Failure MAY voluntarily be raised for example when:
+ * Error getting ACL
+ * Error converting ACL to text
+ * If Failure is not raised on some error condition then an empty
+ * string "" MUST NOT be returned under any circumstances; return
+ * UNSN_ACL_NOT_SUPPORTED instead.
+ *
+ *
+ * ===========
+ * Definition of ACL format
+ *
+ * The format of ACL text representation is completely free as long as
+ * following constraints are met:
+ * - output of unison_acl_to_text() can be used as
+ * input to unison_acl_from_text()
+ * - ACL synchronization is done only on the same platform.
+ *
+ * If ACLs must be synchronized between different platforms then the
+ * currently used universal ACL format matches the definition from
+ * illumos acl(5) man page [https://illumos.org/man/5/acl]. This applies
+ * to both POSIX draft ACLs and NFSv4 ACLs. See the note on cross-platform
+ * synchronization below.
+ *
+ * ACL is always in the form
+ *
+ * acl_entry[,acl_entry]...
+ *
+ * Each acl_entry may be suffixed with a colon and userid/groupid.
+ *
+ * Examples:
+ *
+ * POSIX draft ACL
+ *
+ * user:tom:rw-,mask:rwx,group:staff:r-x:450
+ *
+ * NFSv4 ACL
+ *
+ * user:lp:rw------------:------I:allow:1300,
+ * owner@:--x-----------:------I:deny,
+ * owner@:rw-p---A-W-Co-:-------:allow,
+ * user:marks:r-------------:------I:deny:1270,
+ * group@:r-------------:-------:allow,
+ * everyone@:r-----a-R-c--s:-------:allow
+ *
+ * (note that the example is folded, but it should actually be
+ * returned as one string line without newlines)
+ *
+ *
+ * ===========
+ * On cross-platform synchronization
+ *
+ * Currently there is no canonical ACL representation created specifically
+ * for Unison. Existing platform APIs are used as much as possible, without
+ * custom formatting and parsing.
+ * A specific Unison ACL format could be truly common across platforms.
+ *
+ * If extended ACL synchronization capability is desired in the future then
+ * it is only required to change the output of unison_acl_to_text() and the
+ * input parsing in unison_acl_from_text().
+ * The Unison archive format will not have to be changed as long as the
+ * entire ACL and any eventual metadata is encoded within one string.
+ * It is neither necessary to change the ACL code in props.ml.
+ *
+ * The issues of such cross-platform (e.g. between Windows and Unix-like)
+ * synchronization lie not in the representation format, though. It is easy
+ * enough to interpret the permission sets of NFSv4 and Windows ACLs in a
+ * similar, equivalent way. It can be much more difficult to interpret the
+ * subjects (users and groups) in a meaningful way. Purely for
+ * synchronization, this can still work on some platforms, e.g. Solaris,
+ * which allow the use of SIDs in ACL definition.
+ */
+
+#include <caml/memory.h>
+#include <caml/alloc.h>
+#include <caml/mlvalues.h>
+#include <caml/fail.h>
+
+
+#if defined(sun) || defined(__sun) /* Solarish, all illumos-based OS, */
+#define __Solaris__ /* OpenIndiana, OmniOS, SmartOS, ... */
+#endif
+
+/* Primitive check only, without explicitly checking for
+ * POSIX or NFSv4. NFSv4-style ACLs are expected
+ * but POSIX draft ACLs may work to some extent. */
+#undef UNSN_HAS_FS_ACL
+#if defined(__Solaris__) || defined(__FreeBSD__) || defined(__APPLE__)
+#define UNSN_HAS_FS_ACL
+#endif
+
+#if defined(__NetBSD__)
+#include <unistd.h>
+#if defined(_PC_ACL_NFS4)
+#define UNSN_HAS_FS_ACL
+#endif
+#endif
+
+#if defined(_WIN32)
+#define UNSN_HAS_FS_ACL
+#endif
+
+
+#define UNSN_ACL_NOT_SUPPORTED caml_copy_string("-1")
+
+
+#ifndef UNSN_HAS_FS_ACL
+
+CAMLprim value unison_acl_from_text(value path, value acl)
+{
+ CAMLparam0();
+ CAMLreturn(Val_unit);
+}
+
+CAMLprim value unison_acl_to_text(value path)
+{
+ CAMLparam0();
+ CAMLreturn(UNSN_ACL_NOT_SUPPORTED);
+}
+
+#else
+
+
+#define UNSN_ACL_EMPTY caml_copy_string("")
+
+
+#if defined(_WIN32)
+
+/*#define ACL_DEBUG*/
+
+#ifndef UNICODE
+#define UNICODE
+#endif
+#ifndef _UNICODE
+#define _UNICODE
+#endif
+
+#include <windows.h>
+#include <aclapi.h>
+#include <sddl.h>
+#include <strsafe.h>
+
+#include <caml/version.h>
+#if OCAML_VERSION < 41300
+#define CAML_INTERNALS /* was needed from OCaml 4.06 to 4.12 */
+#endif
+#include <caml/osdeps.h>
+
+#ifdef ACL_DEBUG
+#include <stdio.h>
+#endif
+
+static void unsn_acl_fail(char *msg, DWORD err)
+{
+ DWORD flags;
+ char *sys_msg;
+ DWORD sys_len;
+ char fail_msg[160];
+ const size_t LEN = sizeof(fail_msg) / sizeof(fail_msg[0]);
+
+ flags =
+ FORMAT_MESSAGE_ALLOCATE_BUFFER |
+ FORMAT_MESSAGE_FROM_SYSTEM |
+ FORMAT_MESSAGE_IGNORE_INSERTS;
+
+ sys_len = FormatMessageA(flags, NULL, err, 0, (char *) &sys_msg, 0, NULL);
+ if (!sys_len) {
+ StringCbPrintfA(fail_msg, LEN, "%s (Windows error code: %d)", msg, err);
+ } else {
+ /* Assume last 3 characters are ".\r\n" (doesn't matter if they aren't),
+ * and remove them. */
+ if (sys_len > 3) {
+ sys_msg[sys_len - 3] = '\0';
+ }
+
+ StringCbPrintfA(fail_msg, LEN,
+ "%s (Windows error code: %d) %s", msg, err, sys_msg);
+ LocalFree(sys_msg);
+ }
+
+ caml_failwith(fail_msg);
+}
+
+CAMLprim value unison_acl_from_text(value path, value acl)
+{
+ CAMLparam2(path, acl);
+ wchar_t *wpath = caml_stat_strdup_to_utf16(String_val(path));
+ wchar_t *wacl = caml_stat_strdup_to_utf16(String_val(acl));
+ PCWSTR acl_text;
+ PSECURITY_DESCRIPTOR sd;
+ SECURITY_DESCRIPTOR_CONTROL sdc;
+ DWORD sdc_rev;
+ PSID owner = NULL, group = NULL;
+ PACL DACL;
+ BOOL DACLpresent = FALSE, isDef;
+ BOOL ok = TRUE;
+ SECURITY_INFORMATION si = 0;
+ DWORD res;
+
+#ifdef ACL_DEBUG
+ printf_s(" ===> Setting ACL for |%ls|\n", wpath);
+ printf_s(" ---> Input ACL value |%ls|\n", wacl);
+#endif
+
+ if (wcslen(wacl) == 0) {
+ acl_text = L"D:"; /* SDDL representation of empty ACL */
+ } else {
+ acl_text = wacl;
+ }
+#ifdef ACL_DEBUG
+ printf_s(" ---> Setting ACL value |%ls|\n", acl_text);
+#endif
+
+ if (!ConvertStringSecurityDescriptorToSecurityDescriptorW(acl_text,
+ SDDL_REVISION_1, &sd, NULL)) {
+ caml_stat_free(wpath);
+ caml_stat_free(wacl);
+ unsn_acl_fail("Error converting ACL from text", GetLastError());
+ }
+
+ caml_stat_free(wacl);
+
+ ok = ok && GetSecurityDescriptorDacl(sd, &DACLpresent, &DACL, &isDef);
+ ok = ok && GetSecurityDescriptorControl(sd, &sdc, &sdc_rev);
+
+ if (!ok || !DACLpresent) {
+ LocalFree(sd);
+ caml_stat_free(wpath);
+
+ caml_failwith("Error converting ACL from text (no ACL info present?)");
+ }
+
+ si |= DACL_SECURITY_INFORMATION;
+
+ if (sdc & SE_DACL_PROTECTED) {
+ si |= PROTECTED_DACL_SECURITY_INFORMATION;
+ } else {
+ si |= UNPROTECTED_DACL_SECURITY_INFORMATION;
+ }
+
+ res = SetNamedSecurityInfoW(wpath, SE_FILE_OBJECT,
+ si, owner, group, DACL, NULL);
+
+ LocalFree(sd);
+ caml_stat_free(wpath);
+
+ if (res == ERROR_ACCESS_DENIED) {
+ caml_failwith("Error setting ACL: access denied. The process may require "
+ "Administrator or \"Restore files\" privileges to set the ACL");
+ }
+
+ if (res != ERROR_SUCCESS) {
+ unsn_acl_fail("Error setting ACL", res);
+ }
+
+ CAMLreturn(Val_unit);
+}
+
+CAMLprim value unison_acl_to_text(value path)
+{
+ CAMLparam1(path);
+ CAMLlocal1(result);
+ wchar_t *wpath = caml_stat_strdup_to_utf16(String_val(path));
+ int i, aceCnt;
+ PWSTR acl_text;
+ PSECURITY_DESCRIPTOR sd;
+ SECURITY_DESCRIPTOR_CONTROL sdc;
+ DWORD sdc_rev;
+ PSID owner, group;
+ PACL DACL;
+ ACL_SIZE_INFORMATION aclInfo;
+ PVOID ace;
+ SECURITY_INFORMATION si = DACL_SECURITY_INFORMATION;
+ DWORD res1, err;
+ BOOL res2;
+
+#ifdef ACL_DEBUG
+ printf_s(" ===> Getting ACL for %ls\n", wpath);
+#endif
+
+ res1 = GetNamedSecurityInfoW(wpath, SE_FILE_OBJECT, si,
+ &owner, &group, &DACL, NULL, &sd);
+ caml_stat_free(wpath);
+
+ if (res1 != ERROR_SUCCESS || sd == NULL) {
+ unsn_acl_fail("Error getting ACL", res1);
+ }
+
+#ifdef ACL_DEBUG
+ res2 = ConvertSecurityDescriptorToStringSecurityDescriptorW(sd,
+ SDDL_REVISION_1, si, &acl_text, NULL);
+
+ if (acl_text != NULL) {
+ printf_s(" ---> Initial ACL text representation: %ls\n", acl_text);
+
+ LocalFree(acl_text);
+ }
+#endif /* ACL_DEBUG */
+
+ if (DACL == NULL) {
+ LocalFree(sd);
+
+#ifdef ACL_DEBUG
+ printf_s(" ---> ACL not supported\n");
+#endif
+ CAMLreturn(UNSN_ACL_NOT_SUPPORTED);
+ }
+
+ if (!GetAclInformation(DACL, &aclInfo, sizeof(aclInfo), AclSizeInformation)) {
+ LocalFree(sd);
+ unsn_acl_fail("Error getting ACL information", GetLastError());
+ }
+ aceCnt = aclInfo.AceCount;
+
+ /* Remove all inherited ACEs -- those cannot be restored in the other
+ * replica, they are inherited from the parent directory. */
+ for (i = aclInfo.AceCount - 1; i >= 0; i--) {
+ if (!GetAce(DACL, i, &ace)) {
+#ifdef ACL_DEBUG
+ printf_s("GetAce failed (Windows error code %d)\n", GetLastError());
+#endif
+ } else if (((PACE_HEADER) ace)->AceFlags & INHERITED_ACE) {
+ if (!DeleteAce(DACL, i)) {
+#ifdef ACL_DEBUG
+ printf_s("DeleteAce failed (Windows error code %d)\n", GetLastError());
+#endif
+ } else {
+ aceCnt--;
+ }
+ }
+ }
+
+ /* Even when individual inherited ACEs have been removed, the entire ACL
+ * may have been marked as AUTO_INHERITED. Remove this flag to make
+ * synchronization paranoid checks more reliable. It is unknown if it
+ * can cause synchronization failures, but it doesn't matter - inherited
+ * ACLs can't be propagated in any case. */
+ if (!SetSecurityDescriptorControl(sd, SE_DACL_AUTO_INHERITED, 0)) {
+#ifdef ACL_DEBUG
+ unsn_acl_fail("Error in ACL control information", GetLastError());
+#endif
+ }
+
+ if (aceCnt == 0) { /* No explicit entries */
+ if (!GetSecurityDescriptorControl(sd, &sdc, &sdc_rev)) {
+ LocalFree(sd);
+ unsn_acl_fail("Error getting ACL control information", GetLastError());
+ }
+
+ if (!(sdc & SE_DACL_PROTECTED)) { /* No control flags we care about */
+ LocalFree(sd);
+
+#ifdef ACL_DEBUG
+ printf_s(" ---> Empty ACL (no explicit ACE, may have inherited ACE)\n");
+#endif
+ CAMLreturn(UNSN_ACL_EMPTY); /* Empty ACL (or only inherited) */
+ }
+ }
+
+ res2 = ConvertSecurityDescriptorToStringSecurityDescriptor(sd,
+ SDDL_REVISION_1, si, &acl_text, NULL);
+ err = GetLastError();
+
+ LocalFree(sd);
+
+ if (!res2 || (acl_text == NULL)) {
+ unsn_acl_fail("Error converting ACL to text", err);
+ }
+
+#ifdef ACL_DEBUG
+ printf_s(" ---> Final ACL text representation: %ls\n", acl_text);
+#endif
+
+ result = caml_copy_string_of_utf16(acl_text);
+
+ LocalFree(acl_text);
+
+ CAMLreturn(result);
+}
+
+
+#else /* defined(_WIN32) */
+
+
+#if defined(__Solaris__) || defined(__APPLE__)
+#include <fcntl.h>
+#include <sys/stat.h>
+#endif
+
+#if defined(__Solaris__) || defined(__FreeBSD__) || defined(__NetBSD__) || defined(__APPLE__)
+#include <errno.h>
+#include <stdio.h>
+#include <string.h>
+#include <sys/types.h>
+#include <sys/acl.h>
+#endif
+
+#if defined(__FreeBSD__) || defined(__NetBSD__) || defined(__APPLE__)
+#include <unistd.h>
+#endif
+
+#if defined(__APPLE__)
+#define UNSN_ACL_T acl_t
+#else
+#define UNSN_ACL_T acl_t *
+#endif
+
+
+static void unsn_acl_fail(const char *fmtmsg)
+{
+ char errmsg[255];
+
+ int errnum = errno;
+ if (strerror_r(errnum, errmsg, sizeof(errmsg)) != 0) {
+ snprintf(errmsg, sizeof(errmsg), "(error code %d)", errnum);
+ }
+
+ caml_failwith_value(caml_alloc_sprintf(fmtmsg, errmsg));
+}
+
+#if defined(__FreeBSD__) || defined(__NetBSD__)
+static acl_type_t unsn_path_acl_type(const char *path)
+{
+ if (pathconf(path, _PC_ACL_NFS4) > 0) { /* NFSv4 ACL supported */
+ return ACL_TYPE_NFS4;
+ } else if (pathconf(path, _PC_ACL_EXTENDED) > 0) { /* POSIX draft ACL */
+ return ACL_TYPE_ACCESS; /* It is not possible to get or set
+ default and access ACL at the same time,
+ so fall back to access ACL only. */
+ } else { /* ACLs not supported */
+ return -1;
+ }
+}
+#elif defined(__APPLE__)
+static acl_type_t unsn_path_acl_type(const char *path)
+{
+ return ACL_TYPE_EXTENDED;
+}
+#endif
+
+
+static void unsn_remove_acl_os(const char *path)
+{
+#if defined(__Solaris__)
+ struct stat st;
+
+ if (stat(path, &st) != 0) {
+ unsn_acl_fail("Can't access file to remove ACL: %s");
+ }
+
+ if (acl_strip(path, st.st_uid, st.st_gid, st.st_mode) != 0) {
+ unsn_acl_fail("Error removing ACL: %s");
+ }
+#elif defined(__FreeBSD__) || defined(__NetBSD__)
+ /* FreeBSD has a acl_strip_np() function, but it would be
+ * much too complicated in this code. */
+ /* Don't even bother checking for target ACL type, just
+ * try to remove all and ignore errors. */
+ acl_delete_file_np(path, ACL_TYPE_DEFAULT);
+ acl_delete_file_np(path, ACL_TYPE_ACCESS);
+ acl_delete_file_np(path, ACL_TYPE_NFS4);
+#elif defined(__APPLE__)
+ acl_set_file(path, unsn_path_acl_type(path), acl_from_text("!#acl 1"));
+#endif
+}
+
+
+/************************************
+ * Set ACL from text
+ ************************************/
+static _Bool unsn_acl_from_text_os(const char *acl_text, UNSN_ACL_T *aclp)
+{
+#if defined(__FreeBSD__) || defined(__NetBSD__) || defined(__APPLE__)
+ *aclp = acl_from_text(acl_text);
+
+ return (*aclp != NULL);
+#elif defined(__Solaris__)
+ int error = acl_fromtext(acl_text, aclp);
+
+ return (error == 0 && aclp != NULL);
+#endif
+}
+
+CAMLprim value unison_acl_from_text(value path, value acl)
+{
+ CAMLparam2(path, acl);
+ const char *acl_text = String_val(acl);
+ const char *name = String_val(path);
+ UNSN_ACL_T aclp = NULL;
+ int error;
+
+#if defined(__FreeBSD__) || defined(__NetBSD__) || defined(__APPLE__)
+ acl_type_t type = unsn_path_acl_type(name);
+ if (type == -1) {
+ caml_failwith("ACL not supported on this path");
+ }
+#endif
+
+ /* Check if ACL must be removed */
+ if (*acl_text == '\0') {
+ unsn_remove_acl_os(name);
+ CAMLreturn(Val_unit);
+ }
+
+ if (!unsn_acl_from_text_os(acl_text, &aclp)) {
+ caml_failwith("Error converting ACL from text");
+ }
+
+#if defined(__Solaris__)
+ error = acl_set(name, aclp);
+#elif defined(__FreeBSD__) || defined(__NetBSD__) || defined(__APPLE__)
+ error = acl_set_file(name, type, aclp);
+#endif
+ int real_err = errno;
+ acl_free(aclp);
+ errno = real_err;
+
+ if (error == -1) {
+ unsn_acl_fail("Error setting ACL: %s");
+ }
+
+ CAMLreturn(Val_unit);
+}
+
+
+/************************************
+ * Get ACL as text
+ ************************************/
+/* This function does not allocate new,
+ * it returns the pointer to its argument. */
+static char *postprocess_acl_os(char *s)
+{
+#if defined(__FreeBSD__) || defined(__NetBSD__)
+ char *p;
+ char *buf = s; /* Just an alias; modify input string in place */
+ int perms = 0, comment = 0, offs = 0;
+
+ for (p = s; *p; p++) {
+ switch (*p) {
+ case ',' :
+ perms = 0;
+ break;
+ case '#' :
+ /* FreeBSD acl_to_text embeds the #effective permissions,
+ * which are actually not part of the ACL. */
+ comment = 1;
+ break;
+ case '@' :
+ case ':' :
+ if (!comment) {
+ perms++;
+ }
+ break;
+ case 'D' :
+ /* Swap the position of d and D permissions.
+ * Synchronization works even without swapping, but the different
+ * ordering will show up as constant synchronization difference. */
+ if (perms == 2) {
+ if (buf[offs - 1] != 'd' && *(p + 1) == 'd') {
+ *p = 'd';
+ *(p + 1) = 'D';
+ } else if (buf[offs - 1] != 'd' && *(p + 1) == '-') {
+ *p = '-';
+ *(p + 1) = 'D';
+ }
+ perms = 0; /* prevent further swapping */
+ }
+ break;
+ case 'd' :
+ if (perms == 2) {
+ if (buf[offs - 1] == '-' && *(p + 1) != 'D' && *(p + 1) != '\0') {
+ buf[offs - 1] = 'd';
+ *p = '-';
+ } else if (buf[offs - 1] != 'd' && *(p + 1) == '-') {
+ *p = '-';
+ *(p + 1) = 'D';
+ }
+ perms = 0; /* prevent further swapping */
+ }
+ break;
+ case '\n' :
+ /* Replace newlines with commas...
+ * ... except if it's the last one. */
+ if (*(p + 1) != '\0') {
+ *p = ',';
+ } else {
+ *p = ' ';
+ }
+ perms = 0;
+ comment = 0;
+ break;
+ }
+
+ /* Remove all whitespace and comments. */
+ if (*p != ' ' && *p != '\t' && !comment) {
+ buf[offs++] = *p;
+ }
+ }
+ buf[offs] = '\0';
+
+ return buf;
+#elif defined(__APPLE__)
+ /* Remove trailing newline */
+ size_t last = strlen(s) - 1;
+ if (last >= 0 && s[last] == '\n') {
+ s[last] = '\0';
+ }
+
+ return s;
+#endif
+}
+
+static char *unsn_acl_to_text_os(UNSN_ACL_T aclp)
+{
+#if defined(__FreeBSD__) || defined(__NetBSD__)
+ return postprocess_acl_os(acl_to_text_np(aclp, NULL, ACL_TEXT_APPEND_ID));
+#elif defined(__APPLE__)
+ return postprocess_acl_os(acl_to_text(aclp, NULL));
+#elif defined(__Solaris__)
+ return acl_totext(aclp, ACL_APPEND_ID | ACL_COMPACT_FMT | ACL_SID_FMT);
+#endif
+}
+
+static _Bool unsn_acl_is_empty_or_trivial_os(UNSN_ACL_T aclp)
+{
+#if defined(__FreeBSD__) || defined(__NetBSD__)
+ int is_trivial = 0;
+
+ acl_is_trivial_np(aclp, &is_trivial); /* Ignore any errors here */
+
+ return (is_trivial || aclp == NULL);
+#elif defined(__APPLE__) || defined(__Solaris__)
+ return (aclp == NULL);
+#endif
+}
+
+static int unsn_get_acl_os(const char *path, UNSN_ACL_T *aclp)
+{
+#if defined(__FreeBSD__) || defined(__NetBSD__) || defined(__APPLE__)
+ acl_type_t type = unsn_path_acl_type(path);
+ if (type == -1) {
+ errno = EOPNOTSUPP;
+ return -1;
+ }
+
+ errno = 0;
+ *aclp = acl_get_file(path, type);
+
+#if defined(__APPLE__)
+ if (errno != 0) {
+ /* ACLs are always enabled on Darwin since version 10 (2009).
+ * Unfortunately, Darwin sets errno to ENOENT also when the file
+ * does not have an extended ACL. Since it is impossible to distinguish
+ * from the real ENOENT (due to the path), we must check with stat(). */
+ if (errno == ENOENT) {
+ struct stat st;
+ errno = 0;
+ stat(path, &st);
+
+ if (errno != ENOENT) {
+ /* The path does not trigger ENOENT;
+ * this means that there is no extended ACL. This is allowed. */
+ return 0;
+ }
+
+ errno = ENOENT; /* Ignore errno from stat(), restore original errno. */
+ }
+
+ return -1;
+ }
+#elif defined(__FreeBSD__) || defined(__NetBSD__)
+ if (*aclp == NULL) {
+ return -1;
+ }
+#endif
+
+ return 0;
+#endif /* FreeBSD or NetBSD or Darwin */
+
+#if defined(__Solaris__)
+ return acl_get(path, ACL_NO_TRIVIAL, aclp);
+#endif
+}
+
+CAMLprim value unison_acl_to_text(value path)
+{
+ CAMLparam1(path);
+ CAMLlocal1(result);
+ UNSN_ACL_T aclp = NULL;
+ char *acltxt;
+
+ int err = unsn_get_acl_os(String_val(path), &aclp);
+ if (err == -1) {
+ if (errno == ENOSYS || errno == EOPNOTSUPP) {
+ CAMLreturn(UNSN_ACL_NOT_SUPPORTED);
+ } else {
+ unsn_acl_fail("Error getting ACL: %s");
+ }
+ }
+
+ /* If there was no error but aclp is NULL then it means an empty
+ * or trivial ACL (that is, just the mode), which is allowed. */
+ if (aclp == NULL || unsn_acl_is_empty_or_trivial_os(aclp)) {
+ if (aclp != NULL) {
+ acl_free(aclp);
+ }
+
+ CAMLreturn(UNSN_ACL_EMPTY);
+ }
+
+ acltxt = unsn_acl_to_text_os(aclp);
+ acl_free(aclp);
+
+ if (acltxt == NULL) {
+ caml_failwith("Error converting ACL to text");
+ }
+
+ result = caml_copy_string(acltxt);
+ free(acltxt);
+
+ CAMLreturn(result);
+}
+
+#endif /* !defined(_WIN32) */
+
+
+#endif /* UNSN_HAS_FS_ACL */
diff --git a/src/props_xattr.c b/src/props_xattr.c
new file mode 100644
index 0000000..d832481
--- /dev/null
+++ b/src/props_xattr.c
@@ -0,0 +1,770 @@
+/* Unison file synchronizer: src/props_xattr.c */
+/* Copyright 2020-2022, Tõivo Leedjärv
+
+ This program is free software: you can redistribute it and/or modify
+ it under the terms of the GNU General Public License as published by
+ the Free Software Foundation, either version 3 of the License, or
+ (at your option) any later version.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with this program. If not, see <http://www.gnu.org/licenses/>.
+*/
+
+/* Conceptually, here, an extended attribute is just a name-value pair,
+ * where name is a text string and value is a binary string. This matches
+ * well the concept of extended attributes on some platforms (notably,
+ * Linux and BSDs), while some platforms provide more sophisticated
+ * extended attributes.
+ *
+ * The external interface is defined as follows. Every supported platform
+ * must implement this interface. xattr format can be platform-specific,
+ * which may prevent cross-platform synchronization but still allows
+ * synchronization within the platform. Cross-platform synchronization may
+ * still be possible in some cases, even if one platform will not
+ * understand the xattrs; the attribute values are treated as blobs then.
+ *
+ *
+ * SET the value of one xattr
+ * ==========================
+ * unit unison_xattr_set(String path, String xattrname, String xattrvalue)
+ *
+ * Create the requested extended attribute on the requested file or
+ * directory and set the attribute value.
+ * If the attribute already exists then its value is overwritten.
+ * Symbolic links are followed.
+ *
+ * Input parameters
+ * path - absolute path of a file or directory
+ * xattrname - name of attribute to set on the path
+ * xattrvalue - value of attribute to set on the path
+ *
+ * Return value
+ * No return value.
+ *
+ * Exceptions
+ * There are no mandatory exception conditions.
+ * OCaml exception defined by macro UNSN_XATTR_NOT_SUPPORTED_EX
+ * MAY be raised when extended attributes are not supported on
+ * the requested path.
+ * Failure MAY voluntarily be raised for example when:
+ * Can't access file to set the attribute
+ * Error creating the attribute (invalid name, permission error, etc.)
+ * Error setting the attribute value
+ *
+ *
+ * REMOVE one xattr
+ * ================
+ * unit unison_xattr_remove(String path, String xattrname)
+ *
+ * Remove the requested extended attribute on the requested file or
+ * directory. Symbolic links are followed.
+ *
+ * Input parameters
+ * path - absolute path of a file or directory
+ * xattrname - name of attribute to remove on the path
+ *
+ * Return value
+ * No return value.
+ *
+ * Exceptions
+ * There are no mandatory exception conditions.
+ * OCaml exception defined by macro UNSN_XATTR_NOT_SUPPORTED_EX
+ * MAY be raised when extended attributes are not supported on
+ * the requested path.
+ * Failure MAY voluntarily be raised for example when:
+ * Can't access file to remove the attribute
+ * Error removing the attribute
+ *
+ *
+ * GET the value of one xattr
+ * ==========================
+ * String unison_xattr_get(String path, String xattrname)
+ *
+ * Get the value of the requested extended attribute on the requested
+ * file or directory. The entire value is returned in full length.
+ * Symbolic links are followed.
+ *
+ * Input parameters
+ * path - absolute path of a file or directory
+ * xattrname - name of attribute to get on the path
+ *
+ * Return value
+ * The value of the requested extended attribute, as a binary string.
+ *
+ * Exceptions
+ * OCaml exception defined by macro UNSN_XATTR_NOT_SUPPORTED_EX
+ * MAY be raised when extended attributes are not supported on
+ * the requested path.
+ * Failure MUST be raised when:
+ * The attribute value does not fit in an OCaml string on a 32-bit
+ * platform (approx. 16 MB)
+ * Can't access file to read the attribute
+ * Error reading the attribute value or attribute not found
+ *
+ *
+ * GET the list of xattrs with value lengths
+ * =========================================
+ * List of (String * Int) unison_xattrs_list(String path)
+ *
+ * Get the list of all extended attributes on the requested file or
+ * directory. Attributes names are returned together with the length
+ * of attribute values.
+ * Attributes in the list can be returned in any order and the order
+ * does not have to be stable (i.e. it can be different on every
+ * invocation on the same path).
+ * Symbolic links are followed.
+ *
+ * Input parameters
+ * path - absolute path of a file or directory
+ *
+ * Return value
+ * The list of name-length pairs, with each pair representing the
+ * name and length of value of one extended attribute.
+ *
+ * Exceptions
+ * OCaml exception defined by macro UNSN_XATTR_NOT_SUPPORTED_EX
+ * MUST be raised when extended attributes are not supported on
+ * the requested path, or should not otherwise be returned.
+ * Failure MAY voluntarily be raised for example when:
+ * Can't access file to get the attributes
+ * Error reading attribute values
+ *
+ *
+ * Indicate platform/system capabilities
+ * =====================================
+ * Boolean unison_xattr_updates_ctime()
+ *
+ * Indicate whether the platform/system updates file ctime when
+ * extended attributes change on the file. Not all platforms do this
+ * (Solaris/illumos are known to not update any stat times of the
+ * file/directory when its extended attributes are modified).
+ * The capabilities of the system are important to know because
+ * detecting updates quickly yet correctly relies on knowing when to
+ * get the list of xattrs with values.
+ *
+ * Input parameters
+ * none
+ *
+ * Return value
+ * True if file ctime is updated at xattr changes. False otherwise.
+ * For a platform that does not support ctime, true can be returned
+ * if xattr changes update file mtime.
+ *
+ * Exceptions
+ * none
+ *
+ */
+
+#include <caml/memory.h>
+#include <caml/alloc.h>
+#include <caml/fail.h>
+#include <caml/callback.h>
+
+
+#if defined(sun) || defined(__sun) /* Solarish, all illumos-based OS, */
+#define __Solaris__ /* OpenIndiana, OmniOS, SmartOS, ... */
+#endif
+
+#undef UNSN_HAS_XATTR
+#if defined(__Solaris__) || defined(__FreeBSD__) || defined(__NetBSD__) \
+ || defined(__APPLE__) || defined(__linux)
+#define UNSN_HAS_XATTR
+#endif
+
+#ifndef O_CLOEXEC
+#define O_CLOEXEC 0
+#endif
+
+#define UNSN_XATTR_NOT_SUPPORTED_EX "XattrNotSupported"
+
+
+static void unsn_xattr_not_supported()
+{
+ static const value *ex = NULL;
+
+ if (ex == NULL) {
+ ex = caml_named_value(UNSN_XATTR_NOT_SUPPORTED_EX);
+ }
+
+ caml_raise_constant(*ex);
+}
+
+
+#ifndef UNSN_HAS_XATTR
+
+CAMLprim void unison_xattr_set(value path, value xattrname, value xattr)
+{
+ unsn_xattr_not_supported();
+}
+
+CAMLprim void unison_xattr_remove(value path, value xattrname)
+{
+ unsn_xattr_not_supported();
+}
+
+CAMLprim void unison_xattr_get(value path, value xattrname)
+{
+ unsn_xattr_not_supported();
+}
+
+CAMLprim void unison_xattrs_list(value path)
+{
+ unsn_xattr_not_supported();
+}
+
+CAMLprim value unison_xattr_updates_ctime(value unit)
+{
+ CAMLparam0();
+ CAMLreturn(Val_true);
+}
+
+#else /* UNSN_HAS_XATTR */
+
+
+#if defined(__Solaris__)
+#include <errno.h>
+#include <sys/types.h>
+#include <sys/stat.h>
+#include <fcntl.h>
+#include <dirent.h>
+#include <unistd.h>
+#include <string.h>
+#include <stdio.h>
+#endif
+
+#if defined(__FreeBSD__) || defined(__NetBSD__)
+#include <errno.h>
+#include <sys/types.h>
+#include <sys/extattr.h>
+#include <string.h>
+#include <stdio.h>
+#endif
+
+#if defined(__FreeBSD__)
+#define ENOTSUP EOPNOTSUPP
+#endif
+
+#if defined(__APPLE__)
+#include <errno.h>
+#include <sys/xattr.h>
+#include <string.h>
+#include <stdio.h>
+#endif
+
+#if defined(__linux)
+#include <errno.h>
+#include <sys/types.h>
+#include <sys/xattr.h>
+#include <string.h>
+#include <stdio.h>
+
+/* Attribute names on Linux must be mangled to make cross-platform
+ * synchronization possible. When listing attributes, the "user."
+ * prefix is removed for user namespace attributes and an "!" is
+ * prepended to attribute names in all other namespaces (or more
+ * accurately, it is prepended to the namespace name).
+ *
+ * When feeding the attribute names to get, set, remove and other
+ * syscalls, the reverse is done. */
+
+#define XN_BUF_LEN 261
+#define XN_LEN (XN_BUF_LEN - 6)
+
+static value val_of_attrname(char *attrname)
+{
+ char buf[XN_BUF_LEN] = "!";
+
+ if (attrname != NULL) {
+ if (strncmp(attrname, "user.", 5) == 0) {
+ attrname += 5;
+ } else {
+ attrname = strncat(buf, attrname, XN_LEN);
+ }
+ }
+
+ return caml_copy_string(attrname != NULL ? attrname : "");
+}
+
+static const char *attrname_of_val(const char *attrname, char *buf)
+{
+ if (attrname != NULL) {
+ if (attrname[0] == '!') {
+ return attrname + 1;
+ } else {
+ return strncat(strcpy(buf, "user."), attrname, XN_LEN);
+ }
+ } else {
+ return attrname;
+ }
+}
+#endif /* defined(__linux) */
+
+
+#if defined(__linux)
+
+#define XATTRNAME_VAL(a, n) char xnb_[XN_BUF_LEN];\
+ const char *a = attrname_of_val(String_val(n), xnb_)
+#define VAL_XATTRNAME val_of_attrname
+
+#else
+
+#define XATTRNAME_VAL(a, n) const char *a = String_val(n)
+#define VAL_XATTRNAME caml_copy_string
+
+#endif /* defined(__linux) */
+
+
+static void unsn_xattr_fail(const char *fmtmsg)
+{
+ char buf[512];
+ char *errmsg;
+
+#if defined(_WIN32)
+ errmsg = strerror(errno);
+#else
+ int errnum = errno;
+ if (strerror_r(errnum, buf, sizeof(buf)) != 0) {
+ snprintf(buf, sizeof(buf), "(error code %d)", errnum);
+ }
+ errmsg = buf;
+#endif /* defined(_WIN32) */
+
+ caml_failwith_value(caml_alloc_sprintf(fmtmsg, errmsg));
+}
+
+static int unsn_is_system_attr_os(const char *attrname)
+{
+#if defined(__linux)
+ return (strncmp(attrname, "system.", 7) == 0 &&
+ strncmp(attrname, "system.posix_acl_", 17) != 0);
+#elif defined(__APPLE__)
+ return (strcmp(attrname, XATTR_FINDERINFO_NAME) == 0 ||
+ strcmp(attrname, XATTR_RESOURCEFORK_NAME) == 0);
+#elif defined(__FreeBSD__) || defined(__NetBSD__)
+ return 0;
+#elif defined(__Solaris__)
+ /* Special system "extensible attributes" xattrs are defined in sys/attr.h
+ * as VIEW_READONLY = "SUNWattr_ro" and VIEW_READWRITE = "SUNWattr_rw" */
+ return (strcmp(attrname, ".") == 0 || strcmp(attrname, "..") == 0 ||
+ strncmp(attrname, "SUNWattr_", 9) == 0);
+#endif
+}
+
+
+/************************************
+ * Set xattr
+ ************************************/
+static int unsn_set_xattr_os(const char *path, const char *attrname,
+ const void *attrvalue, size_t valuesize)
+{
+#if defined(__linux)
+ return setxattr(path, attrname, attrvalue, valuesize, 0);
+#elif defined(__APPLE__)
+ return setxattr(path, attrname, attrvalue, valuesize, 0, 0);
+#elif defined(__FreeBSD__) || defined(__NetBSD__)
+ return (int) extattr_set_file(path, EXTATTR_NAMESPACE_USER, attrname,
+ attrvalue, valuesize);
+#elif defined(__Solaris__)
+ if (pathconf(path, _PC_XATTR_ENABLED) < 1) {
+ unsn_xattr_not_supported();
+ }
+
+ /* This is a simplified implementation that just creates/opens
+ * the xattr and writes the value into it.
+ *
+ * Extended attributes in Solaris and illumos are much more
+ * flexible. In most ways they are like normal files/directories.
+ * They have owner/group, mode, utimes, even ACL, and can have
+ * their own extended attributes, etc.
+ *
+ * This implementation does not synchronize any of those params,
+ * as xattrs are conceptually treated as name-value pairs.
+ * It is unknown if this will cause problems with real use cases. */
+ int fd = attropen(path, attrname, O_CREAT|O_WRONLY|O_TRUNC|O_CLOEXEC);
+ if (fd == -1) {
+ unsn_xattr_fail("Error opening extended attribute for writing: %s");
+ }
+
+ ssize_t written = 0, c;
+ do {
+ c = write(fd, attrvalue + written, valuesize - written);
+ written += c;
+ } while (c > 0 && written < valuesize);
+
+ close(fd);
+
+ return c == -1 ? c : 0;
+#endif
+}
+
+CAMLprim value unison_xattr_set(value path, value xattrname, value xattr)
+{
+ CAMLparam3(path, xattrname, xattr);
+ const char *name = String_val(path);
+ XATTRNAME_VAL(attr, xattrname);
+ const char *attrvalue = String_val(xattr);
+ unsigned int len;
+
+ /* Ignore system extended attributes */
+ if (unsn_is_system_attr_os(attr)) {
+ CAMLreturn(Val_unit);
+ }
+
+ len = caml_string_length(xattr);
+
+ int error = unsn_set_xattr_os(name, attr, attrvalue, len);
+ if (error == -1) {
+ if (errno == ENOTSUP) {
+ unsn_xattr_not_supported();
+ } else {
+ unsn_xattr_fail("Error writing extended attribute: %s");
+ }
+ }
+
+ CAMLreturn(Val_unit);
+}
+
+
+/************************************
+ * Remove xattr
+ ************************************/
+static int unsn_remove_xattr_os(const char *path, const char *attrname)
+{
+#if defined(__linux)
+ return removexattr(path, attrname);
+#elif defined(__APPLE__)
+ return removexattr(path, attrname, 0);
+#elif defined(__FreeBSD__) || defined(__NetBSD__)
+ return (int) extattr_delete_file(path, EXTATTR_NAMESPACE_USER, attrname);
+#elif defined(__Solaris__)
+ if (pathconf(path, _PC_XATTR_ENABLED) < 1) {
+ unsn_xattr_not_supported();
+ }
+
+ int fd = attropen(path, ".", O_RDONLY|O_CLOEXEC);
+ if (fd == -1) {
+ unsn_xattr_fail("Error opening extended attribute for removing: %s");
+ }
+ int error = unlinkat(fd, attrname, 0);
+ close(fd);
+
+ return error;
+#endif
+}
+
+CAMLprim value unison_xattr_remove(value path, value xattrname)
+{
+ CAMLparam2(path, xattrname);
+ const char *name = String_val(path);
+ XATTRNAME_VAL(attr, xattrname);
+
+ /* Ignore system extended attributes */
+ if (unsn_is_system_attr_os(attr)) {
+ CAMLreturn(Val_unit);
+ }
+
+ int error = unsn_remove_xattr_os(name, attr);
+ if (error == -1 && errno == ENOTSUP) {
+ unsn_xattr_not_supported();
+ }
+
+ CAMLreturn(Val_unit);
+}
+
+
+/************************************
+ * Length of xattr
+ ************************************/
+static ssize_t unsn_length_xattr_os(const char *path, const char *attrname)
+{
+#if defined(__linux)
+ return getxattr(path, attrname, NULL, 0);
+#elif defined(__APPLE__)
+ return getxattr(path, attrname, NULL, 0, 0, 0);
+#elif defined(__FreeBSD__) || defined(__NetBSD__)
+ return extattr_get_file(path, EXTATTR_NAMESPACE_USER, attrname, NULL, 0);
+#elif defined(__Solaris__)
+ int fd = attropen(path, attrname, O_RDONLY|O_CLOEXEC);
+ if (fd == -1) {
+ unsn_xattr_fail("Error opening extended attribute for querying length: %s");
+ }
+
+ struct stat buf;
+ int error;
+
+ error = fstat(fd, &buf);
+ close(fd);
+
+ return error == -1 ? error : buf.st_size;
+#endif
+}
+
+
+/************************************
+ * Get xattrs
+ ************************************/
+static ssize_t unsn_get_xattr_os(const char *path, const char *attrname,
+ void *buf, size_t size)
+{
+#if defined(__linux)
+ return getxattr(path, attrname, buf, size);
+#elif defined(__APPLE__)
+ return getxattr(path, attrname, buf, size, 0, 0);
+#elif defined(__FreeBSD__) || defined(__NetBSD__)
+ return extattr_get_file(path, EXTATTR_NAMESPACE_USER, attrname, buf, size);
+#elif defined(__Solaris__)
+ int fd = attropen(path, attrname, O_RDONLY|O_CLOEXEC);
+ if (fd == -1) {
+ unsn_xattr_fail("Error opening extended attribute for reading: %s");
+ }
+
+ ssize_t rd = 0, c;
+ do {
+ c = read(fd, buf + rd, size - rd);
+ rd += c;
+ } while (c > 0 && rd < size);
+
+ close(fd);
+
+ return c == -1 ? c : rd;
+#endif
+}
+
+CAMLprim value unison_xattr_get(value path, value xattrname)
+{
+ CAMLparam2(path, xattrname);
+ CAMLlocal1(v);
+ const char *name = String_val(path);
+ XATTRNAME_VAL(attr, xattrname);
+
+ int len = 0, tries = 0;
+
+ do {
+ if (++tries > 10) {
+ caml_failwith("Error reading contents of extended attribute; "
+ "it keeps changing");
+ }
+
+ len = unsn_length_xattr_os(name, attr);
+ if (len == -1 && errno == ENOTSUP) {
+ unsn_xattr_not_supported();
+ } else if (len == -1) {
+ unsn_xattr_fail("Error reading length of extended attribute: %s");
+ }
+
+ if (len == 0) {
+ v = caml_alloc_string(0);
+ } else if (len > 16777211) { // Max OCaml string length on 32 bit platforms
+ caml_failwith_value(caml_alloc_sprintf(
+ "Extended attribute value is too big (%d bytes)", len));
+ } else {
+ char *buf = malloc(len);
+
+ len = unsn_get_xattr_os(name, attr, buf, len);
+ if (len == -1 && errno == ENOTSUP) {
+ free(buf);
+ unsn_xattr_not_supported();
+ } else if (len == -1 && errno != ERANGE) {
+ free(buf);
+ unsn_xattr_fail("Error reading contents of extended attribute: %s");
+ } else if (len != -1) {
+ v = caml_alloc_initialized_string(len, buf);
+ }
+
+ free(buf);
+ }
+ } while (len == -1 && errno == ERANGE);
+ /* ERANGE error produced on Linux and Darwin; other platforms
+ * truncate the value if buffer is too small. */
+
+ CAMLreturn(v);
+}
+
+
+/************************************
+ * List xattrs
+ ************************************/
+static void unsn_list_xattr_fail(void)
+{
+ unsn_xattr_fail("Error getting list of extended attributes: %s");
+}
+
+#if !defined(__Solaris__)
+
+static ssize_t unsn_list_xattr_os(const char *path, char *buf, size_t size)
+{
+#if defined(__linux)
+ return listxattr(path, buf, size);
+#elif defined(__APPLE__)
+ return listxattr(path, buf, size, 0);
+#elif defined(__FreeBSD__) || defined(__NetBSD__)
+ return extattr_list_file(path, EXTATTR_NAMESPACE_USER, buf, size);
+#endif
+}
+
+static ssize_t unsn_list_xattr_aux(const char *path, char **buf)
+{
+ ssize_t namelen;
+
+ namelen = unsn_list_xattr_os(path, NULL, 0);
+
+ if (namelen == -1) {
+ if (errno == ENOTSUP) {
+ unsn_xattr_not_supported();
+ }
+ unsn_list_xattr_fail();
+ }
+ if (namelen == 0) {
+ return 0;
+ }
+
+ *buf = malloc(namelen);
+ if (*buf == NULL) {
+ unsn_list_xattr_fail();
+ }
+
+ namelen = unsn_list_xattr_os(path, *buf, namelen);
+ if (namelen == -1) {
+ free(*buf);
+ unsn_list_xattr_fail();
+ }
+ if (namelen == 0) {
+ free(*buf);
+ return 0;
+ }
+
+ return namelen;
+}
+
+#else
+
+static ssize_t unsn_list_xattr_aux(const char *path, DIR **dirp)
+{
+ if (pathconf(path, _PC_XATTR_ENABLED) < 1) {
+ unsn_xattr_not_supported();
+ }
+
+ if (pathconf(path, _PC_XATTR_EXISTS) < 1) {
+ return 0;
+ }
+
+ int fd = attropen(path, ".", O_RDONLY|O_CLOEXEC);
+ if (fd == -1) {
+ unsn_list_xattr_fail();
+ }
+
+ *dirp = fdopendir(fd);
+ if (*dirp == NULL) {
+ int real_err = errno;
+ close(fd);
+ errno = real_err;
+ unsn_list_xattr_fail();
+ }
+
+ return 1;
+}
+
+#endif /* !__Solaris__ */
+
+CAMLprim value unison_xattrs_list(value path)
+{
+ CAMLparam1(path);
+ CAMLlocal3(result, p, l);
+ /* Use a static buffer because memory management for the path would become
+ * much too complex. Use a constant length because PATH_MAX is not reliable
+ * and pathconf() is out of question. */
+ char name[32768];
+#if !defined(__Solaris__)
+ char *xattrs;
+#else
+ DIR *xattrs;
+ struct dirent *dp;
+ char *xattrname;
+#endif
+ ssize_t namelen, len;
+
+ if (caml_string_length(path) > 32767) {
+ caml_failwith("The path is too long");
+ }
+ strcpy(name, String_val(path));
+
+ result = Val_emptylist;
+
+ namelen = unsn_list_xattr_aux(name, &xattrs);
+ if (namelen == 0) {
+ CAMLreturn(result);
+ }
+
+#if defined(__FreeBSD__) || defined(__NetBSD__)
+ size_t nl = 0;
+ char xattrname[256];
+
+ for (char *xattrnamep = xattrs; xattrnamep < xattrs + namelen;
+ xattrnamep += nl + 1) {
+ nl = *xattrnamep & 255;
+ memcpy(xattrname, xattrnamep + 1, nl);
+ xattrname[nl] = '\0';
+#elif !defined(__Solaris__)
+ /* For safety */
+ *(xattrs + namelen - 1) = '\0';
+
+ for (char *xattrname = xattrs; xattrname < xattrs + namelen;
+ xattrname += strlen(xattrname) + 1) {
+#elif defined(__Solaris__)
+ while (dp = readdir(xattrs)) {
+ /* Note: NULL is returned for both end of dir and an error condition.
+ * Error conditions are silently ignored. */
+ xattrname = dp->d_name;
+#endif
+
+ /* Ignore system extended attributes */
+ if (unsn_is_system_attr_os(xattrname)) {
+ continue;
+ }
+
+ len = unsn_length_xattr_os(name, xattrname);
+ if (len == -1) {
+ continue; /* Ignore silently */
+ }
+
+ p = caml_alloc_tuple(2);
+ Store_field(p, 0, VAL_XATTRNAME(xattrname));
+ Store_field(p, 1, Val_int(len));
+
+ l = caml_alloc_small(2, Tag_cons);
+ Field(l, 0) = p;
+ Field(l, 1) = result;
+
+ result = l;
+ }
+
+#if defined(__Solaris__)
+ closedir(xattrs);
+#else
+ free(xattrs);
+#endif
+
+ CAMLreturn(result);
+}
+
+
+/************************************
+ * ctime capabilities
+ ************************************/
+CAMLprim value unison_xattr_updates_ctime(value unit)
+{
+ CAMLparam0();
+#if defined(__Solaris__)
+ CAMLreturn(Val_false);
+#else
+ CAMLreturn(Val_true);
+#endif
+}
+
+
+#endif /* UNSN_HAS_XATTR */
diff --git a/src/propsdata.ml b/src/propsdata.ml
new file mode 100644
index 0000000..1f8ec86
--- /dev/null
+++ b/src/propsdata.ml
@@ -0,0 +1,112 @@
+(* Unison file synchronizer: src/propsdata.ml *)
+(* Copyright 2020-2022, Tõivo Leedjärv
+
+ This program is free software: you can redistribute it and/or modify
+ it under the terms of the GNU General Public License as published by
+ the Free Software Foundation, either version 3 of the License, or
+ (at your option) any later version.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with this program. If not, see <http://www.gnu.org/licenses/>.
+*)
+
+
+module type S = sig
+ val get : [< `All | `New | `Kept] -> (string * string) list
+ val set : (string * string) list -> unit
+ val merge : (string * string) list -> unit
+ val clear : [`Kept] -> unit
+end
+
+
+module KVStore (V : sig val initSize : int end) = struct
+
+(* Key-value store with a relatively low number of entries (in the tens
+ or hundreds, or at most in low thousands).
+
+ This is not a generic key-value store; this is specifically intended
+ for use by [Props.Data].
+
+ Several simple implementations are possible (for example, a Map or an
+ association list). There seems to be very little difference in terms
+ of performance. Hashtbl has been chosen as it may have a slight scaling
+ advantage. In practice, there probably are no tangile differences
+ between these simple implementations in most scenarios. *)
+let mainStore = Hashtbl.create V.initSize
+let newStore = Hashtbl.create V.initSize
+let keepStore = Hashtbl.create V.initSize
+
+let getStore = function
+ | `All -> mainStore
+ | `New -> newStore
+ | `Kept -> keepStore
+
+let exists key = Hashtbl.mem mainStore key
+
+let find_opt key = Hashtbl.find_opt mainStore key
+
+let associate key value = Hashtbl.add mainStore key value
+
+let associateNew key value =
+ associate key value;
+ Hashtbl.add newStore key value
+
+let add key value =
+ if not (exists key) then associateNew key value
+
+let find key =
+ match find_opt key with
+ | Some v -> v
+ | None -> assert false (* Indicates a bug *)
+
+let get kind =
+ Hashtbl.fold (fun key value acc -> (key, value) :: acc) (getStore kind) []
+
+let set d =
+ Hashtbl.clear mainStore;
+ Hashtbl.clear newStore;
+ Safelist.iter (fun (key, value) -> associate key value) d
+
+let associate_cmp key value =
+ match find_opt key with
+ | None -> associate key value
+ | Some v when v = value -> ()
+ | Some v ->
+ raise (Util.Fatal ("Internal integrity error (propsdata). Key " ^ key
+ ^ " returns different results:\n (existing) " ^ v
+ ^ "\nand\n (new) " ^ value ^ "\n"))
+
+let merge d =
+ Safelist.iter (fun (key, value) -> associate_cmp key value) d
+
+let clear kind =
+ Hashtbl.clear (getStore kind)
+
+let keep key =
+ if Hashtbl.mem keepStore key then ()
+ else Hashtbl.add keepStore key (find key)
+
+end (* module KVStore *)
+
+
+(* ------------------------------------------------------------------------- *)
+(* Extended attributes (xattr) *)
+(* ------------------------------------------------------------------------- *)
+
+module Xattr = struct
+ include KVStore (struct let initSize = 200 end)
+
+ let length () = Hashtbl.length mainStore
+end
+
+
+(* ------------------------------------------------------------------------- *)
+(* ACL *)
+(* ------------------------------------------------------------------------- *)
+
+module ACL = KVStore (struct let initSize = 25 end)
diff --git a/src/propsdata.mli b/src/propsdata.mli
new file mode 100644
index 0000000..c6123cb
--- /dev/null
+++ b/src/propsdata.mli
@@ -0,0 +1,25 @@
+(* Unison file synchronizer: src/propsdata.mli *)
+(* Copyright 2022, Tõivo Leedjärv (see COPYING for details) *)
+
+module type S = sig
+ val get : [< `All | `New | `Kept] -> (string * string) list
+ val set : (string * string) list -> unit
+ val merge : (string * string) list -> unit
+ val clear : [`Kept] -> unit
+end
+
+module Xattr : sig
+ include S
+
+ val add : string -> string -> unit
+ val find_opt : string -> string option
+ val length : unit -> int
+end
+
+module ACL : sig
+ include S
+
+ val add : string -> string -> unit
+ val find : string -> string
+ val keep : string -> unit
+end
diff --git a/src/pty.c b/src/pty.c
index 010b71f..a14d1b7 100644
--- a/src/pty.c
+++ b/src/pty.c
@@ -11,13 +11,24 @@
#endif /* _WIN32 */
-#define CAML_NAME_SPACE
#include <caml/mlvalues.h>
#include <caml/alloc.h> // alloc_tuple
#include <caml/memory.h> // Store_field
#include <caml/fail.h> // failwith
#include <caml/unixsupport.h> // uerror, unix_error
#include <errno.h> // ENOSYS
+#include <caml/version.h>
+#if OCAML_VERSION < 41300
+#define CAML_INTERNALS /* was needed from OCaml 4.06 to 4.12 */
+#endif
+#include <caml/osdeps.h>
+
+#if OCAML_VERSION_MAJOR < 5
+#define caml_unix_error unix_error
+#define caml_uerror uerror
+#define caml_win32_maperr win32_maperr
+#define caml_win32_alloc_handle win_alloc_handle
+#endif
// openpty
#if defined(__linux)
@@ -45,17 +56,17 @@ CAMLprim value setControllingTerminal(value fdVal) {
CAMLparam1(fdVal);
int fd = Int_val(fdVal);
if (ioctl(fd, TIOCSCTTY, (char *) 0) < 0)
- uerror("ioctl", (value) 0);
+ caml_uerror("ioctl", (value) 0);
CAMLreturn(Val_unit);
}
/* c_openpty: unit -> (int * Unix.file_descr) */
-CAMLprim value c_openpty() {
+CAMLprim value c_openpty(value unit) {
CAMLparam0();
- int master,slave;
CAMLlocal1(pair);
+ int master, slave;
if (openpty(&master,&slave,NULL,NULL,NULL) < 0)
- uerror("openpty", (value) 0);
+ caml_uerror("openpty", (value) 0);
pair = caml_alloc_tuple(2);
Store_field(pair,0,Val_int(master));
Store_field(pair,1,Val_int(slave));
@@ -65,74 +76,19 @@ CAMLprim value c_openpty() {
#else // not HAS_OPENPTY
CAMLprim value setControllingTerminal(value fdVal) {
- unix_error (ENOSYS, "setControllingTerminal", Nothing);
+ caml_unix_error(ENOSYS, "setControllingTerminal", Nothing);
}
-CAMLprim value c_openpty() {
- unix_error (ENOSYS, "openpty", Nothing);
+CAMLprim value c_openpty(value unit) {
+ caml_unix_error(ENOSYS, "openpty", Nothing);
}
#endif
#ifdef _WIN32
-#ifndef CAMLassert
-#define CAMLassert(x) ((void) 0)
-#endif
-
#include <windows.h>
-extern void win32_maperr(DWORD errcode);
-extern value win_alloc_handle(HANDLE h);
-
-static int Twin_multi_byte_to_wide_char(const char *s, int slen,
- wchar_t *out, int outlen)
-{
- int retcode;
-
- CAMLassert (s != NULL);
-
- if (slen == 0)
- return 0;
-
- retcode =
- MultiByteToWideChar(CP_UTF8, MB_ERR_INVALID_CHARS,
- s, slen, out, outlen);
- if (retcode == 0)
- retcode = MultiByteToWideChar(CP_ACP, 0, s, slen, out, outlen);
-
- if (retcode == 0) {
- win32_maperr(GetLastError());
- uerror("", Nothing);
- }
-
- return retcode;
-}
-
-#ifndef Bytes_val /* Hack to know that we are on OCaml < 4.06.
- #include <caml/version.h> is not always found, for some reason. */
-static void* caml_stat_alloc_noexc(asize_t sz)
-{
- return malloc(sz);
-}
-#endif /* OCAML_VERSION < 40600 */
-
-static wchar_t* Tcaml_stat_strdup_to_utf16(const char *s)
-{
- wchar_t * ws;
- int retcode;
-
- retcode = Twin_multi_byte_to_wide_char(s, -1, NULL, 0);
- ws = caml_stat_alloc_noexc(retcode * sizeof(*ws));
- Twin_multi_byte_to_wide_char(s, -1, ws, retcode);
-
- return ws;
-}
-
-#ifndef Data_abstract_val /* OCaml < 4.05 */
-#define Data_abstract_val(v) ((void*) Op_val(v))
-#endif
-
#define PROC_THREAD_ATTRIBUTE_PSEUDOCONSOLE 0x00020016
typedef VOID* HPCON;
@@ -145,7 +101,7 @@ typedef void (WINAPI *sClosePseudoConsole) (HPCON hPC);
sCreatePseudoConsole pCreatePseudoConsole;
sClosePseudoConsole pClosePseudoConsole;
-CAMLprim value win_openpty()
+CAMLprim value win_openpty(value unit)
{
CAMLparam0();
CAMLlocal4(tup, tmp1, tmp2, tmp3);
@@ -155,7 +111,7 @@ CAMLprim value win_openpty()
HMODULE kernel32_module = GetModuleHandleW(L"kernel32.dll");
if (kernel32_module == NULL) {
- unix_error(ENOSYS, "openpty", Nothing);
+ caml_unix_error(ENOSYS, "openpty", Nothing);
}
/* This is the only way to use the new API while remaining compatible
@@ -163,7 +119,7 @@ CAMLprim value win_openpty()
pCreatePseudoConsole = (sCreatePseudoConsole)
GetProcAddress(kernel32_module, "CreatePseudoConsole");
if (pCreatePseudoConsole == NULL) {
- unix_error(ENOSYS, "openpty", Nothing);
+ caml_unix_error(ENOSYS, "openpty", Nothing);
}
/* Read-write pipes don't seem to work well with PTY and cause deadlocks.
@@ -172,35 +128,35 @@ CAMLprim value win_openpty()
* emulation by PF_UNIX sockets is only supported starting Windows 10 1803).
* Simpler to use two separate pipes then. */
if (!CreatePipe(&i1, &o1, NULL, 0)) {
- win32_maperr(GetLastError());
- uerror("openpty", Nothing);
+ caml_win32_maperr(GetLastError());
+ caml_uerror("openpty", Nothing);
}
if (!CreatePipe(&i2, &o2, NULL, 0)) {
- win32_maperr(GetLastError());
+ caml_win32_maperr(GetLastError());
if (o1 != INVALID_HANDLE_VALUE) CloseHandle(o1);
if (i1 != INVALID_HANDLE_VALUE) CloseHandle(i1);
- uerror("openpty", Nothing);
+ caml_uerror("openpty", Nothing);
}
if (pCreatePseudoConsole(size, i1, o2, 0, &pty) != S_OK) {
- win32_maperr(GetLastError());
+ caml_win32_maperr(GetLastError());
if (o1 != INVALID_HANDLE_VALUE) CloseHandle(o1);
if (i1 != INVALID_HANDLE_VALUE) CloseHandle(i1);
if (o2 != INVALID_HANDLE_VALUE) CloseHandle(o2);
if (i2 != INVALID_HANDLE_VALUE) CloseHandle(i2);
- uerror("openpty", Nothing);
+ caml_uerror("openpty", Nothing);
}
tmp1 = caml_alloc_tuple(2);
- Store_field(tmp1, 0, win_alloc_handle(i2));
- Store_field(tmp1, 1, win_alloc_handle(o1));
+ Store_field(tmp1, 0, caml_win32_alloc_handle(i2));
+ Store_field(tmp1, 1, caml_win32_alloc_handle(o1));
tmp2 = caml_alloc(1, Abstract_tag);
*((HPCON *) Data_abstract_val(tmp2)) = pty;
tmp3 = caml_alloc_tuple(2);
- Store_field(tmp3, 0, win_alloc_handle(i1));
- Store_field(tmp3, 1, win_alloc_handle(o2));
+ Store_field(tmp3, 0, caml_win32_alloc_handle(i1));
+ Store_field(tmp3, 1, caml_win32_alloc_handle(o2));
tup = caml_alloc_tuple(3);
Store_field(tup, 0, tmp1);
@@ -216,7 +172,7 @@ CAMLprim value win_closepty(value pty)
HMODULE kernel32_module = GetModuleHandleW(L"kernel32.dll");
if (kernel32_module == NULL) {
- unix_error(ENOSYS, "closepty", Nothing);
+ caml_unix_error(ENOSYS, "closepty", Nothing);
}
/* This is the only way to use the new API while remaining compatible
@@ -224,7 +180,7 @@ CAMLprim value win_closepty(value pty)
pClosePseudoConsole = (sClosePseudoConsole)
GetProcAddress(kernel32_module, "ClosePseudoConsole");
if (pClosePseudoConsole == NULL) {
- unix_error(ENOSYS, "closepty", Nothing);
+ caml_unix_error(ENOSYS, "closepty", Nothing);
}
pClosePseudoConsole(*((HPCON *) Data_abstract_val(pty)));
@@ -235,7 +191,7 @@ CAMLprim value win_closepty(value pty)
static void prepareSiWithPty(value prog, STARTUPINFOEX *si, HPCON pty)
{
#ifndef PROC_THREAD_ATTRIBUTE_HANDLE_LIST
- unix_error(ENOSYS, "create_process_pty", prog);
+ caml_unix_error(ENOSYS, "create_process_pty", prog);
#else
SIZE_T size;
@@ -246,21 +202,21 @@ static void prepareSiWithPty(value prog, STARTUPINFOEX *si, HPCON pty)
InitializeProcThreadAttributeList(NULL, 2, 0, &size);
si->lpAttributeList = malloc(size);
if (!si->lpAttributeList) {
- unix_error(ENOMEM, "create_process_pty", prog);
+ caml_unix_error(ENOMEM, "create_process_pty", prog);
}
if (!InitializeProcThreadAttributeList(si->lpAttributeList, 2, 0, &size)) {
- win32_maperr(GetLastError());
+ caml_win32_maperr(GetLastError());
free(si->lpAttributeList);
- uerror("create_process_pty", prog);
+ caml_uerror("create_process_pty", prog);
}
if (!UpdateProcThreadAttribute(si->lpAttributeList, 0,
PROC_THREAD_ATTRIBUTE_PSEUDOCONSOLE, pty, sizeof(pty), NULL, NULL)) {
- win32_maperr(GetLastError());
+ caml_win32_maperr(GetLastError());
DeleteProcThreadAttributeList(si->lpAttributeList);
free(si->lpAttributeList);
- uerror("create_process_pty", prog);
+ caml_uerror("create_process_pty", prog);
}
#endif
}
@@ -281,15 +237,15 @@ CAMLprim value w_create_process_pty_native
HPCON hpc = *((HPCON *) Data_abstract_val(pty));
#ifndef PROC_THREAD_ATTRIBUTE_HANDLE_LIST
- unix_error(ENOSYS, "create_process_pty", prog);
+ caml_unix_error(ENOSYS, "create_process_pty", prog);
#else
- wprog = Tcaml_stat_strdup_to_utf16(String_val(prog));
+ wprog = caml_stat_strdup_to_utf16(String_val(prog));
res = SearchPathW(NULL, wprog, L".exe", MAX_PATH, fullname, NULL);
caml_stat_free(wprog);
if (res == 0) {
- win32_maperr(GetLastError());
- uerror("create_process_pty", prog);
+ caml_win32_maperr(GetLastError());
+ caml_uerror("create_process_pty", prog);
}
prepareSiWithPty(prog, &si, hpc);
@@ -297,19 +253,19 @@ CAMLprim value w_create_process_pty_native
hp = GetCurrentProcess();
if (!DuplicateHandle(hp, Handle_val(fd1), hp, &(si.StartupInfo.hStdInput),
0, TRUE, DUPLICATE_SAME_ACCESS)) {
- win32_maperr(GetLastError());
+ caml_win32_maperr(GetLastError());
err = TRUE;
goto clean1;
}
if (!DuplicateHandle(hp, Handle_val(fd2), hp, &(si.StartupInfo.hStdOutput),
0, TRUE, DUPLICATE_SAME_ACCESS)) {
- win32_maperr(GetLastError());
+ caml_win32_maperr(GetLastError());
err = TRUE;
goto clean2;
}
if (!DuplicateHandle(hp, Handle_val(fd3), hp, &(si.StartupInfo.hStdError),
0, TRUE, DUPLICATE_SAME_ACCESS)) {
- win32_maperr(GetLastError());
+ caml_win32_maperr(GetLastError());
err = TRUE;
goto clean3;
}
@@ -321,7 +277,7 @@ CAMLprim value w_create_process_pty_native
if (!UpdateProcThreadAttribute(si.lpAttributeList, 0,
PROC_THREAD_ATTRIBUTE_HANDLE_LIST, inherit, sizeof(HANDLE) * 3,
NULL, NULL)) {
- win32_maperr(GetLastError());
+ caml_win32_maperr(GetLastError());
err = TRUE;
goto clean4;
}
@@ -329,12 +285,12 @@ CAMLprim value w_create_process_pty_native
flags = GetPriorityClass(GetCurrentProcess());
flags |= EXTENDED_STARTUPINFO_PRESENT;
- wargs = Tcaml_stat_strdup_to_utf16(String_val(args));
+ wargs = caml_stat_strdup_to_utf16(String_val(args));
res = CreateProcessW(fullname, wargs, NULL, NULL, TRUE, flags,
NULL, NULL, &si.StartupInfo, &pi);
caml_stat_free(wargs);
if (res == 0) {
- win32_maperr(GetLastError());
+ caml_win32_maperr(GetLastError());
err = TRUE;
}
@@ -349,7 +305,7 @@ clean1:
free(si.lpAttributeList);
if (err) {
- uerror("create_process_pty", prog);
+ caml_uerror("create_process_pty", prog);
}
CloseHandle(pi.hThread);
@@ -363,27 +319,64 @@ CAMLprim value w_create_process_pty(value *argv, int argn)
argv[3], argv[4], argv[5]);
}
+CAMLprim value win_alloc_console(value unit)
+{
+ CAMLparam0();
+ CAMLlocal1(some);
+ HANDLE stderr_orig;
+ FILE *ign;
+
+ stderr_orig = (HANDLE) GetStdHandle(STD_ERROR_HANDLE);
+
+ if (!AllocConsole()) {
+ caml_win32_maperr(GetLastError());
+ caml_uerror("alloc_console", Nothing);
+ }
+
+ /* If a new console was allocated then we need to make sure that both the
+ * Windows C runtime stderr and the STD_ERROR_HANDLE for the child process
+ * are associated with the new console, unless already redirected or
+ * associated elsewhere.
+ * We are not interested in stdin and stdout for this specific scenario
+ * (as a fallback for the real pty). */
+ if (_fileno(stderr) < 0) freopen_s(&ign, "CONOUT$", "w", stderr);
+
+ if (!GetFileType(stderr_orig)) {
+ some = caml_alloc(1, 0);
+ Store_field(some, 0,
+ caml_win32_alloc_handle((HANDLE) GetStdHandle(STD_ERROR_HANDLE)));
+ CAMLreturn(some);
+ }
+
+ CAMLreturn(Val_int(0));
+}
+
#else // not _WIN32
CAMLprim value w_create_process_pty_native
(value prog, value args, value pty, value fd1, value fd2, value fd3)
{
- unix_error(ENOSYS, "create_process_pty", Nothing);
+ caml_unix_error(ENOSYS, "create_process_pty", Nothing);
}
CAMLprim value w_create_process_pty(value *argv, int argn)
{
- unix_error(ENOSYS, "create_process_pty", Nothing);
+ caml_unix_error(ENOSYS, "create_process_pty", Nothing);
}
CAMLprim value win_openpty()
{
- unix_error(ENOSYS, "openpty", Nothing);
+ caml_unix_error(ENOSYS, "openpty", Nothing);
}
CAMLprim value win_closepty(value pty)
{
- unix_error(ENOSYS, "closepty", Nothing);
+ caml_unix_error(ENOSYS, "closepty", Nothing);
+}
+
+CAMLprim value win_alloc_console()
+{
+ caml_unix_error(ENOSYS, "alloc_console", Nothing);
}
#endif
diff --git a/src/recon.ml b/src/recon.ml
index 57f495a..a3ba18b 100644
--- a/src/recon.ml
+++ b/src/recon.ml
@@ -66,8 +66,23 @@ let revertToDefaultDirection ri =
(* 'Replica2ToReplica1 *)
(* -- *)
let root2direction root =
+ let partialMatch s = function
+ | Clroot.ConnectLocal (None | Some "") -> false
+ | Clroot.ConnectLocal (Some root) ->
+ Util.startswith root s || Util.endswith root s
+ | ConnectByShell (_, host, _, _, Some root)
+ | ConnectBySocket (host, _, Some root) ->
+ Util.startswith root s || Util.endswith root s || Util.startswith host s
+ | ConnectByShell (_, host, _, _, None)
+ | ConnectBySocket (host, _, None) ->
+ Util.startswith host s
+ in
+ let partialRootMatches prefVal =
+ Safelist.map (partialMatch prefVal) (Globals.parsedClRawRoots ())
+ in
if root="older" then `Older
else if root="newer" then `Newer
+ else if root = "" then `None
else
let (r1, r2) = Globals.rawRootPair () in
debug (fun() ->
@@ -75,18 +90,38 @@ let root2direction root =
root r1 r2);
if r1 = root then `Replica1ToReplica2 else
if r2 = root then `Replica2ToReplica1 else
- raise (Util.Fatal (Printf.sprintf
- "%s (given as argument to 'prefer' or 'force' preference)\nis not one of \
- the current roots:\n %s\n %s" root r1 r2))
+ match partialRootMatches root with
+ | [true; false] -> `Replica1ToReplica2
+ | [false; true] -> `Replica2ToReplica1
+ | _ ->
+ raise (Util.Fatal (Printf.sprintf "%s\nis not uniquely identifying one \
+ of the current roots:\n %s\n %s" root r1 r2))
+
+let rootDirCache = ref []
+
+let clearRootDirCache () = rootDirCache := []
+
+let prefRoot prefV =
+ (* Use physical equality with cache keys. The goal is not to avoid as many
+ cache misses as possible but to make cache checking much cheaper than
+ calculating the value (in this case, hashing and string comparison are
+ not quite cheap enough). *)
+ match List.assq_opt prefV !rootDirCache with
+ | Some x -> x
+ | None -> let x = root2direction prefV in
+ rootDirCache := (prefV, x) :: !rootDirCache; x
let forceRoot: string Prefs.t =
Prefs.createString "force" ""
- "!force changes from this replica to the other"
+ ~category:(`Advanced `Sync)
+ "force changes from this replica to the other"
("Including the preference \\texttt{-force \\ARG{root}} causes Unison to "
^ "resolve all differences (even non-conflicting changes) in favor of "
^ "\\ARG{root}. "
^ "This effectively changes Unison from a synchronizer into a mirroring "
^ "utility. \n\n"
+ ^ "You can also specify a unique prefix or suffix of the path of one of "
+ ^ "the roots or a unique prefix of the hostname of a remote root.\n\n"
^ "You can also specify \\verb|-force newer| (or \\verb|-force older|) "
^ "to force Unison to choose the file with the later (earlier) "
^ "modtime. In this case, the \\verb|-times| preference must also "
@@ -96,15 +131,18 @@ let forceRoot: string Prefs.t =
^ "know what you are doing!")
let forceRootPartial: Pred.t =
- Pred.create "forcepartial" ~advanced:true
+ Pred.create "forcepartial"
+ ~category:(`Advanced `Sync)
("Including the preference \\texttt{forcepartial = \\ARG{PATHSPEC} -> \\ARG{root}} causes Unison to "
^ "resolve all differences (even non-conflicting changes) in favor of "
^ "\\ARG{root} for the files in \\ARG{PATHSPEC} (see \\sectionref{pathspec}{Path Specification} "
^ "for more information). "
^ "This effectively changes Unison from a synchronizer into a mirroring "
^ "utility. \n\n"
+ ^ "You can also specify a unique prefix or suffix of the path of one of "
+ ^ "the roots or a unique prefix of the hostname of a remote root.\n\n"
^ "You can also specify \\verb|forcepartial PATHSPEC -> newer| "
- ^ "(or \\verb|forcepartial PATHSPEC older|) "
+ ^ "(or \\verb|forcepartial PATHSPEC -> older|) "
^ "to force Unison to choose the file with the later (earlier) "
^ "modtime. In this case, the \\verb|-times| preference must also "
^ "be enabled.\n\n"
@@ -113,19 +151,23 @@ let forceRootPartial: Pred.t =
let preferRoot: string Prefs.t =
Prefs.createString "prefer" ""
- "!choose this replica's version for conflicting changes"
+ ~category:(`Advanced `Sync)
+ "choose this replica's version for conflicting changes"
("Including the preference \\texttt{-prefer \\ARG{root}} causes Unison always to "
^ "resolve conflicts in favor of \\ARG{root}, rather than asking for "
^ "guidance from the user, except for paths marked by the preference "
^ "\\texttt{merge}. (The syntax of \\ARG{root} is the same as "
^ "for the \\verb|root| preference, plus the special values "
^ "\\verb|newer| and \\verb|older|.) \n\n"
+ ^ "You can also specify a unique prefix or suffix of the path of one of "
+ ^ "the roots or a unique prefix of the hostname of a remote root.\n\n"
^ "This preference is overridden by the \\verb|preferpartial| preference.\n\n"
^ "This preference should be used only if you are {\\em sure} you "
^ "know what you are doing!")
let preferRootPartial: Pred.t =
- Pred.create "preferpartial" ~advanced:true
+ Pred.create "preferpartial"
+ ~category:(`Advanced `Sync)
("Including the preference \\texttt{preferpartial = \\ARG{PATHSPEC} -> \\ARG{root}} "
^ "causes Unison always to "
^ "resolve conflicts in favor of \\ARG{root}, rather than asking for "
@@ -134,6 +176,8 @@ let preferRootPartial: Pred.t =
^ "for more information). (The syntax of \\ARG{root} is the same as "
^ "for the \\verb|root| preference, plus the special values "
^ "\\verb|newer| and \\verb|older|.) \n\n"
+ ^ "You can also specify a unique prefix or suffix of the path of one of "
+ ^ "the roots or a unique prefix of the hostname of a remote root.\n\n"
^ "This preference should be used only if you are {\\em sure} you "
^ "know what you are doing!")
@@ -141,50 +185,60 @@ let preferRootPartial: Pred.t =
(* preferences "force"/"preference", returns a pair (root, force) *)
let lookupPreferredRoot () =
if Prefs.read forceRoot <> "" then
- (Prefs.read forceRoot, `Force)
+ (prefRoot (Prefs.read forceRoot), `Force)
else if Prefs.read preferRoot <> "" then
- (Prefs.read preferRoot, `Prefer)
+ (prefRoot (Prefs.read preferRoot), `Prefer)
else
- ("",`Prefer)
+ (`None, `Prefer)
(* [lookupPreferredRootPartial: Path.t -> string * [`Force | `Prefer]] checks validity of *)
(* preferences "forcepartial", returns a pair (root, force) *)
let lookupPreferredRootPartial p =
let s = Path.toString p in
if Pred.test forceRootPartial s then
- (Pred.assoc forceRootPartial s, `Force)
+ (prefRoot (Pred.assoc forceRootPartial s), `Force)
else if Pred.test preferRootPartial s then
- (Pred.assoc preferRootPartial s, `Prefer)
+ (prefRoot (Pred.assoc preferRootPartial s), `Prefer)
else
- ("",`Prefer)
+ (`None, `Prefer)
let noDeletion =
Prefs.createStringList "nodeletion"
+ ~category:(`Basic `Sync)
"prevent file deletions on one replica"
("Including the preference \\texttt{-nodeletion \\ARG{root}} prevents \
Unison from performing any file deletion on root \\ARG{root}.\n\n\
+ You can also specify a unique prefix or suffix of the path of one of \
+ the roots or a unique prefix of the hostname of a remote root.\n\n\
This preference can be included twice, once for each root, if you \
want to prevent any deletion.")
let noUpdate =
Prefs.createStringList "noupdate"
+ ~category:(`Basic `Sync)
"prevent file updates and deletions on one replica"
("Including the preference \\texttt{-noupdate \\ARG{root}} prevents \
Unison from performing any file update or deletion on root \
\\ARG{root}.\n\n\
+ You can also specify a unique prefix or suffix of the path of one of \
+ the roots or a unique prefix of the hostname of a remote root.\n\n\
This preference can be included twice, once for each root, if you \
want to prevent any update.")
let noCreation =
Prefs.createStringList "nocreation"
+ ~category:(`Basic `Sync)
"prevent file creations on one replica"
("Including the preference \\texttt{-nocreation \\ARG{root}} prevents \
Unison from performing any file creation on root \\ARG{root}.\n\n\
+ You can also specify a unique prefix or suffix of the path of one of \
+ the roots or a unique prefix of the hostname of a remote root.\n\n\
This preference can be included twice, once for each root, if you \
want to prevent any creation.")
let noDeletionPartial =
- Pred.create "nodeletionpartial" ~advanced:true
+ Pred.create "nodeletionpartial"
+ ~category:(`Advanced `Sync)
("Including the preference \
\\texttt{nodeletionpartial = \\ARG{PATHSPEC} -> \\ARG{root}} prevents \
Unison from performing any file deletion in \\ARG{PATHSPEC} \
@@ -193,7 +247,8 @@ let noDeletionPartial =
patterns when selecting a directory and all its contents.")
let noUpdatePartial =
- Pred.create "noupdatepartial" ~advanced:true
+ Pred.create "noupdatepartial"
+ ~category:(`Advanced `Sync)
("Including the preference \
\\texttt{noupdatepartial = \\ARG{PATHSPEC} -> \\ARG{root}} prevents \
Unison from performing any file update or deletion in \
@@ -203,7 +258,8 @@ let noUpdatePartial =
patterns when selecting a directory and all its contents.")
let noCreationPartial =
- Pred.create "nocreationpartial" ~advanced:true
+ Pred.create "nocreationpartial"
+ ~category:(`Advanced `Sync)
("Including the preference \
\\texttt{nocreationpartial = \\ARG{PATHSPEC} -> \\ARG{root}} prevents \
Unison from performing any file creation in \\ARG{PATHSPEC} \
@@ -214,24 +270,33 @@ let noCreationPartial =
let maxSizeThreshold =
Prefs.createInt "maxsizethreshold" (-1)
- "!prevent transfer of files bigger than this (if >=0, in Kb)"
+ ~category:(`Advanced `General)
+ "prevent transfer of files bigger than this (if >=0, in Kb)"
("A number indicating above what filesize (in kilobytes) Unison should "
^ "flag a conflict instead of transferring the file. "
^ "This conflict remains even in the presence of force or prefer options. "
^ "A negative number will allow every transfer independently of the size. "
^ "The default is -1. ")
-let partialCancelPref actionKind =
- match actionKind with
- `DELETION -> noDeletionPartial
- | `UPDATE -> noUpdatePartial
- | `CREATION -> noCreationPartial
-
-let cancelPref actionKind =
- match actionKind with
- `DELETION -> noDeletion
- | `UPDATE -> noUpdate
- | `CREATION -> noCreation
+let testPartialCancelPref root path actionKind =
+ let partialCancelPref actionKind =
+ match actionKind with
+ `DELETION -> noDeletionPartial
+ | `UPDATE -> noUpdatePartial
+ | `CREATION -> noCreationPartial
+ in
+ Pred.assoc_all (partialCancelPref actionKind) path
+ |> List.exists (fun x -> root = prefRoot x)
+
+let testCancelPref root actionKind =
+ let cancelPref actionKind =
+ match actionKind with
+ `DELETION -> noDeletion
+ | `UPDATE -> noUpdate
+ | `CREATION -> noCreation
+ in
+ Prefs.read (cancelPref actionKind)
+ |> List.exists (fun x -> root = prefRoot x)
let actionKind fromRc toRc =
let fromTyp = fromRc.typ in
@@ -240,11 +305,11 @@ let actionKind fromRc toRc =
if toTyp = `ABSENT then `CREATION else
`DELETION
-let shouldCancel path rc1 rc2 root2 =
+let shouldCancel path rc1 rc2 root =
let test kind =
- List.mem root2 (Prefs.read (cancelPref kind))
+ testCancelPref root kind
||
- List.mem root2 (Pred.assoc_all (partialCancelPref kind) path)
+ testPartialCancelPref root path kind
in
let testSize rc =
Prefs.read maxSizeThreshold >= 0
@@ -264,7 +329,7 @@ let shouldCancel path rc1 rc2 root2 =
if test `CREATION then true, "would create a file with nocreation or nocreationpartial set"
else testSize rc1, "would transfer a file of size greater than maxsizethreshold"
-let filterRi root1 root2 ri =
+let filterRi ri =
match ri.replicas with
Problem _ ->
()
@@ -272,9 +337,9 @@ let filterRi root1 root2 ri =
let cancel,reason =
match diff.direction with
Replica1ToReplica2 ->
- shouldCancel (Path.toString ri.path1) diff.rc1 diff.rc2 root2
+ shouldCancel (Path.toString ri.path1) diff.rc1 diff.rc2 `Replica2ToReplica1
| Replica2ToReplica1 ->
- shouldCancel (Path.toString ri.path1) diff.rc2 diff.rc1 root1
+ shouldCancel (Path.toString ri.path1) diff.rc2 diff.rc1 `Replica1ToReplica2
| Conflict _ | Merge ->
false,""
in
@@ -283,57 +348,51 @@ let filterRi root1 root2 ri =
diff.direction <- Conflict reason
let filterRis ris =
- let (root1, root2) = Globals.rawRootPair () in
- Safelist.iter (fun ri -> filterRi root1 root2 ri) ris
+ Safelist.iter filterRi ris
(* Use the current values of the '-prefer <ROOT>' and '-force <ROOT>' *)
(* preferences to override the reconciler's choices *)
let overrideReconcilerChoices ris =
- let (root,force) = lookupPreferredRoot() in
- if root<>"" then begin
- let dir = root2direction root in
- Safelist.iter (fun ri -> setDirection ri dir force) ris
- end;
+ clearRootDirCache ();
+ let (dir, force) = lookupPreferredRoot () in
+ if dir <> `None then Safelist.iter (fun ri -> setDirection ri dir force) ris;
Safelist.iter (fun ri ->
- let (rootp,forcep) = lookupPreferredRootPartial ri.path1 in
- if rootp<>"" then begin
- let dir = root2direction rootp in
- setDirection ri dir forcep
- end) ris;
+ let (dir, forcep) = lookupPreferredRootPartial ri.path1 in
+ if dir <> `None then setDirection ri dir forcep) ris;
filterRis ris
(* Look up the preferred root and verify that it is OK (this is called at *)
(* the beginning of the run, so that we don't have to wait to hear about *)
(* errors *)
let checkThatPreferredRootIsValid () =
- let test_root predname = function
- | "" | "newer" -> ()
- | "older" as r ->
+ let test_root explicitRoot predname predvalue =
+ match prefRoot predvalue with
+ | `None | `Replica1ToReplica2 | `Replica2ToReplica1 -> ()
+ | (`Newer | `Older) when explicitRoot ->
+ raise (Util.Fatal ("Argument to preference '" ^ predname ^ "': "
+ ^ predvalue ^ " must not be keyword 'older' or 'newer'."))
+ | `Newer -> ()
+ | `Older ->
if not (Prefs.read Props.syncModtimes) then
raise (Util.Transient (Printf.sprintf
- "The '%s=%s' preference can only be used with 'times=true'"
- predname r))
- | r -> ignore (root2direction r) in
- let (root,pred) = lookupPreferredRoot() in
- if root<>"" then test_root (match pred with `Force -> "force" | `Prefer -> "prefer") root;
- Safelist.iter (test_root "forcepartial") (Pred.extern_associated_strings forceRootPartial);
- Safelist.iter (test_root "preferpartial") (Pred.extern_associated_strings preferRootPartial);
- let checkPref extract (pref, prefName) =
- try
- let root =
- List.find (fun r -> not (List.mem r (Globals.rawRoots ())))
- (extract pref)
- in
- let (r1, r2) = Globals.rawRootPair () in
- raise (Util.Fatal (Printf.sprintf
- "%s (given as argument to '%s' preference)\n\
- is not one of the current roots:\n %s\n %s" root prefName r1 r2))
- with Not_found ->
- ()
+ "The '%s=older' preference can only be used with 'times=true'"
+ predname))
+ | `Merge -> assert false
+ | exception (Util.Fatal err) ->
+ raise (Util.Fatal ("Argument to preference '" ^ predname ^ "': " ^ err))
+ in
+ let checkPrefs ~explicitRoot extract prefs =
+ Safelist.iter (fun (pref, prefName) ->
+ Safelist.iter (test_root explicitRoot prefName) (extract pref)) prefs
in
- List.iter (checkPref Prefs.read)
+ checkPrefs ~explicitRoot:false (fun x -> [Prefs.read x])
+ [forceRoot, "force"; preferRoot, "prefer"];
+ checkPrefs ~explicitRoot:false Pred.extern_associated_strings
+ [forceRootPartial, "forcepartial";
+ preferRootPartial, "preferpartial"];
+ checkPrefs ~explicitRoot:true Prefs.read
[noDeletion, "nodeletion"; noUpdate, "noupdate"; noCreation, "nocreation"];
- List.iter (checkPref Pred.extern_associated_strings)
+ checkPrefs ~explicitRoot:true Pred.extern_associated_strings
[noDeletionPartial, "nodeletionpartial";
noUpdatePartial, "noupdatepartial";
noCreationPartial, "nocreationpartial"]
@@ -349,7 +408,7 @@ let rec checkForError ui =
NoUpdates ->
()
| Error err ->
- raise (UpdateError err)
+ if not (Fileinfo.shouldIgnore err) then raise (UpdateError err)
| Updates (uc, _) ->
match uc with
Dir (_, children, _, _) ->
@@ -362,7 +421,7 @@ let rec collectErrors ui rem =
NoUpdates ->
rem
| Error err ->
- err :: rem
+ if Fileinfo.shouldIgnore err then rem else err :: rem
| Updates (uc, _) ->
match uc with
Dir (_, children, _, _) ->
@@ -391,6 +450,22 @@ let propagateErrors allowPartial (rplc: Common.replicas): Common.replicas =
with UpdateError err ->
Problem ("[root 1]: " ^ err)
+(* Using the error message to ignore symlinks is a bit fragile but this is
+ the easiest way to keep code changes local and avoid a huge backwards
+ compatibility burden. *)
+
+let skipIgnored result s othUi =
+ match Fileinfo.shouldIgnore s, othUi with
+ | false, _ -> Tree.add result (Problem s)
+ | true, Error s2 ->
+ if Fileinfo.shouldIgnore s2 then result else Tree.add result (Problem s2)
+ | true, NoUpdates
+ | true, Updates (Symlink _, _) -> result
+ | true, Updates _ ->
+ Tree.add result (Problem "Syncing symbolic links is disabled, but \
+ this path represents a symbolic link in one of the replicas and \
+ a non-link in the other replica.")
+
type singleUpdate = Rep1Updated | Rep2Updated
let update2replicaContent path (conflict: bool) ui props ucNew oldType:
@@ -477,7 +552,7 @@ let rec reconcileNoConflict allowPartial path props' ui props whatIsUpdated
match ui with
| NoUpdates -> result
| Error err ->
- Tree.add result (Problem err)
+ skipIgnored result err NoUpdates
| Updates (Dir (desc, children, permchg, _),
Previous(`DIRECTORY, _, _, _)) ->
let r =
@@ -566,9 +641,9 @@ let rec reconcile
errors1 = []; errors2 = []}))) in
match (ui1, ui2) with
(Error s, _) ->
- (equals, Tree.add unequals (Problem s))
+ (equals, skipIgnored unequals s ui2)
| (_, Error s) ->
- (equals, Tree.add unequals (Problem s))
+ (equals, skipIgnored unequals s ui1)
| (NoUpdates, _) ->
(equals,
reconcileNoConflict
@@ -642,6 +717,9 @@ let rec reconcile
(oldType prev) equals unequals
| ContentsSame, ContentsSame when Props.similar desc1 desc2 ->
(add_equal counter equals (uc1, uc2), unequals)
+ | ContentsSame, ContentsSame ->
+ different uc1 uc2 "properties changed on both sides"
+ (oldType prev) equals unequals
| ContentsUpdated _, ContentsUpdated _
when Globals.shouldMerge path ->
toBeMerged uc1 uc2 (oldType prev) equals unequals
diff --git a/src/remote.ml b/src/remote.ml
index b2ff84f..d101c39 100644
--- a/src/remote.ml
+++ b/src/remote.ml
@@ -81,23 +81,53 @@ let decodeInt int_buf i =
(* LOW-LEVEL IO *)
(*************************************************************************)
-let lostConnection () =
+let ioCleanups = ref []
+
+let registerIOClose io f =
+ ioCleanups := (io, f) :: !ioCleanups
+
+let lostConnectionHandler ch =
+ let aux ((i, o), f) =
+ if i = ch || o = ch then begin
+ f ();
+ false (* Each handler is run only once *)
+ end else
+ true
+ in
+ ioCleanups := Safelist.filter aux !ioCleanups
+
+let lostConnection ch =
+ begin try lostConnectionHandler ch with _ -> () end;
Lwt.fail (Util.Fatal "Lost connection with the server")
-let catchIoErrors th =
+let catchIoErrors ch th =
Lwt.catch th
(fun e ->
match e with
Unix.Unix_error(Unix.ECONNRESET, _, _)
| Unix.Unix_error(Unix.EPIPE, _, _)
+ | Unix.Unix_error(Unix.ETIMEDOUT, _, _)
+ | Unix.Unix_error(Unix.EACCES, _, _) (* Linux firewall *)
(* Windows may also return the following errors... *)
- | Unix.Unix_error(Unix.EINVAL, _, _)
+ | Unix.Unix_error(Unix.EINVAL, _, _) (* ... and Linux firewall *)
| Unix.Unix_error(Unix.EUNKNOWNERR (-64), _, _)
(* ERROR_NETNAME_DELETED *)
- | Unix.Unix_error(Unix.EUNKNOWNERR (-233), _, _) ->
+ | Unix.Unix_error(Unix.EUNKNOWNERR (-233), _, _)
(* ERROR_PIPE_NOT_CONNECTED *)
+ | Unix.Unix_error(Unix.EUNKNOWNERR (-1236), _, _)
+ (* ERROR_CONNECTION_ABORTED *)
+ (* The following errors _may_ be temporary but we don't know if
+ they are or for how long they will persist. We also don't have
+ a way to retry and there is no guarantee that the socket remains
+ in a usable state, so treat all these as permanent failures
+ breaking the connection. *)
+ | Unix.Unix_error(Unix.ENETUNREACH, _, _)
+ | Unix.Unix_error(Unix.EHOSTUNREACH, _, _)
+ | Unix.Unix_error(Unix.ENETDOWN, _, _)
+ | Unix.Unix_error(Unix.EHOSTDOWN, _, _)
+ | Unix.Unix_error(Unix.ENETRESET, _, _) ->
(* Client has closed its end of the connection *)
- lostConnection ()
+ lostConnection ch
| _ ->
Lwt.fail e)
@@ -130,7 +160,7 @@ let makeBuffer ch =
let fillInputBuffer conn =
assert (conn.length = 0);
- catchIoErrors
+ catchIoErrors conn.channel
(fun () ->
Lwt_unix.read conn.channel conn.buffer 0 bufferSize >>= fun len ->
debugV (fun() ->
@@ -140,7 +170,7 @@ let fillInputBuffer conn =
Util.msg "grab: %s\n"
(String.escaped (Bytes.sub_string conn.buffer 0 len)));
if len = 0 then
- lostConnection ()
+ lostConnection conn.channel
else begin
receivedBytes := !receivedBytes +. float len;
conn.length <- len;
@@ -171,12 +201,19 @@ let grab conn s len =
let peekWithoutBlocking conn =
Bytes.sub conn.buffer 0 conn.length
+let peekWithBlocking conn =
+ (if conn.length = 0 then begin
+ fillInputBuffer conn
+ end else
+ Lwt.return ()) >>= fun () ->
+ Lwt.return (peekWithoutBlocking conn)
+
(****)
(* Low-level outputs *)
let rec sendOutput conn =
- catchIoErrors
+ catchIoErrors conn.channel
(fun () ->
begin if conn.opened then
Lwt_unix.write conn.channel conn.buffer 0 conn.length
@@ -289,16 +326,44 @@ let disableFlowControl q =
let outputQueueIsEmpty q = q.available
+(* Setup IO with flow control initially disabled, to do the RPC version
+ handshake. Flow control is part of RPC protocol and must be enabled
+ only after RPC version handshake is complete. *)
let makeOutputQueue isServer flush =
- { available = true; canWrite = isServer; flowControl = true;
+ { available = true; canWrite = true; flowControl = false;
writes = Queue.create (); urgentWrites = Queue.create ();
idleWrites = Queue.create ();
flush = flush }
(****)
+(* IMPORTANT: the RPC version must be increased when the RPC mechanism itself
+ changes in a breaking way. Changes on the API level (functions and data
+ types) normally do not cause a breaking change at the RPC level. *)
+(* Version 0 is special in that it must not be listed as a supported version.
+ It is used for 2.51-compatibility mode and is never negotiated. *)
+(* Supported RPC versions should be ordered from newest to oldest. *)
+let rpcSupportedVersions = [1]
+let rpcDefaultVersion = Safelist.hd rpcSupportedVersions
+
+let rpcSupportedVersionStr =
+ String.concat ", "
+ (Safelist.map (fun v -> "\"" ^ string_of_int v ^ "\"")
+ rpcSupportedVersions)
+
+let rpcSupportedVersionStrHdr =
+ String.concat " "
+ (Safelist.map (fun v -> string_of_int v)
+ rpcSupportedVersions)
+
+(* FIX: Added in 2021. Should be removed after a couple of years. *)
+let rpcServerCmdlineOverride = "__new-rpc-mode"
+
+(****)
+
type connection =
- { inputBuffer : ioBuffer;
+ { mutable version : int;
+ inputBuffer : ioBuffer;
outputBuffer : ioBuffer;
outputQueue : outputQueue }
@@ -335,12 +400,32 @@ let maybeFlush pendingFlush q buf =
let makeConnection isServer inCh outCh =
let pendingFlush = ref false in
let outputBuffer = makeBuffer outCh in
- { inputBuffer = makeBuffer inCh;
+ { version = rpcDefaultVersion;
+ inputBuffer = makeBuffer inCh;
outputBuffer = outputBuffer;
outputQueue =
makeOutputQueue isServer
(fun q -> maybeFlush pendingFlush q outputBuffer) }
+let closeConnection conn =
+ begin try Lwt_unix.close conn.inputBuffer.channel with Unix.Unix_error _ -> () end;
+ begin try Lwt_unix.close conn.outputBuffer.channel with Unix.Unix_error _ -> () end;
+ conn.outputBuffer.opened <- false
+
+let connectionIO conn =
+ (conn.inputBuffer.channel, conn.outputBuffer.channel)
+
+let setConnectionVersion conn ver =
+ conn.version <- ver
+
+let connectionVersion conn = conn.version
+
+let connEq conn conn' =
+ conn.inputBuffer.channel = conn'.inputBuffer.channel
+ && conn.outputBuffer.channel = conn'.outputBuffer.channel
+
+let connNeq conn conn' = not (connEq conn conn')
+
(* Send message [l] *)
let dump conn l =
performOutput
@@ -361,11 +446,204 @@ let dumpUrgent conn l =
fillBuffer conn.outputBuffer l >>= fun () ->
flushBuffer conn.outputBuffer)
+let enableFlowControl conn isServer =
+ let rec waitDrain () =
+ if not isServer && conn.outputBuffer.length > 0 then
+ Lwt_unix.yield () >>= waitDrain
+ else
+ Lwt.return ()
+ in
+ let q = conn.outputQueue in
+ q.available <- false;
+ waitDrain () >>= fun () ->
+ q.flowControl <- true;
+ q.canWrite <- isServer;
+ if q.canWrite then
+ popOutputQueues q >>= Lwt_unix.yield >>= fun () ->
+ Lwt.return ()
+ else
+ Lwt.return ()
+
+(****)
+
+let connectionCheck = ref None
+
+let checkConnection ioServer =
+ connectionCheck := Some ioServer;
+ (* Poke on the socket to trigger an error if connection has been lost. *)
+ Lwt_unix.run (
+ (if (Util.osType = `Win32) then Lwt.return 0 else
+ Lwt_unix.read ioServer.inputBuffer.channel ioServer.inputBuffer.buffer 0 0)
+ (* Try to make sure connection cleanup, if necessary, has finished
+ before returning.
+ Since there is no way to reliably detect when other threads have
+ finished, we just yield a bit (the same comments apply as in
+ commandLoop). *)
+ >>= fun _ ->
+ let rec wait n =
+ if n = 0 then Lwt.return () else begin
+ Lwt_unix.yield () >>= fun () ->
+ wait (n - 1)
+ end
+ in
+ wait 10);
+ connectionCheck := None
+
+let isConnectionCheck conn =
+ match !connectionCheck with
+ | None -> false
+ | Some conn' -> connEq conn conn'
+
+(* Due to [Common.root] currently excluding important details present in
+ [Clroot.clroot], there is a 1:N mapping between a [root] and a [clroot].
+ For example, a [clroot] pointing to the same host but a different
+ protocol or user or port will be mapped to the same [root] as long as
+ the root fspaths are the same.
+ It is currently (Oct 2022) not seen as a critical issue to fix.
+ The code previously used to index connections just by the canonical host
+ name, ignoring all other details, including the root fspath. That code
+ was in place for over 20 years and did not seem to cause any issues.
+ The current code is safer than the previous code... *)
+module ClientConn = struct
+ type t =
+ { clroot : Clroot.clroot;
+ root : Common.root;
+ conn : connection }
+ (* Never do polymorphic comparisons with [connection]! *)
+
+ let connections = ref []
+
+ let findByClroot clroot = Safelist.find (fun x -> x.clroot = clroot) !connections
+ let findByRoot root = Safelist.find (fun x -> x.root = root) !connections
+
+ let register clroot root conn =
+ connections := { clroot; root; conn } ::
+ Safelist.filter (fun x -> x.clroot <> clroot) !connections
+
+ let unregister conn =
+ connections := Safelist.filter (fun x -> connNeq x.conn conn) !connections
+
+ let ofRoot root =
+ try (findByRoot root).conn with
+ | Not_found -> raise (Util.Fatal "No connection with the server")
+
+ let ofRootOpt root =
+ try Some (findByRoot root).conn with
+ | Not_found -> None
+
+ let canonRootOfClroot clroot =
+ try Some (findByClroot clroot).root with
+ | Not_found -> None
+
+ let withConncheck find =
+ try
+ let conn = (find ()).conn in
+ begin try
+ checkConnection conn
+ with
+ | Unix.Unix_error (EBADF, _, _) -> (* Already closed *)
+ unregister conn
+ (* (All or most?) other exceptions should be caught by receiving and
+ sending threads. If this does not happen (it also depends on the
+ implementation of [Lwt_unix.run]) then trigger the cleanup here as
+ the last resort. *)
+ | Unix.Unix_error _ ->
+ try
+ lostConnection (fst (connectionIO conn)) |> ignore;
+ unregister conn
+ with e -> begin
+ unregister conn;
+ raise e
+ end
+ end;
+ (* [find] _must_ be duplicated after [checkConnection]! *)
+ Some (find ()).conn
+ with Not_found ->
+ None
+
+ let ofRootConncheck root =
+ withConncheck (fun () -> findByRoot root)
+
+ let ofClrootConncheck clroot =
+ withConncheck (fun () -> findByClroot clroot)
+
+end (* module ClientConn *)
+
+let connectionOfRoot root = ClientConn.ofRoot root
+
+(****)
+
+let atCloseHandlers = ref []
+
+let at_conn_close ?(only_server = false) f =
+ atCloseHandlers := (only_server, f) :: !atCloseHandlers
+
+let runConnCloseHandlers isServer =
+ Safelist.iter (fun (only_server, f) ->
+ if not only_server || isServer then f ()) !atCloseHandlers
+
+let atConnCloseHandlers = ref []
+
+let at_conn_close' conn f =
+ atConnCloseHandlers := (conn, f) :: !atConnCloseHandlers
+
+let runConnCloseHandlers' conn =
+ atConnCloseHandlers := Safelist.filter (fun (c, f) ->
+ if connEq c conn then (f (); false) else true) !atConnCloseHandlers
+
+let clientCloseCleanup () =
+ runConnCloseHandlers false
+
+let clientConnClose conn =
+ closeConnection conn;
+ ClientConn.unregister conn;
+ runConnCloseHandlers' conn;
+ clientCloseCleanup ()
+
+let registerConnCleanup conn cleanup =
+ registerIOClose (connectionIO conn) (fun () -> clientConnClose conn);
+ match cleanup with
+ | None -> ()
+ | Some f -> at_conn_close' conn f
+
+let clientCloseRootConnection = function
+ | (Common.Local, _) -> clientCloseCleanup ()
+ | (Common.Remote _, _) as root ->
+ begin match ClientConn.ofRootOpt root with
+ | Some conn -> clientConnClose conn
+ | None -> ()
+ end
+
(****)
-(* Initialize the connection *)
-let setupIO isServer inCh outCh =
- makeConnection isServer inCh outCh
+(* Implemented as a record to avoid polluting [Remote] namespace. If
+ the number and complexity of functions grows in future then it's
+ probably a good idea to extract this code into a separate module. *)
+type ('a, 'b, 'c) resourceC =
+ { register : 'a -> 'a; release : 'a -> 'b; release_noerr : 'a -> 'c }
+let resourceWithConnCleanup close close_noerr =
+ let h = Hashtbl.create 17 in
+ let closeAll () =
+ Hashtbl.iter (fun x _ -> ignore (close_noerr x)) h;
+ Hashtbl.clear h
+ in
+ at_conn_close closeAll;
+ let register x = Hashtbl.add h x true; x in
+ let release x = Hashtbl.remove h x; close x in
+ let release_noerr x = Hashtbl.remove h x; close_noerr x in
+ { register; release; release_noerr }
+
+let lwtRegionWithConnCleanup sz =
+ let reg = ref (Lwt_util.make_region sz) in
+ let resetReg () =
+ Lwt_util.purge_region !reg;
+ (* The remaining threads should be collected by GC *)
+ reg := Lwt_util.make_region sz
+ in
+ at_conn_close resetReg;
+ reg
+
+(****)
(* XXX *)
module Thread = struct
@@ -394,11 +672,25 @@ end
type tag = Bytearray.t
-type 'a marshalFunction =
+type 'a marshalFunction = connection ->
'a -> (Bytearray.t * int * int) list -> (Bytearray.t * int * int) list
-type 'a unmarshalFunction = Bytearray.t -> 'a
+type 'a unmarshalFunction = connection -> Bytearray.t -> 'a
type 'a marshalingFunctions = 'a marshalFunction * 'a unmarshalFunction
+type 'a convV0Fun =
+ V0 : ('a -> 'compat) * ('compat -> 'a) -> 'a convV0Fun [@unboxed]
+
+external id : 'a -> 'a = "%identity"
+let convV0_id = V0 (id, id)
+let convV0_id_pair = convV0_id, convV0_id
+
+let makeConvV0FunArg compat_to compat_from =
+ (V0 (compat_to, compat_from)), convV0_id
+let makeConvV0FunRet compat_to compat_from =
+ convV0_id, (V0 (compat_to, compat_from))
+let makeConvV0Funs compat_to compat_from compat_to2 compat_from2 =
+ (V0 (compat_to, compat_from)), (V0 (compat_to2, compat_from2))
+
let registeredSet = ref Util.StringSet.empty
let rec first_chars len msg =
@@ -420,7 +712,18 @@ let safeMarshal marshalPayload tag data rem =
let start = String.escaped start in
Util.msg "send [%s] '%s' %d bytes\n"
(Bytearray.to_string tag) start length);
- (encodeInt (l + length) :: (tag, 0, l) :: rem')
+ let len = l + length in
+ if (len lsr 31) lsr 1 <> 0 then (* [encodeInt] can only encode 32 bits *)
+ raise (Util.Fatal
+ "Protocol error: message data too big. This may be a bug or it\n\
+ may be that your replicas are huge and the amount of updates\n\
+ can't be handled by the current protocol implementation. If you\n\
+ believe it is a bug then please consider reporting it.\n\
+ Otherwise, try reducing the amount of updates by syncing the\n\
+ replicas in smaller steps (using the \"path\" preference, for\n\
+ example). You may have to do this for the initial sync only.")
+ else
+ (encodeInt len :: (tag, 0, l) :: rem')
let safeUnmarshal unmarshalPayload tag buf =
let taglength = Bytearray.length tag in
@@ -441,23 +744,37 @@ let registerTag string =
registeredSet := Util.StringSet.add string !registeredSet;
Bytearray.of_string string
-let defaultMarshalingFunctions =
- (fun data rem ->
- let s = Bytearray.marshal data [Marshal.No_sharing] in
- let l = Bytearray.length s in
- ((s, 0, l) :: rem, l)),
- (fun buf pos ->
- try Bytearray.unmarshal buf pos
- with Failure s -> raise (Util.Fatal (Printf.sprintf
+let marshalV0 (V0 (to251, _)) data rem =
+ let s = Bytearray.marshal (to251 data) [Marshal.No_sharing] in
+ let l = Bytearray.length s in
+ ((s, 0, l) :: rem, l)
+
+let unmarshalV0 (V0 (_, from251)) buf pos =
+ try from251 (Bytearray.unmarshal buf pos)
+ with Failure s -> raise (Util.Fatal (Printf.sprintf
"Fatal error during unmarshaling (%s),
possibly because client and server have been compiled with different \
-versions of the OCaml compiler." s)))
+versions of the OCaml compiler." s))
+
+let marshalV1 m data rem =
+ let s = Umarshal.marshal_to_bytearray m data in
+ let l = Bytearray.length s in
+ ((s, 0, l) :: rem, l)
+
+let unmarshalV1 m buf pos =
+ try Umarshal.unmarshal_from_bytearray m buf pos
+ with Failure s | Umarshal.Error s -> raise (Util.Fatal (Printf.sprintf
+"Fatal error during unmarshaling (%s)" s))
+
+let defaultMarshalingFunctions convV0 m =
+ (fun conn -> if conn.version = 0 then marshalV0 convV0 else marshalV1 m),
+ (fun conn -> if conn.version = 0 then unmarshalV0 convV0 else unmarshalV1 m)
let makeMarshalingFunctions payloadMarshalingFunctions string =
let (marshalPayload, unmarshalPayload) = payloadMarshalingFunctions in
let tag = registerTag string in
- let marshal (data : 'a) rem = safeMarshal marshalPayload tag data rem in
- let unmarshal buf = (safeUnmarshal unmarshalPayload tag buf : 'a) in
+ let marshal conn (data : 'a) rem = safeMarshal (marshalPayload conn) tag data rem in
+ let unmarshal conn buf = (safeUnmarshal (unmarshalPayload conn) tag buf : 'a) in
(marshal, unmarshal)
(*****************************************************************************)
@@ -468,29 +785,15 @@ let makeMarshalingFunctions payloadMarshalingFunctions string =
these be part of it too? *)
let sshCmd =
Prefs.createString "sshcmd" "ssh"
- ("!path to the ssh executable")
+ ~category:(`Advanced `Remote)
+ ("path to the ssh executable")
("This preference can be used to explicitly set the name of the "
^ "ssh executable (e.g., giving a full path name), if necessary.")
-let rshCmd =
- Prefs.createString "rshcmd" "rsh"
- ("*path to the rsh executable")
- ("This preference can be used to explicitly set the name of the "
- ^ "rsh executable (e.g., giving a full path name), if necessary.")
-
-let rshargs =
- Prefs.createString "rshargs" ""
- "*other arguments (if any) for remote shell command"
- ("The string value of this preference will be passed as additional "
- ^ "arguments (besides the host name and the name of the Unison "
- ^ "executable on the remote system) to the \\verb|rsh| "
- ^ "command used to invoke the remote server. The backslash is an "
- ^ "escape character."
- )
-
let sshargs =
Prefs.createString "sshargs" ""
- "!other arguments (if any) for remote shell command"
+ ~category:(`Advanced `Remote)
+ "other arguments (if any) for remote shell command"
("The string value of this preference will be passed as additional "
^ "arguments (besides the host name and the name of the Unison "
^ "executable on the remote system) to the \\verb|ssh| "
@@ -498,16 +801,22 @@ let sshargs =
^ "escape character."
)
+(* rsh prefs removed since 2.52 *)
+let () = Prefs.markRemoved "rshcmd"
+let () = Prefs.markRemoved "rshargs"
+
let serverCmd =
Prefs.createString "servercmd" ""
- ("!name of " ^ Uutil.myName ^ " executable on remote server")
+ ~category:(`Advanced `Remote)
+ ("name of " ^ Uutil.myName ^ " executable on remote server")
("This preference can be used to explicitly set the name of the "
^ "Unison executable on the remote server (e.g., giving a full "
^ "path name), if necessary.")
let addversionno =
Prefs.createBool "addversionno" false
- ("!add version number to name of " ^ Uutil.myName ^ " on server")
+ ~category:(`Advanced `Remote)
+ ("add version number to name of " ^ Uutil.myName ^ " on server")
("When this flag is set to {\\tt true}, Unison "
^ "will use \\texttt{unison-\\ARG{currentmajorversionnumber}} instead of "
^ "just \\verb|unison| as the remote server command (note that the minor "
@@ -516,28 +825,6 @@ let addversionno =
^ "conveniently on the same server: whichever version is run "
^ "on the client, the same version will be selected on the server.")
-(* List containing the connected hosts and the file descriptors of
- the communication. *)
-let connectionsByHosts = ref []
-
-(* Gets the Read/Write file descriptors for a host;
- the connection must have been set up by canonizeRoot before calling *)
-let hostConnection host =
- try Safelist.assoc host !connectionsByHosts
- with Not_found ->
- raise(Util.Fatal "Remote.hostConnection")
-
-(* connectedHosts is a list of command-line roots and their corresponding
- canonical host names.
- Local command-line roots are not in the list.
- Although there can only be one remote host per sync, it's possible
- connectedHosts to hold more than one hosts if more than one sync is
- performed.
- It's also possible for there to be two connections open for the
- same canonical root.
-*)
-let connectedHosts = ref []
-
(**********************************************************************
CLIENT/SERVER PROTOCOLS
**********************************************************************)
@@ -613,8 +900,24 @@ type header =
| Stream of string
| StreamAbort
+let mheader = Umarshal.(sum6 unit string string string string unit
+ (function
+ | NormalResult -> I61 ()
+ | TransientExn a -> I62 a
+ | FatalExn a -> I63 a
+ | Request a -> I64 a
+ | Stream a -> I65 a
+ | StreamAbort -> I66 ())
+ (function
+ | I61 () -> NormalResult
+ | I62 a -> TransientExn a
+ | I63 a -> FatalExn a
+ | I64 a -> Request a
+ | I65 a -> Stream a
+ | I66 () -> StreamAbort))
+
let ((marshalHeader, unmarshalHeader) : header marshalingFunctions) =
- makeMarshalingFunctions defaultMarshalingFunctions "rsp"
+ makeMarshalingFunctions (defaultMarshalingFunctions convV0_id mheader) "rsp"
let processRequest conn id cmdName buf =
let cmd =
@@ -624,28 +927,46 @@ let processRequest conn id cmdName buf =
Lwt.try_bind (fun () -> cmd conn buf)
(fun marshal ->
debugE (fun () -> Util.msg "Sending result (id: %d)\n" (decodeInt id 0));
- dump conn ((id, 0, intSize) :: marshalHeader NormalResult (marshal [])))
+ dump conn ((id, 0, intSize) :: marshalHeader conn NormalResult (marshal [])))
(function
Util.Transient s ->
debugE (fun () ->
Util.msg "Sending transient exception (id: %d)\n" (decodeInt id 0));
- dump conn ((id, 0, intSize) :: marshalHeader (TransientExn s) [])
+ dump conn ((id, 0, intSize) :: marshalHeader conn (TransientExn s) [])
| Util.Fatal s ->
debugE (fun () ->
Util.msg "Sending fatal exception (id: %d)\n" (decodeInt id 0));
- dump conn ((id, 0, intSize) :: marshalHeader (FatalExn s) [])
+ dump conn ((id, 0, intSize) :: marshalHeader conn (FatalExn s) [])
| e ->
Lwt.fail e)
+ (* With the current RPC protocol it is not possible to recover from situations
+ where an RPC packet is not completely transmitted (due to an interrupted
+ write syscall). The other side will hang forever, waiting for the complete
+ packet to arrive. New packets (here, transmitting the exception) can't be
+ sent because the receiver can't read them until the previous packet is
+ complete. (Best case, the server quits with a protocol error.)
+
+ Therefore, it is important that exceptions that can interrupt syscalls
+ (for example, Sys.Break (Ctrl-C)) are never wrapped into Util.Transient or
+ Util.Fatal, unless the connection is already known to be broken. Likewise,
+ other exception handlers than the one just above must avoid writing out
+ additional data to the RPC connection. *)
let streamAbortedSrc = ref 0
let streamAbortedDst = ref false
let streamError = Hashtbl.create 7
+let resetStreamErroState () =
+ streamAbortedSrc := 0;
+ streamAbortedDst := false;
+ Hashtbl.reset streamError
+let () = at_conn_close resetStreamErroState
+
let abortStream conn id =
if not !streamAbortedDst then begin
streamAbortedDst := true;
- let request = encodeInt id :: marshalHeader StreamAbort [] in
+ let request = encodeInt id :: marshalHeader conn StreamAbort [] in
dumpUrgent conn request
end else
Lwt.return ()
@@ -679,6 +1000,9 @@ let newMsgId () = incr ids; if !ids = hugeint then ids := 2; !ids
(* Threads waiting for a response from the other side *)
let receivers = ref MsgIdMap.empty
+let resetReceivers () =
+ receivers := MsgIdMap.empty
+let () = at_conn_close resetReceivers
let find_receiver id =
let thr = MsgIdMap.find id !receivers in
@@ -703,7 +1027,7 @@ let rec receive conn =
(fun () -> Util.msg "Message received (id: %d)\n" num_id);
(* Read the header *)
receivePacket conn >>= (fun buf ->
- let req = unmarshalHeader buf in
+ let req = unmarshalHeader conn buf in
begin match req with
Request cmdName ->
receivePacket conn >>= (fun buf ->
@@ -764,9 +1088,9 @@ let registerSpecialServerCmd
makeMarshalingFunctions marshalingFunctionsResult (cmdName ^ "-res") in
(* Create a server function and remember it *)
let server conn buf =
- let args = unmarshalArgs buf in
+ let args = unmarshalArgs conn buf in
serverSide conn args >>= (fun answer ->
- Lwt.return (marshalResult answer))
+ Lwt.return (marshalResult conn answer))
in
serverCmds := Util.StringMap.add cmdName server !serverCmds;
(* Create a client function and return it *)
@@ -775,19 +1099,20 @@ let registerSpecialServerCmd
assert (id >= 0); (* tracking down an assert failure in receivePacket... *)
let request =
encodeInt id ::
- marshalHeader (Request cmdName) (marshalArgs serverArgs [])
+ marshalHeader conn (Request cmdName) (marshalArgs conn serverArgs [])
in
let reply = wait_for_reply id in
debugE (fun () -> Util.msg "Sending request (id: %d)\n" id);
dump conn request >>= (fun () ->
reply >>= (fun buf ->
- Lwt.return (unmarshalResult buf)))
+ Lwt.return (unmarshalResult conn buf)))
in
client
-let registerServerCmd name f =
+let registerServerCmd name ?(convV0=convV0_id_pair) mArg mRet f =
registerSpecialServerCmd
- name defaultMarshalingFunctions defaultMarshalingFunctions f
+ name (defaultMarshalingFunctions (fst convV0) mArg)
+ (defaultMarshalingFunctions (snd convV0) mRet) f
(* RegisterHostCmd is a simpler version of registerClientServer [registerServerCmd?].
It is used to create remote procedure calls: the only communication
@@ -799,49 +1124,47 @@ let registerServerCmd name f =
RegisterHostCmd recognizes the case where the server is the local
host, and it avoids socket communication in this case.
*)
-let registerHostCmd cmdName cmd =
+let registerHostCmd cmdName ?(convV0=convV0_id_pair) mArg mRet cmd =
let serverSide = (fun _ args -> cmd args) in
let client0 =
- registerServerCmd cmdName serverSide in
- let client host args =
- let conn = hostConnection host in
+ registerServerCmd cmdName ~convV0 mArg mRet serverSide in
+ let client root args =
+ let conn = ClientConn.ofRoot root in
client0 conn args in
(* Return a function that runs either the proxy or the local version,
depending on whether the call is to the local host or a remote one *)
- fun host args ->
- match host with
- "" -> cmd args
- | _ -> client host args
-
-let hostOfRoot root =
- match root with
- (Common.Local, _) -> ""
- | (Common.Remote host, _) -> host
-let connectionToRoot root = hostConnection (hostOfRoot root)
+ fun root args ->
+ match root with
+ | (Common.Local, _) -> cmd args
+ | (Common.Remote _, _) -> client root args
(* RegisterRootCmd is like registerHostCmd but it indexes connections by
root instead of host. *)
-let registerRootCmd (cmdName : string) (cmd : (Fspath.t * 'a) -> 'b) =
- let r = registerHostCmd cmdName cmd in
- fun root args -> r (hostOfRoot root) ((snd root), args)
-
-let registerRootCmdWithConnection
- (cmdName : string) (cmd : connection -> 'a -> 'b) =
- let client0 = registerServerCmd cmdName cmd in
+let registerRootCmd (cmdName : string)
+ ?(convV0=convV0_id_pair) mArg mRet (cmd : (Fspath.t * 'a) -> 'b) =
+ let mArg = Umarshal.(prod2 Fspath.m mArg id id) in
+ let r = registerHostCmd cmdName ~convV0 mArg mRet cmd in
+ fun root args -> r root ((snd root), args)
+
+let registerRootCmdWithConnection (cmdName : string)
+ ?(convV0=convV0_id_pair) mArg mRet (cmd : connection -> 'a -> 'b) =
+ let client0 = registerServerCmd cmdName ~convV0 mArg mRet cmd in
(* Return a function that runs either the proxy or the local version,
depending on whether the call is to the local host or a remote one *)
fun localRoot remoteRoot args ->
- match (hostOfRoot localRoot) with
- "" -> let conn = hostConnection (hostOfRoot remoteRoot) in
+ match (fst localRoot) with
+ | Common.Local -> let conn = ClientConn.ofRoot remoteRoot in
cmd conn args
- | _ -> let conn = hostConnection (hostOfRoot localRoot) in
+ | _ -> let conn = ClientConn.ofRoot localRoot in
client0 conn args
-let streamReg = Lwt_util.make_region 1
+let streamReg = lwtRegionWithConnCleanup 1
let streamingActivated =
Prefs.createBool "stream" true
- ("!use a streaming protocol for transferring file contents")
+ ~category:(`Advanced `Remote)
+ ~deprecated:true
+ ("use a streaming protocol for transferring file contents")
"When this preference is set, Unison will use an experimental \
streaming protocol for transferring file contents more efficiently. \
The default value is \\texttt{true}."
@@ -853,11 +1176,12 @@ let registerStreamCmd
=
let cmd =
registerSpecialServerCmd
- cmdName marshalingFunctionsArgs defaultMarshalingFunctions
+ cmdName marshalingFunctionsArgs
+ (defaultMarshalingFunctions convV0_id Umarshal.unit)
(fun conn v -> serverSide conn v; Lwt.return ())
in
let ping =
- registerServerCmd (cmdName ^ "Ping")
+ registerServerCmd (cmdName ^ "Ping") Umarshal.int Umarshal.unit
(fun conn (id : int) ->
try
let e = Hashtbl.find streamError id in
@@ -875,7 +1199,7 @@ let registerStreamCmd
makeMarshalingFunctions marshalingFunctionsArgs (cmdName ^ "-str") in
(* Create a server function and remember it *)
let server conn buf =
- let args = unmarshalArgs buf in
+ let args = unmarshalArgs conn buf in
serverSide conn args
in
serverStreams := Util.StringMap.add cmdName server !serverStreams;
@@ -885,7 +1209,7 @@ let registerStreamCmd
if !streamAbortedSrc = id then raise (Util.Transient "Streaming aborted");
let request =
encodeInt id ::
- marshalHeader (Stream cmdName) (marshalArgs serverArgs [])
+ marshalHeader conn (Stream cmdName) (marshalArgs conn serverArgs [])
in
dumpIdle conn request
in
@@ -897,46 +1221,241 @@ let registerStreamCmd
let id = newMsgId () in (* Message ID *)
Lwt.try_bind
(fun () ->
- Lwt_util.run_in_region streamReg 1
+ Lwt_util.run_in_region !streamReg 1
(fun () -> sender (fun v -> client conn id v)))
(fun v -> ping conn id >>= fun () -> Lwt.return v)
(fun e ->
- debugE (fun () ->
- Util.msg "Pinging remote end after streaming error\n");
- ping conn id >>= fun () -> Lwt.fail e)
+ if !streamAbortedSrc = id then begin
+ debugE (fun () ->
+ Util.msg "Pinging remote end after streaming error\n");
+ ping conn id >>= fun () -> Lwt.fail e
+ end else
+ Lwt.fail e)
end
let commandAvailable =
- registerRootCmd "commandAvailable"
+ registerRootCmd "commandAvailable" Umarshal.string Umarshal.bool
(fun (_, cmdName) -> Lwt.return (Util.StringMap.mem cmdName !serverCmds))
(****************************************************************************
BUILDING CONNECTIONS TO THE SERVER
****************************************************************************)
-let connectionHeader =
- let (major,minor,patchlevel) =
- Scanf.sscanf Sys.ocaml_version "%d.%d.%d" (fun x y z -> (x,y,z)) in
- let compiler =
- if major < 4
- || major = 4 && minor < 2
- || major = 4 && minor = 2 && patchlevel <= 1
- then "<= 4.01.1"
- else ">= 4.01.2"
- (* BCP: These strings seem wrong -- they should say 4.02,
- not 4.01, according to my understanding of when the breaking
- change happened. However, I'm nervous about breaking installations
- that are working, so I'm going to leave it. Hopefully we are
- far enough beyond these OCaml versions that it doesn't matter
- anyway. *)
- in "Unison " ^ Uutil.myMajorVersion ^ " with OCaml " ^ compiler ^ "\n"
-
-let rec checkHeader conn buffer pos len =
+let receiveUntilSep ?(space=false) ?(nl=true) ?(includesep=false) conn =
+ assert (space || nl);
+ let inp = Buffer.create 32
+ and buf = Bytearray.create 1 in
+ let add () = Buffer.add_char inp buf.{0} in
+ let rec aux () =
+ grab conn.inputBuffer buf 1 >>= fun () ->
+ match buf.{0} with
+ | ' ' | '\t' when space ->
+ if includesep then add (); Lwt.return (Buffer.contents inp)
+ | '\n' when nl ->
+ if includesep then add (); Lwt.return (Buffer.contents inp)
+ | '\r' ->
+ aux () (* ignore *)
+ | _ ->
+ add (); aux ()
+ in aux ()
+
+(* Get input until newline (excluded), blocking *)
+let receiveUntilNewline conn =
+ receiveUntilSep ~nl:true conn
+
+(* Get input until space or newline, separator included by default; blocking *)
+let receiveUntilSpaceOrNl ?(includesep=true) conn =
+ receiveUntilSep ~space:true ~nl:true ~includesep conn
+
+(* Get input of fixed length, blocking *)
+let receiveString conn len =
+ let buf = Bytearray.create len in
+ grab conn.inputBuffer buf len >>= fun () ->
+ Lwt.return (Bytearray.to_string buf)
+
+(* Get input until newline (excluded), non-blocking *)
+let receiveUntilNewlineNb conn =
+ let e = Bytes.to_string (peekWithoutBlocking conn.inputBuffer) in
+ let len = try String.index e '\n' with Not_found -> String.length e in
+ receiveString conn len
+
+let sendStrings conn slist =
+ dump conn
+ (Safelist.map (fun s -> (Bytearray.of_string s, 0, String.length s)) slist)
+
+let sendString conn s = sendStrings conn [s]
+
+(****)
+
+let rpcOk = "OK\n"
+
+let rpcNokTag = "NOK "
+let rpcErr err = rpcNokTag ^ err ^ "\n"
+
+type handshakeMsg = Ok | Error of string | Unknown of string
+
+let receiveHandshakeMsg conn =
+ receiveUntilSpaceOrNl conn >>= fun msg ->
+ if msg = rpcOk then Lwt.return Ok
+ else if msg = rpcNokTag then begin
+ receiveUntilNewlineNb conn >>= fun msg -> Lwt.return (Error msg)
+ end else
+ Lwt.return (Unknown msg)
+
+type handshakeData = Data of string | Error of string | Unknown of string
+
+let receiveHandshakeData conn keyw =
+ receiveUntilSpaceOrNl conn >>= fun msg ->
+ if msg = keyw then
+ receiveUntilNewline conn >>= fun data -> Lwt.return (Data data)
+ else if msg = rpcNokTag then
+ receiveUntilNewlineNb conn >>= fun err -> Lwt.return (Error err)
+ else
+ Lwt.return (Unknown msg)
+
+let sendHandshakeMsg conn = function
+ | Ok -> sendString conn rpcOk
+ | Error err -> sendString conn (rpcErr err)
+ | Unknown _ -> assert false
+
+let sendHandshakeErr conn err =
+ sendHandshakeMsg conn (Error err)
+
+let sendHandshakeData conn keyw data =
+ let len = String.length keyw in
+ let keyw = if len > 0 && keyw.[len - 1] <> ' ' then keyw ^ " " else keyw in
+ sendString conn (keyw ^ data ^ "\n")
+
+(* RPC version negotiation process:
+ 1. Server sends connectionHeader and supported RPC versions.
+
+ 2. Client receives and verifies connectionHeader.
+ * If OK then proceeds.
+ * If NOK then closes connection.
+
+ 3. Client receives and verifies RPC versions.
+ * If not correct version tag or can't parse then closes connection.
+
+ 4. Client selects a version (typically the most recent one) from the
+ intersection of its supported RPC versions and server's RPC versions.
+ * If intersection is empty then closes connection.
+
+ 5. Client sends selected RPC version to the server.
+
+ 6. Server receives and verifies proposed version.
+ * If OK then proceeds.
+ * If not correct version tag, can't parse or proposed version is
+ not supported then server sends "NOK".
+ ** Client receives "NOK" and closes connection.
+
+ 7. Server selects proposed version and sends "OK".
+
+ 8. Client receives "OK". Version negotiation is complete.
+*)
+
+let connectionHeader = "Unison RPC\n"
+let compatConnectionHeader = "Unison 2.51 with OCaml >= 4.01.2\n"
+(* Every supported version released prior to the RPC version negotiation
+ mechanism uses this connection header string. *)
+let compat248ConnectionHeader = "Unison 2.48\n"
+(* Additionally, even 2.48 can be supported, even though that support is
+ not official. *)
+
+let rpcVersionsTag = "VERSIONS "
+let rpcVersionsStr = rpcVersionsTag ^ rpcSupportedVersionStrHdr ^ "\n"
+
+let rpcVersionTag = "VERSION "
+let rpcVersionStr ver = rpcVersionTag ^ string_of_int ver ^ "\n"
+
+let verIsSupported ver =
+ Safelist.exists (fun v -> v = ver) rpcSupportedVersions
+
+let handshakeFail err =
+ Lwt.fail (Util.Fatal err)
+
+let handshakeError msg =
+ handshakeFail ("Received error from the server: \"" ^ msg ^ "\".")
+
+let handshakeUnknown msg =
+ handshakeFail ("Received unexpected header from the server: \""
+ ^ String.escaped msg ^ "\".")
+
+let parseVersion side s =
+ let error e =
+ raise (Util.Transient
+ ("Unknown " ^ side ^ " RPC version: " ^ e
+ ^ ". Version received from " ^ side ^ ": \"" ^ String.escaped s
+ ^ "\". Supported RPC versions: " ^ rpcSupportedVersionStr))
+ in
+ if s = "" then
+ error "invalid format"
+ else
+ match int_of_string s with
+ | ver -> Some ver
+ | exception Failure _ -> error "parse error"
+
+let parseServerVersions inp =
+ let supported l = function
+ | "" -> l
+ | v -> match parseVersion "server" v with
+ | Some vi -> if verIsSupported vi then vi :: l else l
+ | None -> l
+ in
+ try
+ let vs = String.split_on_char ' ' inp in
+ if vs = [""] then ignore (parseVersion "server" ""); (* Trigger the error *)
+ let intersect = Safelist.fold_left supported [] vs in
+ Lwt.return (Safelist.rev (Safelist.sort compare intersect))
+ with
+ | Util.Transient e -> handshakeFail e
+
+let selectServerVersion conn =
+ let getTheRest () = Bytes.to_string (peekWithoutBlocking conn.inputBuffer) in
+ receiveHandshakeData conn rpcVersionsTag >>= function
+ | Error msg -> handshakeError msg
+ | Unknown fromServ -> handshakeUnknown (fromServ ^ getTheRest ())
+ | Data versions ->
+ parseServerVersions versions >>= function
+ | [] ->
+ handshakeFail ("None of server's RPC versions are supported. "
+ ^ "The server may be too old or too recent. "
+ ^ "Versions received from server: \""
+ ^ String.escaped versions ^ "\". "
+ ^ "Supported RPC versions: " ^ rpcSupportedVersionStr)
+ | ver :: _ ->
+ setConnectionVersion conn ver;
+ debug (fun () -> Util.msg "Selected RPC version: %i\n" ver);
+ sendHandshakeData conn rpcVersionTag (string_of_int ver) >>= fun () ->
+ receiveHandshakeMsg conn >>= function
+ | Ok -> Lwt.return ()
+ | Error reply -> handshakeError reply
+ | Unknown reply -> handshakeUnknown (reply ^ getTheRest ())
+
+let checkServerVersion conn header =
+ if header = compatConnectionHeader then begin
+ setConnectionVersion conn 0;
+ debug (fun () -> Util.msg "Selected RPC version: 2.51-compatibility\n");
+ (* skip negotiation *) Lwt.return ()
+ end else if header = compat248ConnectionHeader then begin
+ setConnectionVersion conn 0;
+ debug (fun () -> Util.msg "Selected RPC version: 2.48-compatibility\n");
+ (* skip negotiation *) Lwt.return ()
+ end else
+ selectServerVersion conn
+
+let rec checkHeaderRec conn buffer pos len connectionHeader =
if pos = len then
- Lwt.return ()
+ Lwt.return connectionHeader
else begin
(grab conn.inputBuffer buffer 1 >>= (fun () ->
- if buffer.{0} <> connectionHeader.[pos] then
+ let chOk =
+ try buffer.{0} = connectionHeader.[pos] with Invalid_argument _ -> false
+ and compatChOk =
+ try buffer.{0} = compatConnectionHeader.[pos] with Invalid_argument _ -> false
+ and compat248ChOk =
+ try buffer.{0} = compat248ConnectionHeader.[pos] with Invalid_argument _ -> false
+ in
+ if not chOk && not compatChOk && not compat248ChOk then
let prefix =
String.sub connectionHeader 0 pos ^ Bytearray.to_string buffer in
let rest = peekWithoutBlocking conn.inputBuffer in
@@ -954,9 +1473,97 @@ let rec checkHeader conn buffer pos len =
^ "message, or because your remote login shell is printing\n"
^ "something itself before starting Unison."))
else
- checkHeader conn buffer (pos + 1) len))
+ if not chOk && compatChOk then
+ (* We make use of the fact that that the new header is almost a prefix
+ of the old header. It is not an exact comparison here but good
+ enough for this purpose. *)
+ checkHeaderRec conn buffer (pos + 1)
+ (String.length compatConnectionHeader) compatConnectionHeader
+ else if not chOk && compat248ChOk then
+ checkHeaderRec conn buffer (pos + 1)
+ (String.length compat248ConnectionHeader) compat248ConnectionHeader
+ else
+ checkHeaderRec conn buffer (pos + 1) len connectionHeader))
end
+let checkHeader conn =
+ checkHeaderRec conn (Bytearray.create 1) 0
+ (String.length connectionHeader) connectionHeader
+
+(****)
+
+(* Magic string exchange is used within the old protocol to detect if both
+ the server and the client support the new RPC version negotiation mechanism.
+
+ It works like this:
+ 1. Directly after connection header, the server sends the magic string and
+ otherwise continues using the old RPC protocol.
+ 2. An old client will process the magic string as a valid RPC message that
+ is effectively a no-op and continues using old RPC protocol as normal.
+ 3. A new client will notice the magic string and send the same magic string
+ in response. It will stop the old RPC protocol and restart from header
+ checking and what is now hopefully an RPC version negotiation.
+ 4. The server will notice client's magic string, stop the old RPC protocol
+ and restart from connection header, this time with the new RPC version
+ negotiation mechanism.
+
+ The magic string is defined as follows:
+ 1. encoded int 1 followed by
+ 2. encoded int > 0 (packet size) followed by
+ 3. a valid 2.51 protocol packet, the contents of which we don't care about,
+ but it must be a no-op for 2.51 client (in this case a StreamAbort).
+
+ Int 1 is a valid 2.51 protocol message ID but it is never used with normal
+ messages, hence its safe usage as a magic string. A StreamAbort to a client,
+ especially with id 1, is a safe no-op. *)
+
+let magicId = 1
+(* Although this magic packet is inherently dependent on OCaml version,
+ it is unlikely to change and has been verified to be the same with
+ OCaml versions 4.05 to 4.12. It is hard coded here to avoid any future
+ changes (the idea being that old clients will not be compiled with
+ any newer OCaml compilers). *)
+let magicPacket = "rsp\132\149\166\190\000\000\000\001\000\000\000\000\000\000\000\000\000\000\000\000A"
+let magic = encodeInt magicId :: encodeInt (String.length magicPacket) ::
+ [Bytearray.of_string magicPacket, 0, String.length magicPacket]
+
+let checkForMagicString conn =
+ (* Fill the buffer and then peek at the contents without consuming *)
+ peekWithBlocking conn.inputBuffer >>= fun b ->
+ if Bytes.length b < intSize then
+ Lwt.return false
+ else begin
+ let id = Bytearray.create intSize in
+ let () = Bytearray.blit_from_bytes b 0 id 0 intSize in
+ if decodeInt id 0 <> magicId then
+ Lwt.return false
+ else begin
+ debug (fun () -> Util.msg "Received RPC version upgrade notice\n");
+ (* Consume magic id from buffer *)
+ grab conn.inputBuffer id intSize >>= fun () ->
+ (* Consume magic packet from buffer *)
+ receivePacket conn >>= fun _ -> Lwt.return true
+ (* We rely solely on the magic id and don't check the contents of the
+ packet. Should it become necessary for some reason then it is
+ possible to verify the magic packet byte by byte here. *)
+ end
+ end
+
+let checkServerUpgrade conn header =
+ if header <> compatConnectionHeader && header <> compat248ConnectionHeader then
+ Lwt.return header
+ else
+ checkForMagicString conn >>= function
+ | false -> Lwt.return header
+ | true ->
+ (* Consume write token from buffer *)
+ let id = Bytearray.create intSize in
+ grab conn.inputBuffer id intSize >>= fun () ->
+ (* Send the magic string *)
+ dumpUrgent conn magic >>= fun () ->
+ debug (fun () -> Util.msg "Going to attempt RPC version upgrade\n");
+ checkHeader conn
+
(****)
(*
@@ -966,24 +1573,23 @@ let rec checkHeader conn buffer pos len =
*)
let halfduplex =
Prefs.createBool "halfduplex" false
- "!force half-duplex communication with the server"
+ ~category:(`Advanced `Remote)
+ ~deprecated:true
+ "force half-duplex communication with the server"
"When this flag is set to {\\tt true}, Unison network communication \
is forced to be half duplex (the client and the server never \
simultaneously emit data). If you experience unstabilities with \
- your network link, this may help. The communication is always \
- half-duplex when synchronizing with a Windows machine due to a \
- limitation of Unison current implementation that could result \
- in a deadlock."
+ your network link, this may help."
let negociateFlowControlLocal conn () =
disableFlowControl conn.outputQueue;
Lwt.return false
let negociateFlowControlRemote =
- registerServerCmd "negociateFlowControl" negociateFlowControlLocal
+ registerServerCmd "negociateFlowControl" Umarshal.unit Umarshal.bool negociateFlowControlLocal
let negociateFlowControl conn =
- (* Flow control negociation can be done asynchronously. *)
+ (* Flow control negotiation can be done asynchronously. *)
if not (Prefs.read halfduplex) then
Lwt.ignore_result
(negociateFlowControlRemote conn () >>= fun needed ->
@@ -994,16 +1600,34 @@ let negociateFlowControl conn =
(****)
-let initConnection onClose in_ch out_ch =
- let conn = setupIO false in_ch out_ch in
- checkHeader
- conn (Bytearray.create 1) 0 (String.length connectionHeader) >>= (fun () ->
+let initConnection ?(connReady=fun () -> ()) ?cleanup in_ch out_ch =
+ (* [makeConnection] is not expected to raise any recoverable exceptions.
+ If this assumption changes in the future then [in_ch] and [out_ch] must
+ be closed in the recovery code. *)
+ let conn = makeConnection false in_ch out_ch in
+ let close_on_fail t =
+ Lwt.catch (fun () -> t) (fun e -> closeConnection conn; Lwt.fail e)
+ in
+ let with_timeout t =
+ Lwt.choose [t;
+ Lwt_unix.sleep 120. >>= fun () ->
+ Lwt.fail (Util.Fatal "Timed out negotiating connection with the server")]
+ in
+ close_on_fail (with_timeout (
+ peekWithBlocking conn.inputBuffer >>= fun _ ->
+ connReady (); Lwt.return () >>= fun () -> (* Connection working, notify *)
+ checkHeader conn >>=
+ checkServerUpgrade conn >>=
+ checkServerVersion conn)) >>= fun () ->
+ registerConnCleanup conn cleanup;
+ (* From this moment forward, the RPC version has been selected. All
+ communication must now adhere to that version's specification. *)
+ enableFlowControl conn false >>= (fun () ->
Lwt.ignore_result (Lwt.catch
(fun () -> receive conn)
- (function
- | Util.Fatal "Lost connection with the server" as e -> onClose e
- | e -> Lwt.fail e
- ));
+ (fun e ->
+ clientConnClose conn;
+ if isConnectionCheck conn then Lwt.return () else Lwt.fail e));
negociateFlowControl conn;
Lwt.return conn)
@@ -1018,16 +1642,16 @@ let rec findFirst f l =
let printAddr host addr =
match addr with
Unix.ADDR_UNIX s ->
- assert false
+ s
| Unix.ADDR_INET (s, p) ->
Format.sprintf "%s[%s]:%d" host (Unix.string_of_inet_addr s) p
-let buildSocket host port kind ai =
+let buildSocket host port kind ?(err="") ai =
let attemptCreation ai =
Lwt.catch
(fun () ->
let socket =
- Lwt_unix.socket
+ Lwt_unix.socket ~cloexec:true
ai.Unix.ai_family ai.Unix.ai_socktype ai.Unix.ai_protocol
in
Lwt.catch
@@ -1043,8 +1667,10 @@ let buildSocket host port kind ai =
if ai.Unix.ai_family = Unix.PF_INET6 then
Lwt_unix.setsockopt socket Unix.IPV6_ONLY true;
(* Allow reuse of local addresses for bind *)
- Lwt_unix.setsockopt socket Unix.SO_REUSEADDR true;
- (* Bind the socket to portnum on the local host *)
+ if ai.Unix.ai_family <> Unix.PF_UNIX then
+ Lwt_unix.setsockopt socket Unix.SO_REUSEADDR true;
+ (* Bind the socket to portnum on the local host
+ or to a filesystem path (when Unix domain socket) *)
Lwt_unix.bind socket ai.Unix.ai_addr;
(* Start listening, allow up to 1 pending request *)
Lwt_unix.listen socket 1;
@@ -1063,15 +1689,16 @@ let buildSocket host port kind ai =
Unix.Unix_error (error, _, _) ->
begin match error with
Unix.EAFNOSUPPORT | Unix.EPROTONOSUPPORT | Unix.EINVAL ->
- ()
+ Lwt.return None
| _ ->
let msg =
match kind with
`Connect ->
- Printf.sprintf "Can't connect to server %s: %s\n"
+ Printf.sprintf "%s%s: %s\n"
+ err
(printAddr host ai.Unix.ai_addr)
(Unix.error_message error)
- | `Bind ->
+ | `Bind when ai.Unix.ai_family <> Unix.PF_UNIX ->
Printf.sprintf
"Can't bind socket to port %s at address [%s]: %s\n"
port
@@ -1081,56 +1708,99 @@ let buildSocket host port kind ai =
| _ ->
assert false)
(Unix.error_message error)
+ | `Bind (* Unix.PF_UNIX *) ->
+ Printf.sprintf
+ "Can't bind socket to path '%s': %s\n"
+ port
+ (Unix.error_message error)
in
- Util.warn msg
- end;
- Lwt.return None
+ Lwt.fail (Util.Fatal msg)
+ end
| _ ->
Lwt.fail e)
in
attemptCreation ai
+let makeUnixSocketAi path =
+ { Unix.ai_family = Unix.PF_UNIX;
+ ai_socktype = Unix.SOCK_STREAM;
+ ai_protocol = 0;
+ ai_addr = Unix.ADDR_UNIX path;
+ ai_canonname = "" }
+
+let buildConnectSocketUnix path =
+ assert (String.length path > 2);
+ (* Unix domain socket path from [Clroot] is enclosed in curly braces.
+ Extract the real path. *)
+ let path = String.sub path 1 ((String.length path) - 2) in
+ let err = "Can't connect to Unix domain socket on path " in
+ buildSocket "" path `Connect ~err (makeUnixSocketAi path) >>= function
+ | None ->
+ Lwt.fail (Util.Fatal (err ^ path))
+ | Some x ->
+ Lwt.return x
+
let buildConnectSocket host port =
- let attemptCreation ai = buildSocket host port `Connect ai in
+ let isHost = String.length host > 0 && host.[0] <> '{' in
+ if not isHost then buildConnectSocketUnix host else
+ let err = "Failed to connect to the server on host " in
+ let attemptCreation ai = buildSocket host port `Connect ~err ai in
let options = [ Unix.AI_SOCKTYPE Unix.SOCK_STREAM ] in
findFirst attemptCreation (Unix.getaddrinfo host port options) >>= fun res ->
match res with
Some socket ->
Lwt.return socket
| None ->
- let msg =
- Printf.sprintf
- "Failed to connect to the server on host %s:%s" host port
- in
- Lwt.fail (Util.Fatal msg)
+ let hostport = Printf.sprintf "%s:%s" host port in
+ Lwt.fail (Util.Fatal (err ^ hostport))
+
+(* [at_exit] does not provide reliable cleanup (why?), so this
+ complex mechanism is needed to unlink Unix domain sockets
+ in case of exceptional termination. *)
+let createdUnixSockets = ref []
+
+let postponeUnixSocketCleanup path =
+ createdUnixSockets := path :: !createdUnixSockets
-let buildListenSocket host port =
+let unixSocketCleanup () =
+ Safelist.iter
+ (fun path -> try Unix.unlink path with Unix.Unix_error _ -> ())
+ !createdUnixSockets
+
+let buildListenSocketUnix path =
+ assert (path <> "");
+ buildSocket "" path `Bind (makeUnixSocketAi path) >>= function
+ | None ->
+ Lwt.fail (Util.Fatal
+ (Printf.sprintf "Can't bind Unix domain socket on path %s" path))
+ | Some x ->
+ postponeUnixSocketCleanup path;
+ Lwt.return [x]
+
+let buildListenSocket hosts port =
+ let isPort = try ignore (int_of_string port); true with Failure _ -> false in
+ if not isPort then buildListenSocketUnix port else
let options = [ Unix.AI_SOCKTYPE Unix.SOCK_STREAM ; Unix.AI_PASSIVE ] in
- Lwt_util.map (buildSocket host port `Bind)
- (Unix.getaddrinfo host port options) >>= fun res ->
+ hosts
+ |> Safelist.map (fun host -> Unix.getaddrinfo host port options)
+ |> Safelist.concat
+ |> Lwt_util.map (buildSocket "" port `Bind) >>= fun res ->
match Safelist.filter (fun x -> x <> None) res with
| [] ->
- let msg =
- if host = "" then
- Printf.sprintf "Can't bind socket to port %s" port
- else
- Printf.sprintf "Can't bind socket to port %s on host %s"
- port host
- in
- Lwt.fail (Util.Fatal msg)
+ Lwt.fail (Util.Fatal (Printf.sprintf "Can't bind socket to port %s" port))
| s ->
Lwt.return (Safelist.map (function None -> assert false | Some x -> x) s)
-let buildSocketConnection onClose host port =
+let buildSocketConnection host port =
buildConnectSocket host port >>= fun socket ->
- initConnection (onClose (fun () -> ())) socket socket
+ initConnection socket socket
-let buildShellConnection onClose shell host userOpt portOpt rootName termInteract =
+let buildShellConnection shell host userOpt portOpt rootName termInteract =
let remoteCmd =
(if Prefs.read serverCmd="" then Uutil.myName
else Prefs.read serverCmd)
^ (if Prefs.read addversionno then "-" ^ Uutil.myMajorVersion else "")
- ^ " -server" in
+ ^ " -server " ^ rpcServerCmdlineOverride in
let userArgs =
match userOpt with
None -> []
@@ -1142,15 +1812,11 @@ let buildShellConnection onClose shell host userOpt portOpt rootName termInterac
let shellCmd =
(if shell = "ssh" then
Prefs.read sshCmd
- else if shell = "rsh" then
- Prefs.read rshCmd
else
shell) in
let shellCmdArgs =
(if shell = "ssh" then
Prefs.read sshargs
- else if shell = "rsh" then
- Prefs.read rshargs
else
"") in
let preargs =
@@ -1164,13 +1830,11 @@ let buildShellConnection onClose shell host userOpt portOpt rootName termInterac
Safelist.concat
(Safelist.map (fun s -> Util.splitIntoWords s ' ') preargs) in
let argsarray = Array.of_list args in
- let (i1,o1) = Lwt_unix.pipe_out () in
- let (i2,o2) = Lwt_unix.pipe_in () in
+ let (i1,o1) = Lwt_unix.pipe_out ~cloexec:true () in
+ let (i2,o2) = Lwt_unix.pipe_in ~cloexec:true () in
(* We need to make sure that there is only one reader and one
writer by pipe, so that, when one side of the connection
dies, the other side receives an EOF or a SIGPIPE. *)
- Lwt_unix.set_close_on_exec i2;
- Lwt_unix.set_close_on_exec o1;
(* We add CYGWIN=binmode to the environment before calling
ssh because the cygwin implementation on Windows sometimes
puts the pipe in text mode (which does end of line
@@ -1182,133 +1846,173 @@ let buildShellConnection onClose shell host userOpt portOpt rootName termInterac
System.putenv "CYGWIN" "binmode";
debug (fun ()-> Util.msg "Shell connection: %s (%s)\n"
shellCmd (String.concat ", " args));
- let term =
+ let (term, termPid) =
Util.convertUnixErrorsToFatal "starting shell connection" (fun () ->
match termInteract with
- None ->
- ignore (System.create_process shellCmd argsarray i1 o2 Unix.stderr);
- None
+ | None ->
+ (* Signals generated by the terminal from user input are sent to all
+ processes in the foreground process group. This means that the ssh
+ child process will receive SIGINT at the same time as Unison and
+ close the connection before Unison has the chance to do cleanup with
+ the remote end. To make matters more complicated, the ssh process
+ must be in the foreground process group because interaction with the
+ user is done via the terminal (not via stdin, stdout) and background
+ processes can't read from the terminal (unless we'd set up a pty
+ like is done for the GUI).
+
+ Don't let these signals reach ssh by blocking them.
+
+ The signals could be ignored instead of being blocked because ssh
+ does not set handlers for SIGINT and SIGQUIT if they've been ignored
+ at startup. But this triggers an error in ssh. The interactive
+ passphrase reading function captures these signals for the purpose
+ of restoring terminal settings (echo). When receiving a signal, and
+ after restoring previous signal handlers, it resends the signal to
+ itself. But now the signal is ignored and instead of terminating,
+ the process will continue running as if passphrase reading function
+ had returned with an empty result.
+
+ Since the ssh process no longer receives the signals generated by
+ user input we have to make sure that it terminates when Unison does.
+ This usually happens due to its stdin and stdout being closed,
+ except for when it is interacting with the user via terminal. To get
+ around that, an [at_exit] handler is registered to send a SIGTERM
+ and SIGKILL to the ssh process. (Note, for [at_exit] handlers to
+ run, unison process must terminate normally, not be killed. For
+ SIGINT, this means that [Sys.catch_break true] (or an alternative
+ SIGINT handler) must be set before creating the ssh process.) *)
+ let pid = Util.blockSignals [Sys.sigint] (fun () ->
+ System.create_process shellCmd argsarray i1 o2 Unix.stderr) in
+ let end_ssh () =
+ let kill_noerr si = try Unix.kill pid si
+ with Unix.Unix_error _ -> () | Invalid_argument _ -> () in
+ match Unix.waitpid [WNOHANG] pid with
+ | (0, _) ->
+ (* Grace period before killing. Important to give ssh a chance
+ to restore terminal settings, should that be needed. *)
+ kill_noerr Sys.sigterm; Unix.sleepf 0.01; kill_noerr Sys.sigkill
+ | _ | exception Unix.Unix_error _ -> ()
+ in
+ let () = at_exit end_ssh in
+ (None, pid)
| Some callBack ->
- fst (Terminal.create_session shellCmd argsarray i1 o2 Unix.stderr))
+ Terminal.create_session shellCmd argsarray i1 o2 Unix.stderr)
in
Unix.close i1; Unix.close o2;
- begin match term, termInteract with
- | Some fdTerm, Some callBack ->
- Terminal.handlePasswordRequests fdTerm (callBack rootName)
- | _ ->
- ()
- end;
+ let forwardShellStderr fdIn fdOut s =
+ (* When the shell connection has been established then keep
+ forwarding server's stderr to client's stderr; not to GUI. *)
+ let buf = Bytes.create 16000 in
+ let rec loop s len =
+ (* Can't use printf because if stderr is not open in Windows,
+ it will throw an exception when at_exit tries to flush it. *)
+ ignore (try if len > 0 then Unix.write fdOut s 0 len else 0
+ with Unix.Unix_error _ -> 0);
+ Lwt.catch (fun () -> Lwt_unix.read fdIn buf 0 16000)
+ (fun _ -> debug (fun () ->
+ Util.msg "Caught an exception when reading remote stderr\n");
+ Lwt.return 0)
+ >>= function
+ | 0 -> Lwt.return ()
+ | len -> loop buf len
+ in
+ loop (Bytes.of_string s) (String.length s)
+ in
+ let est = ref false in
+ let connReady () = est := true
+ and isReady () = !est = true in
+ let getTermErr =
+ match term, termInteract with
+ | Some fdTerm, Some interact ->
+ let (handleRequests, extractRemainingOutput) =
+ Terminal.handlePasswordRequests fdTerm (interact rootName) isReady in
+ Lwt.ignore_result (
+ handleRequests >>= fun () ->
+ extractRemainingOutput false >>=
+ forwardShellStderr (fst fdTerm) Unix.stderr);
+ fun () -> extractRemainingOutput true
+ | _ ->
+ fun () -> Lwt.return ""
+ in
let cleanup () =
- try Terminal.close_session term with Unix.Unix_error _ -> ()
+ (* Make sure the [handlePasswordRequests] threads will finish while
+ silencing any exceptions (most likely EBADF) caused by having closed
+ the terminal fds. *)
+ Lwt.ignore_result (getTermErr () >>= fun s ->
+ debug (fun () ->
+ if s <> "" then Util.msg "Received from remote shell process:\n%s\n" s);
+ Lwt.return ());
+ if term = None then
+ try ignore (Terminal.safe_waitpid termPid) with Unix.Unix_error _ -> ()
+ else
+ try Terminal.close_session termPid with Unix.Unix_error _ -> ()
in
- initConnection (onClose cleanup) i2 o1
-
-let canonizeLocally s unicode =
- (* We need to select the proper API in order to compute correctly the
- canonical fspath *)
- Fs.setUnicodeEncoding unicode;
+ (* With [connReady], we know that shell connection was established (even if
+ RPC handshake failed). This hacky way of detecting the connection is used
+ because [Lwt_unix.wait_read] is not implemented under Windows.
+ By this time, we are already somewhat late in the communication process.
+ Any error output from very early stages of server startup, before other
+ output is produced, might still end up in GUI (but this is very unlikely;
+ it is more likely that the same error caused connection to be dropped). *)
+ Lwt.catch
+ (fun () -> initConnection ~connReady ~cleanup i2 o1)
+ (fun e ->
+ Lwt.catch
+ (fun () -> getTermErr () >>= fun s ->
+ if s <> "" then Util.warn s;
+ Lwt.fail e)
+ (* Don't close the terminal before reading the final error output
+ or we might miss it completely. *)
+ (fun _ -> cleanup (); Lwt.fail e))
+
+let canonizeLocally s =
Fspath.canonize s
let canonizeOnServer =
registerServerCmd "canonizeOnServer"
- (fun _ (s, unicode) ->
- Lwt.return (Os.myCanonicalHostName (), canonizeLocally s unicode))
+ Umarshal.(prod2 (option string) bool id id)
+ Umarshal.(prod2 string Fspath.m id id)
+ (fun _ (s, _) -> (* The tuple is kept for backwards API compatibility *)
+ Lwt.return (Os.myCanonicalHostName (), canonizeLocally s))
+
+let canonizeOnServer conn s =
+ (* The second tuple item is required for compatibility with <= 2.52 *)
+ canonizeOnServer conn (s, true)
let canonize clroot = (* connection for clroot must have been set up already *)
match clroot with
Clroot.ConnectLocal s ->
- (Common.Local, canonizeLocally s (Case.useUnicodeAPI ()))
+ (Common.Local, canonizeLocally s)
| _ ->
- match
- try
- Some (Safelist.assoc clroot !connectedHosts)
- with Not_found ->
- None
- with
+ match ClientConn.canonRootOfClroot clroot with
None -> raise (Util.Fatal "Remote.canonize")
- | Some (h, fspath, _) -> (Common.Remote h, fspath)
-
-let listReplace v l = v :: Safelist.remove_assoc (fst v) l
-
-let connectionCheck = ref ""
-
-let checkConnection host ioServer =
- connectionCheck := host;
- (* Poke on the socket to trigger an error if connection has been lost. *)
- Lwt_unix.run (
- (if (Util.osType = `Win32) then Lwt.return 0 else
- Lwt_unix.read ioServer.inputBuffer.channel ioServer.inputBuffer.buffer 0 0)
- (* Try to make sure connection cleanup, if necessary, has finished
- before returning.
- Since there is no way to reliably detect when other threads have
- finished, we just yield a bit (the same comments apply as in
- commandLoop). *)
- >>= fun _ ->
- let rec wait n =
- if n = 0 then Lwt.return () else begin
- Lwt_unix.yield () >>= fun () ->
- wait (n - 1)
- end
- in
- wait 10);
- connectionCheck := ""
-
-let rec hostFspath clroot =
- try
- let (host, _, ioServer) = Safelist.assoc clroot !connectedHosts in
- checkConnection host ioServer;
- let (_, _, ioServer) = Safelist.assoc clroot !connectedHosts in
- Some (Lwt.return ioServer)
- with Not_found ->
- None
+ | Some root -> root
let isRootConnected = function
| (Common.Local, _) -> true
- | (Common.Remote host, _) -> begin
- try
- let ioServer = Safelist.assoc host !connectionsByHosts in
- checkConnection host ioServer;
- let _ = Safelist.assoc host !connectionsByHosts in
- true
- with Not_found ->
- false
- end
-
-let onClose clroot cleanup e =
- try
- let (host, _, _) = Safelist.assoc clroot !connectedHosts in
- connectedHosts := Safelist.remove_assoc clroot !connectedHosts;
- connectionsByHosts := Safelist.remove_assoc host !connectionsByHosts;
- cleanup ();
- if !connectionCheck = host then Lwt.return ()
- else Lwt.fail e
- with Not_found ->
- if !connectionCheck = "" then Lwt.fail e
- else Lwt.return ()
+ | (Common.Remote _, _) as root -> ClientConn.ofRootConncheck root <> None
let canonizeRoot rootName clroot termInteract =
- let unicode = Case.useUnicodeAPI () in
let finish ioServer s =
- (* We need to always compute the fspath as it depends on
- unicode settings *)
- canonizeOnServer ioServer (s, unicode) >>= (fun (host, fspath) ->
- connectedHosts :=
- listReplace (clroot, (host, fspath, ioServer)) !connectedHosts;
- connectionsByHosts := listReplace (host, ioServer) !connectionsByHosts;
- Lwt.return (Common.Remote host,fspath)) in
+ (* We need to always compute the fspath as it may have changed
+ due to profile configuration changes *)
+ canonizeOnServer ioServer s >>= (fun (host, fspath) ->
+ let root = (Common.Remote host, fspath) in
+ ClientConn.register clroot root ioServer;
+ Lwt.return root) in
match clroot with
Clroot.ConnectLocal s ->
- Lwt.return (Common.Local, canonizeLocally s unicode)
+ Lwt.return (Common.Local, canonizeLocally s)
| Clroot.ConnectBySocket(host,port,s) ->
- begin match hostFspath clroot with
- Some x -> x
- | None -> buildSocketConnection (onClose clroot) host port
+ begin match ClientConn.ofClrootConncheck clroot with
+ | Some x -> Lwt.return x
+ | None -> buildSocketConnection host port
end >>= fun ioServer ->
finish ioServer s
| Clroot.ConnectByShell(shell,host,userOpt,portOpt,s) ->
- begin match hostFspath clroot with
- Some x -> x
- | None -> buildShellConnection (onClose clroot)
+ begin match ClientConn.ofClrootConncheck clroot with
+ | Some x -> Lwt.return x
+ | None -> buildShellConnection
shell host userOpt portOpt rootName termInteract
end >>= fun ioServer ->
finish ioServer s
@@ -1332,33 +2036,24 @@ let openConnectionStart clroot =
None
| Clroot.ConnectBySocket(host,port,s) ->
Lwt_unix.run
- (begin match hostFspath clroot with
- Some x -> x
- | None -> buildSocketConnection (onClose clroot) host port
+ (begin match ClientConn.ofClrootConncheck clroot with
+ | Some x -> Lwt.return x
+ | None -> buildSocketConnection host port
end >>= fun ioServer ->
- (* We need to always compute the fspath as it depends on
- unicode settings *)
- let unicode = Case.useUnicodeAPI () in
- canonizeOnServer ioServer (s, unicode) >>= fun (host, fspath) ->
- connectedHosts :=
- listReplace (clroot, (host, fspath, ioServer)) !connectedHosts;
- connectionsByHosts :=
- listReplace (host, ioServer) !connectionsByHosts;
+ (* We need to always compute the fspath as it may have changed
+ due to profile configuration changes *)
+ canonizeOnServer ioServer s >>= fun (host, fspath) ->
+ ClientConn.register clroot (Common.Remote host, fspath) ioServer;
Lwt.return ());
None
| Clroot.ConnectByShell(shell,host,userOpt,portOpt,s) ->
- match hostFspath clroot with
- Some x ->
- let unicode = Case.useUnicodeAPI () in
+ match ClientConn.ofClrootConncheck clroot with
+ | Some ioServer ->
(* We recompute the fspath as it may have changed due to
- unicode settings *)
+ profile configuration changes *)
Lwt_unix.run
- (x >>= fun ioServer ->
- canonizeOnServer ioServer (s, unicode) >>= fun (host, fspath) ->
- connectedHosts :=
- listReplace (clroot, (host, fspath, ioServer)) !connectedHosts;
- connectionsByHosts :=
- listReplace (host, ioServer) !connectionsByHosts;
+ (canonizeOnServer ioServer s >>= fun (host, fspath) ->
+ ClientConn.register clroot (Common.Remote host, fspath) ioServer;
Lwt.return ());
None
| None ->
@@ -1366,7 +2061,7 @@ let openConnectionStart clroot =
(if Prefs.read serverCmd="" then Uutil.myName
else Prefs.read serverCmd)
^ (if Prefs.read addversionno then "-" ^ Uutil.myMajorVersion else "")
- ^ " -server" in
+ ^ " -server " ^ rpcServerCmdlineOverride in
let userArgs =
match userOpt with
None -> []
@@ -1378,15 +2073,11 @@ let openConnectionStart clroot =
let shellCmd =
(if shell = "ssh" then
Prefs.read sshCmd
- else if shell = "rsh" then
- Prefs.read rshCmd
else
shell) in
let shellCmdArgs =
(if shell = "ssh" then
Prefs.read sshargs
- else if shell = "rsh" then
- Prefs.read rshargs
else
"") in
let preargs =
@@ -1400,13 +2091,11 @@ let openConnectionStart clroot =
Safelist.concat
(Safelist.map (fun s -> Util.splitIntoWords s ' ') preargs) in
let argsarray = Array.of_list args in
- let (i1,o1) = Lwt_unix.pipe_out() in
- let (i2,o2) = Lwt_unix.pipe_in() in
+ let (i1,o1) = Lwt_unix.pipe_out ~cloexec:true () in
+ let (i2,o2) = Lwt_unix.pipe_in ~cloexec:true () in
(* We need to make sure that there is only one reader and one
writer by pipe, so that, when one side of the connection
dies, the other side receives an EOF or a SIGPIPE. *)
- Lwt_unix.set_close_on_exec i2;
- Lwt_unix.set_close_on_exec o1;
(* We add CYGWIN=binmode to the environment before calling
ssh because the cygwin implementation on Windows sometimes
puts the pipe in text mode (which does end of line
@@ -1440,55 +2129,128 @@ let openConnectionReply = function
let openConnectionEnd (i1,i2,o1,o2,s,fdopt,clroot,pid) =
Unix.close i1; Unix.close o2;
let cleanup () =
- try Terminal.close_session fdopt with Unix.Unix_error _ -> ()
+ try Terminal.close_session pid with Unix.Unix_error _ -> ()
in
Lwt_unix.run
- (initConnection (onClose clroot cleanup) i2 o1 >>= fun ioServer ->
- let unicode = Case.useUnicodeAPI () in
- canonizeOnServer ioServer (s, unicode) >>= fun (host, fspath) ->
- connectedHosts :=
- listReplace (clroot, (host, fspath, ioServer)) !connectedHosts;
- connectionsByHosts :=
- listReplace (host, ioServer) !connectionsByHosts;
+ (initConnection ~cleanup i2 o1 >>= fun ioServer ->
+ canonizeOnServer ioServer s >>= fun (host, fspath) ->
+ ClientConn.register clroot (Common.Remote host, fspath) ioServer;
Lwt.return ())
let openConnectionCancel (i1,i2,o1,o2,s,fdopt,clroot,pid) =
- try Unix.kill pid Sys.sigkill with Unix.Unix_error _ -> ();
- try Unix.close i1 with Unix.Unix_error _ -> ();
- try Lwt_unix.close i2 with Unix.Unix_error _ -> ();
- try Lwt_unix.close o1 with Unix.Unix_error _ -> ();
- try Unix.close o2 with Unix.Unix_error _ -> ();
- match fdopt with
- None -> ()
- | Some _ -> (try Terminal.close_session fdopt with Unix.Unix_error _ -> ())
+ (try Unix.kill pid Sys.sigkill with Unix.Unix_error _ -> ());
+ (try Unix.close i1 with Unix.Unix_error _ -> ());
+ (try Lwt_unix.close i2 with Unix.Unix_error _ -> ());
+ (try Lwt_unix.close o1 with Unix.Unix_error _ -> ());
+ (try Unix.close o2 with Unix.Unix_error _ -> ());
+ (try Terminal.close_session pid with Unix.Unix_error _ -> ())
(****************************************************************************)
(* SERVER-MODE COMMAND PROCESSING LOOP *)
(****************************************************************************)
+let checkClientVersion conn () =
+ let reply msg = sendHandshakeMsg conn msg in
+ (* FIX: In future when gaining the ability to close connections from server
+ side, make errors close the connection, not just send to client. *)
+ let error = sendHandshakeErr conn in
+ receiveHandshakeData conn rpcVersionTag >>= function
+ | Error msg ->
+ error ("Could not negotiate RPC version. "
+ ^ "Received unexpected error from the client: \"" ^ msg ^ "\"")
+ | Unknown fromClient ->
+ error ("Could not negotiate RPC version. "
+ ^ "Received unexpected header from the client: \""
+ ^ String.escaped (fromClient
+ ^ Bytes.to_string (peekWithoutBlocking conn.inputBuffer)) ^ "\"")
+ | Data buf ->
+ match parseVersion "client" buf with
+ | Some clientVer ->
+ if verIsSupported clientVer then begin
+ setConnectionVersion conn clientVer;
+ reply Ok
+ end else
+ error ("Client RPC version not supported. "
+ ^ "Version received from client: \""
+ ^ string_of_int clientVer ^ "\". "
+ ^ "Supported RPC versions: " ^ rpcSupportedVersionStr)
+ | None -> Lwt.return ()
+ | exception Util.Transient e -> error e
+
+(****)
+
let showWarningOnClient =
(registerServerCmd
- "showWarningOnClient"
+ "showWarningOnClient" Umarshal.string Umarshal.unit
(fun _ str -> Lwt.return (Util.warn str)))
let forwardMsgToClient =
(registerServerCmd
- "forwardMsgToClient"
+ "forwardMsgToClient" Trace.mmsg Umarshal.unit
(fun _ str -> (*msg "forwardMsgToClient: %s\n" str; *)
Lwt.return (Trace.displayMessageLocally str)))
+(* Compatibility mode for 2.51 clients. *)
+let compatServerInit mode conn =
+ let compatConnectionHeader =
+ match mode with
+ | Some "2.48" -> compat248ConnectionHeader
+ | _ -> compatConnectionHeader
+ in
+ dump conn [(Bytearray.of_string compatConnectionHeader, 0,
+ String.length compatConnectionHeader)] >>= fun () ->
+ (* Send the magic string to notify new clients *)
+ dumpUrgent conn magic >>= fun () ->
+ (* Must enable flow control because that is the default for 2.51.
+ This must be done after dumpUrgent above to ensure that the write
+ token is sent the last. *)
+ enableFlowControl conn true >>= fun () ->
+ (* Let's see if the client noticed the magic string. This is
+ a no-op for old clients. *)
+ checkForMagicString conn
+
+let compatServerRun conn =
+ (* Set the local warning printer to make an RPC to the client and
+ show the warning there; ditto for the message printer *)
+ Util.warnPrinter :=
+ Some (fun str -> Lwt_unix.run (showWarningOnClient conn str));
+ Trace.messageForwarder :=
+ Some (fun str -> Lwt_unix.run (forwardMsgToClient conn str));
+ receive conn >>=
+ Lwt.wait
+
(* This function loops, waits for commands, and passes them to
the relevant functions. *)
-let commandLoop in_ch out_ch =
+let commandLoop ~compatMode in_ch out_ch =
Trace.runningasserver := true;
(* Send header indicating to the client that it has successfully
connected to the server *)
- let conn = setupIO true in_ch out_ch in
+ let conn = makeConnection true in_ch out_ch in
Lwt.catch
- (fun e ->
- dump conn [(Bytearray.of_string connectionHeader, 0,
- String.length connectionHeader)]
- >>= (fun () ->
+ (fun () ->
+ (if compatMode <> None then
+ let () = setConnectionVersion conn 0 in
+ compatServerInit compatMode conn >>= (fun upgrade ->
+ if upgrade then begin
+ (* Restore the state before starting protocol negotiation *)
+ allowWrites conn.outputQueue;
+ disableFlowControl conn.outputQueue
+ end;
+ Lwt.return upgrade)
+ else
+ Lwt.return true) >>= fun upgrade ->
+ debug (fun () -> Util.msg "%sGoing to attempt RPC version upgrade\n"
+ (if upgrade then "" else "NOT "));
+ if not upgrade then
+ compatServerRun conn
+ else
+ sendStrings conn [connectionHeader; rpcVersionsStr] >>=
+ checkClientVersion conn >>= fun () ->
+ (* From this moment forward, the RPC version has been selected. All
+ communication must now adhere to that version's specification. *)
+ (* Flow control was disabled for RPC version handshake. Enable it
+ for flow control negotiation. *)
+ enableFlowControl conn true >>= (fun () ->
(* Set the local warning printer to make an RPC to the client and
show the warning there; ditto for the message printer *)
Util.warnPrinter :=
@@ -1517,7 +2279,8 @@ let commandLoop in_ch out_ch =
let killServer =
Prefs.createBool "killserver" false
- "!kill server when done (even when using sockets)"
+ ~category:(`Advanced `Remote)
+ "kill server when done (even when using sockets)"
("When set to \\verb|true|, this flag causes Unison to kill the remote "
^ "server process when the synchronization is finished. This behavior "
^ "is the default for \\verb|ssh| connections, so this preference is not "
@@ -1530,55 +2293,119 @@ let killServer =
(* For backward compatibility *)
let _ = Prefs.alias killServer "killServer"
+(* FIX: This code should be removed when removing 2.51-compatibility code. *)
+let is248Exe =
+ let exeName = Filename.basename (Sys.executable_name) in
+ String.length exeName >= 11 && String.sub exeName 0 11 = "unison-2.48"
+
+let rec accept_retry l =
+ Lwt.catch
+ (fun () -> Lwt_unix.accept l)
+ (function
+ (* Temporary and connection-specific errors *)
+ | Unix.Unix_error (Unix.ECONNABORTED, _, _)
+ | Unix.Unix_error (Unix.EPERM, _, _) (* Linux firewall *)
+ | Unix.Unix_error
+ (* Resource exhaustion: could be considered temporary *)
+ (Unix.(EMFILE | ENFILE | ENOBUFS | ENOMEM), _, _)
+ (* Linux curiosity: accept(2) may return errors on the new socket *)
+ | Unix.Unix_error (Unix.ENETUNREACH, _, _)
+ | Unix.Unix_error (Unix.EHOSTUNREACH, _, _)
+ | Unix.Unix_error (Unix.ENETDOWN, _, _)
+ | Unix.Unix_error (Unix.EHOSTDOWN, _, _)
+ | Unix.Unix_error (Unix.ETIMEDOUT, _, _) as e ->
+ let errmsg = match e with
+ | Unix.Unix_error (err, _, _) -> Unix.error_message err
+ | _ -> Printexc.to_string e in
+ Util.msg "server: continuing after receiving an error \
+ when accepting client connection: %s\n" errmsg;
+ accept_retry l
+ (* Permanent errors *)
+ | e -> Lwt.fail e)
+
(* Used by the socket mechanism: Create a socket on portNum and wait
for a request. Each request is processed by commandLoop. When a
session finishes, the server waits for another request. *)
-let waitOnPort hostOpt port =
+let waitOnPort hosts port =
Util.convertUnixErrorsToFatal "waiting on port"
(fun () ->
- let host =
- match hostOpt with
- Some host -> host
- | None -> ""
- in
- let listening = Lwt_unix.run (buildListenSocket host port) in
+ let hosts = match hosts with [] -> [""] | _ -> hosts in
+ let listening = Lwt_unix.run (buildListenSocket hosts port) in
let accepting = Array.make (Safelist.length listening) None in
- let accept i l =
+ let rec accept i l =
match accepting.(i) with
| None ->
- let st = Lwt_unix.accept l >>= fun s -> Lwt.return (i, s) in
+ let st = accept_retry l >>= fun s -> Lwt.return (i, s) in
let () = accepting.(i) <- Some st in
st
| Some st -> st
- and serve (i, s) = accepting.(i) <- None; s in
+ and serve (i, s) = accepting.(i) <- None; setKeepalive s; s
+ and setKeepalive = function
+ | (_, Unix.ADDR_UNIX _) -> ()
+ | (c, ADDR_INET _) -> Lwt_unix.setsockopt c Unix.SO_KEEPALIVE true
+ in
Util.msg "server started\n";
let rec handleClients () =
let (connected, _) =
serve @@ Lwt_unix.run (Lwt.choose (List.mapi accept listening))
in
- Lwt_unix.setsockopt connected Unix.SO_KEEPALIVE true;
+ registerIOClose (connected, connected) (fun () -> doCleanup connected);
begin try
(* Accept a connection *)
- Lwt_unix.run (commandLoop connected connected)
+ let compatMode = Some (if is248Exe then "2.48" else "2.51") in
+ Lwt_unix.run (commandLoop ~compatMode connected connected)
with Util.Fatal "Lost connection with the server" -> () end;
(* The client has closed its end of the connection *)
- begin try Lwt_unix.close connected with Unix.Unix_error _ -> () end;
if not (Prefs.read killServer) then handleClients ()
+ and doCleanup socket =
+ begin try Lwt_unix.close socket with Unix.Unix_error _ -> () end;
+ if not (Prefs.read killServer) then runConnCloseHandlers true
in
- handleClients ())
+ try
+ Sys.catch_break true;
+ handleClients ();
+ unixSocketCleanup ()
+ with
+ | Sys.Break ->
+ unixSocketCleanup ()
+ | (Util.Fatal _ | Unix.Unix_error _) as e ->
+ unixSocketCleanup ();
+ raise e
+ )
let beAServer () =
begin try
let home = System.getenv "HOME" in
Util.convertUnixErrorsToFatal
"changing working directory"
- (fun () -> System.chdir (System.fspathFromString home))
+ (fun () -> System.chdir home)
with Not_found ->
Util.msg
"Environment variable HOME unbound: \
executing server in current directory\n"
end;
+ (* Let's start with 2.51-compatibility mode. Newer clients will add
+ a special override keyword in server args that will disable the
+ compatibility mode.
+
+ FIX: It is a bit of a hack, so better not make it permanent.
+ It was added in 2021 and should be removed after a couple of years. *)
+ let compatMode =
+ try
+ not (Prefs.scanCmdLine "" |> Util.StringMap.find "rest"
+ |> Safelist.mem rpcServerCmdlineOverride)
+ with Not_found -> true
+ in
+ (* Additionally, do a best effort emulation of 2.48.
+ FIX: remove together with code above. *)
+ let compatMode =
+ match compatMode with
+ | true when is248Exe -> Some "2.48"
+ | true -> Some "2.51"
+ | false -> None
+ in
+ begin end;
Lwt_unix.run
- (commandLoop
+ (commandLoop ~compatMode
(Lwt_unix.of_unix_file_descr Unix.stdin)
(Lwt_unix.of_unix_file_descr Unix.stdout))
diff --git a/src/remote.mli b/src/remote.mli
index 03b7665..8c7ec22 100644
--- a/src/remote.mli
+++ b/src/remote.mli
@@ -5,16 +5,45 @@ module Thread : sig
val unwindProtect : (unit -> 'a Lwt.t) -> (exn -> unit Lwt.t) -> 'a Lwt.t
end
+(* A pair of functions enabling conversion from type 'a to a 2.51-compatible
+ type and the other way around.
+ The conversion functions are needed because the 2.51-compatible types must
+ be frozen in time and never changed in future. Type 'a can and will change
+ in time as enhancements are added and old code is removed.
+ When a type is changed, breaking compatibility with 2.51, then respective
+ conversion functions must also be added. *)
+type 'a convV0Fun
+val makeConvV0FunArg :
+ ('a -> 'compat)
+ -> ('compat -> 'a)
+ -> 'a convV0Fun * 'b convV0Fun
+val makeConvV0FunRet :
+ ('b -> 'compat)
+ -> ('compat -> 'b)
+ -> 'a convV0Fun * 'b convV0Fun
+val makeConvV0Funs :
+ ('a -> 'compata)
+ -> ('compata -> 'a)
+ -> ('b -> 'compatb)
+ -> ('compatb -> 'b)
+ -> 'a convV0Fun * 'b convV0Fun
+
(* Register a server function. The result is a function that takes a host
name as argument and either executes locally or else communicates with a
remote server, as appropriate. (Calling registerServerCmd also has the
side effect of registering the command under the given name, so that when
we are running as a server it can be looked up and executed when
requested by a remote client.) *)
+(* It is not recommended to use this function in new code unless the cmd is
+ truly independent of any roots/replicas. Use [registerRootCmd] or one of
+ the other functions instead. *)
val registerHostCmd :
string (* command name *)
+ -> ?convV0: 'a convV0Fun * 'b convV0Fun
+ (* 2.51-compatibility functions for args and result *)
+ -> 'a Umarshal.t -> 'b Umarshal.t
-> ('a -> 'b Lwt.t) (* local command *)
- -> ( string (* -> host *)
+ -> ( Common.root (* -> host (the root path is ignored) *)
-> 'a (* arguments *)
-> 'b Lwt.t) (* -> (suspended) result *)
@@ -27,6 +56,10 @@ val registerHostCmd :
<funcName>OnRoot and <funcName>Local *)
val registerRootCmd :
string (* command name *)
+ -> ?convV0: (Fspath.t * 'a) convV0Fun * 'b convV0Fun
+ (* 2.51-compatibility functions for args
+ and result *)
+ -> 'a Umarshal.t -> 'b Umarshal.t
-> ((Fspath.t * 'a) -> 'b Lwt.t) (* local command *)
-> ( Common.root (* -> root *)
-> 'a (* additional arguments *)
@@ -41,7 +74,7 @@ val commandAvailable :
(* Enter "server mode", reading and processing commands from a remote
client process until killed *)
val beAServer : unit -> unit
-val waitOnPort : string option -> string -> unit
+val waitOnPort : string list -> string -> unit
(* Whether the server should be killed when the client terminates *)
val killServer : bool Prefs.t
@@ -49,13 +82,19 @@ val killServer : bool Prefs.t
(* Establish a connection to the remote server (if any) corresponding
to the root and return the canonical name of the root *)
val canonizeRoot :
- string -> Clroot.clroot -> (string -> string -> string) option ->
+ string -> Clroot.clroot -> (string -> Terminal.termInteract) option ->
Common.root Lwt.t
(* Test if connection to the remote server (if any) corresponding
to the root is established. Always returns true for local roots *)
val isRootConnected : Common.root -> bool
+(* Close the connection to server and run all cleanup and [at_conn_close]
+ handlers. Can also be called for a local root; in this case only the
+ cleanup and [at_conn_close] handlers are run (as there is no connection
+ to close). *)
+val clientCloseRootConnection : Common.root -> unit
+
(* Statistics *)
val emittedBytes : float ref
val receivedBytes : float ref
@@ -87,28 +126,24 @@ module MsgIdMap : Map.S with type key = msgId
val newMsgId : unit -> msgId
type connection
-val connectionToRoot : Common.root -> connection
+val connectionVersion : connection -> int
+val connectionOfRoot : Common.root -> connection
val registerServerCmd :
- string -> (connection -> 'a -> 'b Lwt.t) -> connection -> 'a -> 'b Lwt.t
-val registerSpecialServerCmd :
- string ->
- ('a ->
- (Bytearray.t * int * int) list -> (Bytearray.t * int * int) list * int) *
- (Bytearray.t -> int -> 'a) ->
- ('b ->
- (Bytearray.t * int * int) list -> (Bytearray.t * int * int) list * int) *
- (Bytearray.t -> int -> 'b) ->
- (connection -> 'a -> 'b Lwt.t) -> connection -> 'a -> 'b Lwt.t
-val defaultMarshalingFunctions :
- ('a ->
- (Bytearray.t * int * int) list -> (Bytearray.t * int * int) list * int) *
- (Bytearray.t -> int -> 'b)
+ string
+ -> ?convV0: 'a convV0Fun * 'b convV0Fun
+ -> 'a Umarshal.t -> 'b Umarshal.t
+ -> (connection -> 'a -> 'b Lwt.t)
+ -> connection -> 'a -> 'b Lwt.t
val intSize : int
val encodeInt : int -> Bytearray.t * int * int
val decodeInt : Bytearray.t -> int -> int
val registerRootCmdWithConnection :
string (* command name *)
+ -> ?convV0: 'a convV0Fun * 'b convV0Fun
+ (* 2.51-compatibility functions for args
+ and result *)
+ -> 'a Umarshal.t -> 'b Umarshal.t
-> (connection -> 'a -> 'b Lwt.t) (* local command *)
-> Common.root (* root on which the command is executed *)
-> Common.root (* other root *)
@@ -119,8 +154,53 @@ val streamingActivated : bool Prefs.t
val registerStreamCmd :
string ->
- ('a ->
+ (connection -> 'a ->
(Bytearray.t * int * int) list -> (Bytearray.t * int * int) list * int) *
- (Bytearray.t -> int -> 'a) ->
+ (connection -> Bytearray.t -> int -> 'a) ->
(connection -> 'a -> unit) ->
connection -> (('a -> unit Lwt.t) -> 'b Lwt.t) -> 'b Lwt.t
+
+(* Register a function to be run when the connection between client and server
+ is closed (willingly or unexpectedly). The function should not raise
+ exceptions. If it does then running some of the other registered functions
+ may be skipped (which may not be an issue as the exception is likely going
+ to quit the process).
+
+ Registered functions are only expected to be useful when the connection is
+ closed but the process keeps running (a socket server, for example). Do not
+ use it as a substitute for [at_exit].
+
+ These functions are additionally run when "closing" a local sync when there
+ is no actual connection.
+
+ Keep in mind that a function registered like this can be called immediately
+ when a lost connection is detected, before any exception indicating lost
+ connection is raised. *)
+val at_conn_close : ?only_server:bool -> (unit -> unit) -> unit
+
+(* Register resources to be cleaned up when the connection between client and
+ server closes (normally or exceptionally). This cleanup is additionally run
+ when "closing" a local sync when there is no actual connection.
+
+ Closing the resources is still the responsibility of the code opening the
+ resources but it is not always possible to run the resource cleanup code
+ (due to an Lwt thread being stopped, for example). In those cases the
+ registered resources are cleaned up when the connection is closed, as a
+ last resort.
+
+ The returned functions must be used to track the resources registered for
+ cleanup. *)
+type ('a, 'b, 'c) resourceC =
+ { register : 'a -> 'a; (* Register an opened resource for cleanup *)
+ release : 'a -> 'b; (* Unregister and close the resource normally *)
+ release_noerr : 'a -> 'c } (* Same as above; don't raise exceptions *)
+
+val resourceWithConnCleanup :
+ ('a -> 'b) (* Function to close the resource normally *)
+ -> ('a -> 'c) (* Function to close the resource, don't raise exceptions *)
+ -> ('a, 'b, 'c) resourceC (* Functions to track resources for cleanup *)
+
+(* Make an [Lwt_util.region] which is automatically purged and reset when
+ the connection between client and server closes. This cleanup is also
+ run when "closing" a local sync when there is no actual connection. *)
+val lwtRegionWithConnCleanup : int -> Lwt_util.region ref
diff --git a/src/sortri.ml b/src/sortri.ml
index 873b917..a8b608b 100644
--- a/src/sortri.ml
+++ b/src/sortri.ml
@@ -24,7 +24,8 @@ let dbgsort = Util.debug "sort"
let bysize =
Prefs.createBool "sortbysize" false
- "!list changed files by size, not name"
+ ~category:(`Advanced `Syncprocess)
+ "list changed files by size, not name"
("When this flag is set, the user interface will list changed files "
^ "by size (smallest first) rather than by name. This is useful, for "
^ "example, for synchronizing over slow links, since it puts very "
@@ -37,13 +38,15 @@ let bysize =
let newfirst =
Prefs.createBool "sortnewfirst" false
- "!list new before changed files"
+ ~category:(`Advanced `Syncprocess)
+ "list new before changed files"
("When this flag is set, the user interface will list newly created "
^ "files before all others. This is useful, for example, for checking "
^ "that newly created files are not `junk', i.e., ones that should be "
^ "ignored or deleted rather than synchronized.")
-let sortfirst = Pred.create "sortfirst" ~advanced:true
+let sortfirst = Pred.create "sortfirst"
+ ~category:(`Advanced `Syncprocess)
("Each argument to \\texttt{sortfirst} is a pattern \\ARG{pathspec}, "
^ "which describes a set of paths. "
^ "Files matching any of these patterns will be listed first in the "
@@ -51,7 +54,8 @@ let sortfirst = Pred.create "sortfirst" ~advanced:true
^ "The syntax of \\ARG{pathspec} is "
^ "described in \\sectionref{pathspec}{Path Specification}.")
-let sortlast = Pred.create "sortlast" ~advanced:true
+let sortlast = Pred.create "sortlast"
+ ~category:(`Advanced `Syncprocess)
("Similar to \\verb|sortfirst|, except that files matching one of these "
^ "patterns will be listed at the very end.")
diff --git a/src/stasher.ml b/src/stasher.ml
index b5dec4b..58499d3 100644
--- a/src/stasher.ml
+++ b/src/stasher.ml
@@ -25,7 +25,8 @@ let verbose = Util.debug "stasher+"
let backuplocation =
Prefs.createString "backuploc" "central"
- "!where backups are stored ('local' or 'central')"
+ ~category:(`Advanced `Syncprocess)
+ "where backups are stored ('local' or 'central')"
("This preference determines whether backups should be kept locally, near the "
^ "original files, or"
^" in a central directory specified by the \\texttt{backupdir} "
@@ -36,7 +37,8 @@ let backuplocation =
let _ = Prefs.alias backuplocation "backuplocation"
let backup =
- Pred.create "backup" ~advanced:true
+ Pred.create "backup"
+ ~category:(`Advanced `Syncprocess)
("Including the preference \\texttt{-backup \\ARG{pathspec}} "
^ "causes Unison to keep backup files for each path that matches "
^ "\\ARG{pathspec}; directories (nor their permissions or any other "
@@ -51,7 +53,8 @@ let backup =
let _ = Pred.alias backup "mirror"
let backupnot =
- Pred.create "backupnot" ~advanced:true
+ Pred.create "backupnot"
+ ~category:(`Advanced `Syncprocess)
("The values of this preference specify paths or individual files or"
^ " regular expressions that should {\\em not} "
^ "be backed up, even if the {\\tt backup} preference selects "
@@ -65,13 +68,14 @@ let shouldBackup p =
let backupprefix =
Prefs.createString "backupprefix" ".bak.$VERSION."
- "!prefix for the names of backup files"
+ ~category:(`Advanced `Syncprocess)
+ "prefix for the names of backup files"
("When a backup for a file \\verb|NAME| is created, it is stored "
^ "in a directory specified by \\texttt{backuplocation}, in a file called "
^ "\\texttt{backupprefix}\\verb|NAME|\\texttt{backupsuffix}."
^ " \\texttt{backupprefix} can include a directory name (causing Unison to "
^ "keep all backup files for a given directory in a subdirectory with this name), and both "
- ^ " \\texttt{backupprefix} and \\texttt{backupsuffix} can contain the string"
+ ^ " \\texttt{backupprefix} and \\texttt{backupsuffix} can contain the string "
^ "\\ARG{\\$VERSION}, which will be replaced by the \\emph{age} of the backup "
^ "(1 for the most recent, 2 for the second most recent, and so on...)."
^ " This keyword is ignored if it appears in a directory name"
@@ -87,12 +91,15 @@ let backupprefix =
let backupsuffix =
Prefs.createString "backupsuffix" ""
- "!a suffix to be added to names of backup files"
+ ~category:(`Advanced `Syncprocess)
+ "a suffix to be added to names of backup files"
("See \\texttt{backupprefix} for full documentation.")
let backups =
Prefs.createBool "backups" false
- "!keep backup copies of all files (see also 'backup')"
+ ~category:(`Advanced `Syncprocess)
+ ~deprecated:true
+ "keep backup copies of all files (see also 'backup')"
("Setting this flag to true is equivalent to "
^" setting \\texttt{backuplocation} to \\texttt{local}"
^" and \\texttt{backup} to \\verb|Name *|.")
@@ -113,7 +120,8 @@ let translateOldPrefs () =
let maxbackups =
Prefs.createInt "maxbackups" 2
- "!number of backed up versions of a file"
+ ~category:(`Advanced `Syncprocess)
+ "number of backed up versions of a file"
("This preference specifies the number of backup versions that will "
^ "be kept by unison, for each path that matches the predicate "
^ "\\verb|backup|. The default is 2.")
@@ -123,7 +131,8 @@ let _ = Prefs.alias maxbackups "backupversions"
let backupdir =
Prefs.createString "backupdir" ""
- "!directory for storing centralized backups"
+ ~category:(`Advanced `Syncprocess)
+ "directory for storing centralized backups"
("If this preference is set, Unison will use it as the name of the "
^ "directory used to store backup files specified by "
^ "the {\\tt backup} preference, when {\\tt backuplocation} is set"
@@ -139,22 +148,24 @@ let backupDirectory () =
if Prefs.read backupdir <> ""
then Fspath.canonize (Some (Prefs.read backupdir))
else Fspath.canonize
- (Some (System.fspathToString (Util.fileInUnisonDir "backup"))))
+ (Some (Util.fileInUnisonDir "backup")))
let backupcurrent =
- Pred.create "backupcurr" ~advanced:true
+ Pred.create "backupcurr"
+ ~category:(`Advanced `Syncprocess)
("Including the preference \\texttt{-backupcurr \\ARG{pathspec}} "
^" causes Unison to keep a backup of the {\\em current} version of every file "
^ "matching \\ARG{pathspec}. "
^" This file will be saved as a backup with version number 000. Such"
^" backups can be used as inputs to external merging programs, for instance. See "
- ^ "the documentatation for the \\verb|merge| preference."
+ ^ "the documentation for the \\verb|merge| preference."
^" For more details, see \\sectionref{merge}{Merging Conflicting Versions}."
^"\n\n The syntax of \\ARG{pathspec} is described in "
^ "\\sectionref{pathspec}{Path Specification}.")
let backupcurrentnot =
- Pred.create "backupcurrnot" ~advanced:true
+ Pred.create "backupcurrnot"
+ ~category:(`Advanced `Syncprocess)
"Exceptions to \\verb|backupcurr|, like the \\verb|ignorenot| preference."
let shouldBackupCurrent p =
@@ -265,19 +276,33 @@ let updateBackupNamingFunctions () =
(*------------------------------------------------------------------------------------*)
-let makeBackupName path i =
+let makeBackupName fspath path i =
+ (* In the special case when the root itself is a file, use the root's name
+ as the backup file name. Empty path will break backups.
+ We only check the path being empty, and not its type, because the root
+ can change from file to dir and vice versa between syncs. *)
+ let path' =
+ if Path.isEmpty path then
+ Path.fromString (Filename.basename (Fspath.toString fspath))
+ else path in
+
(* if backups are kept centrally, the current version has exactly
the same name as the original, for convenience. *)
if i=0 && Prefs.read backuplocation = "central" then
- path
+ path'
else
Path.addSuffixToFinalName
- (Path.addPrefixToFinalName path (!make_prefix i))
+ (Path.addPrefixToFinalName path' (!make_prefix i))
(!make_suffix i)
-let stashDirectory fspath =
+let stashDirectory fspath path =
match Prefs.read backuplocation with
"central" -> backupDirectory ()
+ | "local" when Path.isEmpty path ->
+ (* Special case when the root itself is a file. Can't use the root
+ as the backup location, which must be a directory. Use the root's
+ parent instead. *)
+ Fspath.canonize (Some (Filename.dirname (Fspath.toString fspath)))
| "local" -> fspath
| _ -> raise (Util.Fatal ("backuplocation preference should be set"
^"to central or local."))
@@ -298,15 +323,15 @@ let showContent typ fspath path =
sufficiently large number!
*)
let backupPath fspath path =
- let sFspath = stashDirectory fspath in
+ let sFspath = stashDirectory fspath path in
- let rec f path i =
- let tempPath = makeBackupName path i in
+ let rec f fspath path i =
+ let tempPath = makeBackupName fspath path i in
verbose (fun () -> Util.msg "backupPath f %s %d\n" (Path.toString path) i);
if Os.exists sFspath tempPath then
if i < Prefs.read maxbackups then begin
verbose (fun () -> Util.msg "need to rename backup file\n");
- Os.rename "backupPath" sFspath tempPath sFspath (f path (i + 1))
+ Os.rename "backupPath" sFspath tempPath sFspath (f fspath path (i + 1))
end
else if i >= Prefs.read maxbackups then
Os.delete sFspath tempPath;
@@ -317,13 +342,13 @@ let backupPath fspath path =
"mkdirectories %s %s\n"
(Fspath.toDebugString sFspath) (Path.toString backdir));
if not (Os.exists sFspath Path.empty) then
- Os.createDir sFspath Path.empty Props.dirDefault;
+ Os.createDir sFspath Path.empty (Props.perms Props.dirDefault);
match Path.deconstructRev backdir with
None -> ()
| Some (_, parent) ->
mkdirectories parent;
- let props = (Fileinfo.get false sFspath Path.empty).Fileinfo.desc in
- if not (Os.exists sFspath backdir) then Os.createDir sFspath backdir props
+ let perms = Props.perms (Fileinfo.getBasic false sFspath Path.empty).desc in
+ if not (Os.exists sFspath backdir) then Os.createDir sFspath backdir perms
else (* Do not just check with Os.exists. It must also be a directory.
https://github.com/bcpierce00/unison/issues/30
If a non-directory with the same name exists, it must be moved
@@ -332,13 +357,13 @@ let backupPath fspath path =
This is only applicable with backuplocation "central" as it
will create a separate directory tree. *)
if (Prefs.read backuplocation = "central") &&
- (Fileinfo.get false sFspath backdir).Fileinfo.typ != `DIRECTORY then
- let backdir = f backdir 0 in
- Os.createDir sFspath backdir props in
+ Fileinfo.getType false sFspath backdir != `DIRECTORY then
+ let backdir = f sFspath backdir 0 in
+ Os.createDir sFspath backdir perms in
- let path0 = makeBackupName path 0 in
- let sourceTyp = (Fileinfo.get true fspath path).Fileinfo.typ in
- let path0Typ = (Fileinfo.get false sFspath path0).Fileinfo.typ in
+ let path0 = makeBackupName fspath path 0 in
+ let sourceTyp = Fileinfo.getType true fspath path in
+ let path0Typ = Fileinfo.getType false sFspath path0 in
if ( sourceTyp = `FILE && path0Typ = `FILE
&& (Fingerprint.file fspath path) = (Fingerprint.file sFspath path0))
@@ -358,7 +383,7 @@ let backupPath fspath path =
(showContent path0Typ sFspath path0)
(Fspath.toDebugString fspath) (Path.toString path)
(showContent sourceTyp fspath path));
- let sPath = f path 0 in
+ let sPath = f fspath path 0 in
(* Make sure the parent directory exists *)
begin match Path.deconstructRev sPath with
| None -> mkdirectories Path.empty
@@ -464,14 +489,14 @@ let getRecentVersion fspath path fingerprint =
(Path.toString path)
(Fspath.toDebugString fspath));
Util.convertUnixErrorsToTransient "getRecentVersion" (fun () ->
- let dir = stashDirectory fspath in
+ let dir = stashDirectory fspath path in
let rec aux_find i =
- let path = makeBackupName path i in
+ let path = makeBackupName fspath path i in
if Os.exists dir path &&
(* FIX: should check that the existing file has the same size, to
avoid computing the fingerprint if it is obviously going to be
different... *)
- (let dig = Os.fingerprint dir path (Fileinfo.get false dir path) in
+ (let dig = Os.fingerprint dir path (Fileinfo.getType false dir path) in
dig = fingerprint)
then begin
debug (fun () ->
@@ -502,7 +527,7 @@ let initBackupsLocal () =
let initBackupsRoot: Common.root -> unit -> unit Lwt.t =
Remote.registerRootCmd
- "initBackups"
+ "initBackups" Umarshal.unit Umarshal.unit
(fun (fspath, ()) ->
Lwt.return (initBackupsLocal ()))
diff --git a/src/strings.ml b/src/strings.ml
index 3537c7d..6e853eb 100644
--- a/src/strings.ml
+++ b/src/strings.ml
@@ -4,7 +4,7 @@
let docs =
("about", ("About Unison",
"Unison File Synchronizer\n\
- Version 2.51.5\n\
+ Version 2.53.3\n\
\n\
"))
::
@@ -62,7 +62,7 @@ let docs =
\032 Benjamin Pierce (http://www.cis.upenn.edu/~bcpierce/) leads the Unison\n\
\032 project. The current version of Unison was designed and implemented by\n\
\032 Trevor Jim (http://www.research.att.com/~trevor/), Benjamin Pierce\n\
- \032 (http://www.cis.upenn.edu/~bcpierce/), and J\233r\244me Vouillon\n\
+ \032 (http://www.cis.upenn.edu/~bcpierce/), and J\195\169r\195\180me Vouillon\n\
\032 (http://www.pps.jussieu.fr/~vouillon/), with Alan Schmitt\n\
\032 (http://alan.petitepomme.net/), Malo Denielou, Zhe Yang\n\
\032 (http://www.brics.dk/~zheyang/), Sylvain Gommier, and Matthieu Goulay.\n\
@@ -70,11 +70,11 @@ let docs =
\032 improved by Ben Willmore. Our implementation of the rsync\n\
\032 (http://samba.org/rsync/) protocol was built by Norman Ramsey\n\
\032 (http://www.eecs.harvard.edu/~nr/) and Sylvain Gommier. It is based on\n\
- \032 Andrew Tridgell (http://samba.anu.edu.au/~tridge/)'s thesis work\n\
+ \032 Andrew Tridgell (http://samba.anu.edu.au/~tridge/)\226\128\153s thesis work\n\
\032 (http://samba.anu.edu.au/~tridge/phd_thesis.pdf) and inspired by his\n\
\032 rsync (http://samba.org/rsync/) utility. The mirroring and merging\n\
\032 functionality was implemented by Sylvain Roy, improved by Malo\n\
- \032 Denielou, and improved yet further by St\233phane Lescuyer. Jacques\n\
+ \032 Denielou, and improved yet further by St\195\169phane Lescuyer. Jacques\n\
\032 Garrigue (http://wwwfun.kurims.kyoto-u.ac.jp/~garrigue/) contributed\n\
\032 the original Gtk version of the user interface; the Gtk2 version was\n\
\032 built by Stephen Tse. Sundar Balasubramaniam helped build a prototype\n\
@@ -132,7 +132,7 @@ let docs =
\032 small improvements, and contributed patches.\n\
\n\
\032 Proposed changes to unison are welcome. They should be submitted as\n\
- \032 pull requests. (Since safety and robustness are Unison's most important\n\
+ \032 pull requests. (Since safety and robustness are Unison\226\128\153s most important\n\
\032 properties, patches will be held to high standards of clear design and\n\
\032 clean coding.) If you want to contribute to Unison, start by\n\
\032 downloading the developer tarball from the download page. For some\n\
@@ -166,7 +166,7 @@ let docs =
\n\
\032 Work on Unison has been supported by the National Science Foundation\n\
\032 under grants CCR-9701826 and ITR-0113226, Principles and Practice of\n\
- \032 Synchronization, and by University of Pennsylvania's Institute for\n\
+ \032 Synchronization, and by University of Pennsylvania\226\128\153s Institute for\n\
\032 Research in Cognitive Science (IRCS).\n\
\n\
"))
@@ -190,7 +190,7 @@ let docs =
\032 You will need to install a copy of Unison on every machine that you\n\
\032 want to synchronize. However, you only need the version with a\n\
\032 graphical user interface (if you want a GUI at all) on the machine\n\
- \032 where you're actually going to display the interface (the CLIENT\n\
+ \032 where you\226\128\153re actually going to display the interface (the CLIENT\n\
\032 machine). Other machines that you synchronize with can get along just\n\
\032 fine with the textual version.\n\
\n\
@@ -198,10 +198,10 @@ let docs =
\n\
\032 See https://github.com/bcpierce00/unison/wiki/Downloading-Unison.\n\
\n\
- \032 If a pre-built binary of Unison is available for the client machine's\n\
+ \032 If a pre-built binary of Unison is available for the client machine\226\128\153s\n\
\032 architecture, just download it and put it somewhere in your search path\n\
- \032 (if you're going to invoke it from the command line) or on your desktop\n\
- \032 (if you'll be click-starting it).\n\
+ \032 (if you\226\128\153re going to invoke it from the command line) or on your desktop\n\
+ \032 (if you\226\128\153ll be click-starting it).\n\
\n\
\032 The executable file for the graphical version (with a name including\n\
\032 gtkui) actually provides both interfaces: the graphical one appears by\n\
@@ -209,23 +209,22 @@ let docs =
\032 text on the command line. The textui executable provides just the\n\
\032 textual interface.\n\
\n\
- \032 If you don't see a pre-built executable for your architecture, you'll\n\
- \032 need to build it yourself. See the section \"Building Unison from\n\
- \032 Scratch\" .\n\
+ \032 If you don\226\128\153t see a pre-built executable for your architecture, you\226\128\153ll\n\
+ \032 need to build it yourself. See the section \226\128\156Building Unison from\n\
+ \032 Scratch\226\128\157 .\n\
\n\
\032 Check to make sure that what you have downloaded is really executable.\n\
\032 Either click-start it, or type \"unison -version\" at the command line.\n\
\n\
\032 Unison can be used in three different modes: with different directories\n\
- \032 on a single machine, with a remote machine over a direct socket\n\
- \032 connection, or with a remote machine using ssh for authentication and\n\
- \032 secure transfer. If you intend to use the last option, you may need to\n\
- \032 install ssh; see the section \"Installing Ssh\" .\n\
+ \032 on a single machine, with a local or a remote machine over a direct\n\
+ \032 socket connection, or with a remote machine using ssh for\n\
+ \032 authentication and secure transfer.\n\
\n\
Running Unison\n\
\n\
- \032 Once you've got Unison installed on at least one system, read the\n\
- \032 section \"Tutorial\" of the user manual (or type \"unison -doc tutorial\")\n\
+ \032 Once you\226\128\153ve got Unison installed on at least one system, read the\n\
+ \032 section \226\128\156Tutorial\226\128\157 of the user manual (or type \"unison -doc tutorial\")\n\
\032 for instructions on how to get started.\n\
\n\
Upgrading\n\
@@ -238,11 +237,78 @@ let docs =
\032 version of Unison will sometimes introduce a different format for the\n\
\032 archive files used to remember information about the previous state of\n\
\032 the replicas. In this case, the old archive will be ignored (not\n\
- \032 deleted -- if you roll back to the previous version of Unison, you will\n\
+ \032 deleted \226\128\148 if you roll back to the previous version of Unison, you will\n\
\032 find the old archives intact), which means that any differences between\n\
\032 the replicas will show up as conflicts that need to be resolved\n\
\032 manually.\n\
\n\
+ \032 As of version 2.52, Unison has a degree of backward and forward\n\
+ \032 compatibility. This means three things. First, it is possible for local\n\
+ \032 and remote machines to run a different version of Unison. Second, it is\n\
+ \032 possible for local and remote machines to run a version (same or\n\
+ \032 different) of Unison built with a different version of OCaml compiler\n\
+ \032 (this has been problematic historically). Lastly, it is possible to\n\
+ \032 upgrade Unison on the local machine (compiled with any OCaml version)\n\
+ \032 and keep the existing archive.\n\
+ \n\
+ \032 If version interoperability requirements are followed then Unison 2.52\n\
+ \032 and newer can upgrade the archive created by earlier Unison versions.\n\
+ \032 To avoid rebuilding archive files when upgrading from a version older\n\
+ \032 than 2.52, you must install version 2.52 or newer built with the same\n\
+ \032 OCaml version as your previous version of Unison, and then run it at\n\
+ \032 least once on each root. Doing so will upgrade the archive file.\n\
+ \n\
+ \032 After upgrading the archive, you are free to swap the Unison 2.52 or\n\
+ \032 newer executable to one compiled with a different version of OCaml. The\n\
+ \032 archive file is no longer dependent on the compiler version.\n\
+ \n\
+ Version interoperability\n\
+ \n\
+ \032 To ensure interoperability with different Unison versions on local and\n\
+ \032 remote machines, and to upgrade from an earlier version without\n\
+ \032 rebuilding the archive files, you have to remember these guidelines.\n\
+ \032 Upgrading from an incompatible version, while possible and normal, will\n\
+ \032 require fully scanning both roots, which can be time-consuming with big\n\
+ \032 replicas.\n\
+ \n\
+ \032 Unison 2.52 and newer are compatible with:\n\
+ \032 * Unison 2.52 or newer (for as long as backwards compatibility is\n\
+ \032 maintained in the newer versions). You do not have to pay any\n\
+ \032 attention to OCaml compiler versions.\n\
+ \032 * Unison 2.51 if both versions are compiled with same OCaml compiler\n\
+ \032 version (you can see which compiler version was used by running\n\
+ \032 unison -version).\n\
+ \032 * Unison 2.48 if both versions are compiled with same OCaml compiler\n\
+ \032 version. See special notes below.\n\
+ \n\
+ \032 Interoperability matrix for quick reference:\n\
+ \n\
+ \032 Client versions Server versions\n\
+ \032 2.52 or newer 2.51 2.48\n\
+ \032 2.52 or newer full interop same OCaml version same OCaml version\n\
+ \032 2.51 same OCaml version full interop no interop\n\
+ \032 2.48 same OCaml version* no interop full interop\n\
+ \n\
+ \032 Special notes for Unison 2.48:\n\
+ \032 * Unison 2.48 does not show which OCaml compiler was used to compile\n\
+ \032 it. If you do not have the option of re-compiling the 2.48 version,\n\
+ \032 you have two alternatives. First (and most likely to succeed), see\n\
+ \032 what is the version of the OCaml compiler in the same package\n\
+ \032 repository where you installed Unison 2.48 from, then use Unison\n\
+ \032 2.52 compiled with that version. Second, you can just try Unison\n\
+ \032 2.52 executables compiled with different OCaml versions and see\n\
+ \032 which one works with your copy of Unison 2.48.\n\
+ \032 * When running Unison 2.48 on the client machine with Unison 2.52 or\n\
+ \032 newer on the server machine, you have to do some additional\n\
+ \032 configuration. The Unison executable name on the server must start\n\
+ \032 with unison-2.48 (just unison-2.48 is ok, as is unison-2.48.exe,\n\
+ \032 but also unison-2.48+ocaml-4.05). If using TCP socket connection to\n\
+ \032 the server then you\226\128\153re all set! If using ssh then you have to add\n\
+ \032 one of the following options to your profile or as a command-line\n\
+ \032 argument on the client machine: -addversionno; see the section\n\
+ \032 \226\128\156Remote Usage\226\128\157 , or -servercmd; see the section \226\128\156Remote Shell\n\
+ \032 Method\226\128\157 .\n\
+ \n\
Building Unison from Scratch\n\
\n\
\032 If a pre-built image is not available, you will need to compile it from\n\
@@ -253,99 +319,7 @@ let docs =
\032 been tested on many flavors of Windows (98, NT, 2000, XP) and Unix (OS\n\
\032 X, Solaris, Linux, FreeBSD), and on both 32- and 64-bit architectures.\n\
\n\
- Unix\n\
- \n\
- \032 Unison can be built with or without a graphical user interface (GUI).\n\
- \032 The build system will decide automatically depending on the libraries\n\
- \032 installed on your system, but you can also type make UISTYLE=text to\n\
- \032 build Unison without GUI.\n\
- \n\
- \032 You'll need the Objective Caml compiler, available from\n\
- \032 http://caml.inria.fr. OCaml is available from most package managers\n\
- \032 Building and installing OCaml on Unix systems is very straightforward;\n\
- \032 just follow the instructions in the distribution. You'll probably want\n\
- \032 to build the native-code compiler in addition to the bytecode compiler,\n\
- \032 as Unison runs much faster when compiled to native code, but this is\n\
- \032 not absolutely necessary. (Quick start: on many systems, the following\n\
- \032 sequence of commands will get you a working and installed compiler:\n\
- \032 first do make world opt, then su to root and do make install.)\n\
- \n\
- \032 You'll also need the GNU make utility, which is standard on most Unix\n\
- \032 systems. Unison's build system is not parallelizable, so don't use\n\
- \032 flags that cause it to start processes in parallel (e.g. -j).\n\
- \n\
- \032 Once you've got OCaml installed, grab a copy of the Unison sources,\n\
- \032 unzip and untar them, change to the new \"unison\" directory, and type\n\
- \032 \"make UISTYLE=text\". The result should be an executable file called\n\
- \032 \"unison\". Type \"./unison\" to make sure the program is executable. You\n\
- \032 should get back a usage message.\n\
- \n\
- \032 If you want to build the graphical user interface, you will need to\n\
- \032 install some additional things:\n\
- \032 * The Gtk2 development libraries (package libgtk2.0-dev on debian\n\
- \032 based systems).\n\
- \032 * OCaml bindings for Gtk2. Install them from your software\n\
- \032 repositories (package liblablgtk2-ocaml on debian based systems).\n\
- \032 Also available from\n\
- \032 http://wwwfun.kurims.kyoto-u.ac.jp/soft/olabl/lablgtk.html.\n\
- \032 * Pango, a text rendering library and a part of Gtk2. On some systems\n\
- \032 (e.g. Ubuntu) the bindings between Pango and OCaml need to be\n\
- \032 installed explicitly (package liblablgtk-extras-ocaml-dev on\n\
- \032 Ubuntu).\n\
- \n\
- \032 Type make src to build Unison. If Gtk2 is available on the system,\n\
- \032 Unison with a GUI will be built automatically.\n\
- \n\
- \032 Put the unison executable somewhere in your search path, either by\n\
- \032 adding the Unison directory to your PATH variable or by copying the\n\
- \032 executable to some standard directory where executables are stored. Or\n\
- \032 just type make install to install Unison to $HOME/bin/unison.\n\
- \n\
- Mac OS X\n\
- \n\
- \032 To build the text-only user interface, follow the instructions above\n\
- \032 for building on Unix systems. You should do this first, even if you are\n\
- \032 also planning on building the GUI, just to make sure it works.\n\
- \n\
- \032 To build the basic GUI version, you'll first need to download and\n\
- \032 install the XCode developer tools from Apple. Once this is done, just\n\
- \032 type make in the src directory, and if things go well you should get an\n\
- \032 application that you can move from uimac/build/Default/Unison.app to\n\
- \032 wherever you want it.\n\
- \n\
- Windows\n\
- \n\
- \032 Although the binary distribution should work on any version of Windows,\n\
- \032 some people may want to build Unison from scratch on those systems too.\n\
- \n\
- Bytecode version:\n\
- \n\
- \032 The simpler but slower compilation option to build a Unison executable\n\
- \032 is to build a bytecode version. You need first install Windows version\n\
- \032 of the OCaml compiler (version 3.07 or later, available from\n\
- \032 http://caml.inria.fr). Then grab a copy of Unison sources and type\n\
- \032 make NATIVE=false\n\
- \n\
- \032 to compile the bytecode. The result should be an executable file called\n\
- \032 unison.exe.\n\
- \n\
- Native version:\n\
- \n\
- \032 Building a more efficient, native version of Unison on Windows requires\n\
- \032 a little more work. See the file INSTALL.win32 in the source code\n\
- \032 distribution.\n\
- \n\
- Installation Options\n\
- \n\
- \032 The Makefile in the distribution includes several switches that can be\n\
- \032 used to control how Unison is built. Here are the most useful ones:\n\
- \032 * Building with NATIVE=true uses the native-code OCaml compiler,\n\
- \032 yielding an executable that will run quite a bit faster. We use\n\
- \032 this for building distribution versions.\n\
- \032 * Building with make DEBUGGING=true generates debugging symbols.\n\
- \032 * Building with make STATIC=true generates a (mostly) statically\n\
- \032 linked executable. We use this for building distribution versions,\n\
- \032 for portability.\n\
+ \032 Building instructions are included with the source code.\n\
\n\
"))
::
@@ -369,29 +343,29 @@ let docs =
\032 identical.\n\
\n\
\032 The graphical version can also be run directly by clicking on its icon,\n\
- \032 but this may require a little set-up (see the section \"Click-starting\n\
- \032 Unison\" ). For this tutorial, we assume that you're starting it from\n\
+ \032 but this may require a little set-up (see the section \226\128\156Click-starting\n\
+ \032 Unison\226\128\157 ). For this tutorial, we assume that you\226\128\153re starting it from\n\
\032 the command line.\n\
\n\
\032 Unison can synchronize files and directories on a single machine, or\n\
\032 between two machines on a network. (The same program runs on both\n\
\032 machines; the only difference is which one is responsible for\n\
- \032 displaying the user interface.) If you're only interested in a\n\
- \032 single-machine setup, then let's call that machine the CLIENT . If\n\
- \032 you're synchronizing two machines, let's call them CLIENT and SERVER .\n\
+ \032 displaying the user interface.) If you\226\128\153re only interested in a\n\
+ \032 single-machine setup, then let\226\128\153s call that machine the CLIENT . If\n\
+ \032 you\226\128\153re synchronizing two machines, let\226\128\153s call them CLIENT and SERVER .\n\
\n\
Local Usage\n\
\n\
- \032 Let's get the client machine set up first and see how to synchronize\n\
+ \032 Let\226\128\153s get the client machine set up first and see how to synchronize\n\
\032 two directories on a single machine.\n\
\n\
- \032 Follow the instructions in the section \"Installation\" to either\n\
+ \032 Follow the instructions in the section \226\128\156Installation\226\128\157 to either\n\
\032 download or build an executable version of Unison, and install it\n\
\032 somewhere on your search path. (If you just want to use the textual\n\
\032 user interface, download the appropriate textui binary. If you just\n\
- \032 want to the graphical interface--or if you will use both interfaces\n\
- \032 [the gtkui binary actually has both compiled in]--then download the\n\
- \032 gtkui binary.)\n\
+ \032 want to the graphical interface\226\128\148or if you will use both interfaces [the\n\
+ \032 gtkui binary actually has both compiled in]\226\128\148then download the gtkui\n\
+ \032 binary.)\n\
\n\
\032 Create a small test directory a.tmp containing a couple of files and/or\n\
\032 subdirectories, e.g.,\n\
@@ -404,7 +378,7 @@ let docs =
\032 cp -r a.tmp b.tmp\n\
\n\
\032 Now try synchronizing a.tmp and b.tmp. (Since they are identical,\n\
- \032 synchronizing them won't propagate any changes, but Unison will\n\
+ \032 synchronizing them won\226\128\153t propagate any changes, but Unison will\n\
\032 remember the current state of both directories so that it will be able\n\
\032 to tell next time what has changed.) Type:\n\
\032 unison a.tmp b.tmp\n\
@@ -440,7 +414,7 @@ let docs =
\n\
\032 indicates that the file c has been modified only in the second replica,\n\
\032 and that the default action is therefore to propagate the new version\n\
- \032 to the first replica. To follow Unison's recommendation, press the \"f\"\n\
+ \032 to the first replica. To follow Unison\226\128\153s recommendation, press the \226\128\156f\226\128\157\n\
\032 at the prompt.\n\
\n\
\032 If both replicas are modified and their contents are different, then\n\
@@ -456,7 +430,7 @@ let docs =
\032 shown. Unison simply notes that the file is up to date.\n\
\n\
\032 These display conventions are used by both versions of the user\n\
- \032 interface. The only difference lies in the way in which Unison's\n\
+ \032 interface. The only difference lies in the way in which Unison\226\128\153s\n\
\032 default actions are either accepted or overridden by the user.\n\
\n\
\032 Textual Interface:\n\
@@ -465,13 +439,13 @@ let docs =
\032 interface will ask for instructions as to how to propagate the\n\
\032 change. If some default action is indicated (by an arrow), you can\n\
\032 simply press Return to go on to the next changed file. If you want\n\
- \032 to do something different with this file, press \"<\" or \">\" to force\n\
+ \032 to do something different with this file, press \226\128\156<\226\128\157 or \226\128\156>\226\128\157 to force\n\
\032 the change to be propagated from right to left or from left to\n\
- \032 right, or else press \"/\" to skip this file and leave both replicas\n\
+ \032 right, or else press \226\128\156/\226\128\157 to skip this file and leave both replicas\n\
\032 alone. When it reaches the end of the list of modified files,\n\
\032 Unison will ask you one more time whether it should proceed with\n\
\032 the updates that have been selected.\n\
- \032 When Unison stops to wait for input from the user, pressing \"?\"\n\
+ \032 When Unison stops to wait for input from the user, pressing \226\128\156?\226\128\157\n\
\032 will always give a list of possible responses and their meanings.\n\
\n\
\032 Graphical Interface:\n\
@@ -479,61 +453,67 @@ let docs =
\032 either a.tmp or b.tmp. To override a default action (or to select\n\
\032 an action in the case when there is no default), first select the\n\
\032 file, either by clicking on its name or by using the up- and\n\
- \032 down-arrow keys. Then press either the left-arrow or \"<\" key (to\n\
+ \032 down-arrow keys. Then press either the left-arrow or \226\128\156<\226\128\157 key (to\n\
\032 cause the version in b.tmp to propagate to a.tmp) or the\n\
- \032 right-arrow or \">\" key (which makes the a.tmp version override\n\
+ \032 right-arrow or \226\128\156>\226\128\157 key (which makes the a.tmp version override\n\
\032 b.tmp).\n\
\032 Every keyboard command can also be invoked from the menus at the\n\
\032 top of the user interface. (Conversely, each menu item is annotated\n\
\032 with its keyboard equivalent, if it has one.)\n\
\032 When you are satisfied with the directions for the propagation of\n\
- \032 changes as shown in the main window, click the \"Go\" button to set\n\
+ \032 changes as shown in the main window, click the \226\128\156Go\226\128\157 button to set\n\
\032 them in motion. A check sign will be displayed next to each\n\
\032 filename when the file has been dealt with.\n\
\n\
Remote Usage\n\
\n\
- \032 Next, we'll get Unison set up to synchronize replicas on two different\n\
+ \032 Next, we\226\128\153ll get Unison set up to synchronize replicas on two different\n\
\032 machines.\n\
\n\
+ \032 NB: Unison has not been designed to run with elevated privileges (e.g.\n\
+ \032 setuid), and it has not been audited for that environment. Therefore\n\
+ \032 Unison should be run with the userid of the owner of the files to be\n\
+ \032 synchronized, and should never be run setuid or similar. (Problems\n\
+ \032 encountered when running setuid etc. must be reproduced without setuid\n\
+ \032 before being reported as bugs.)\n\
+ \n\
\032 Follow the instructions in the Installation section to download or\n\
\032 build an executable version of Unison on the server machine, and\n\
- \032 install it somewhere on your search path. (It doesn't matter whether\n\
+ \032 install it somewhere on your search path. (It doesn\226\128\153t matter whether\n\
\032 you install the textual or graphical version, since the copy of Unison\n\
- \032 on the server doesn't need to display any user interface at all.)\n\
+ \032 on the server doesn\226\128\153t need to display any user interface at all.)\n\
\n\
\032 It is important that the version of Unison installed on the server\n\
\032 machine is the same as the version of Unison on the client machine. But\n\
\032 some flexibility on the version of Unison at the client side can be\n\
\032 achieved by using the -addversionno option; see the section\n\
- \032 \"Preferences\" .\n\
+ \032 \226\128\156Preferences\226\128\157 .\n\
\n\
\032 Now there is a decision to be made. Unison provides two methods for\n\
\032 communicating between the client and the server:\n\
\032 * Remote shell method: To use this method, you must have some way of\n\
- \032 invoking remote commands on the server from the client's command\n\
+ \032 invoking remote commands on the server from the client\226\128\153s command\n\
\032 line, using a facility such as ssh. This method is more convenient\n\
- \032 (since there is no need to manually start a \"unison server\" process\n\
- \032 on the server) and also more secure (especially if you use ssh).\n\
- \032 * Socket method: This method requires only that you can get TCP\n\
- \032 packets from the client to the server and back. A draconian\n\
- \032 firewall can prevent this, but otherwise it should work anywhere.\n\
+ \032 (since there is no need to manually start a \226\128\156unison server\226\128\157 process\n\
+ \032 on the server) and also more secure, assuming you are using ssh).\n\
+ \032 * TCP socket method: This method requires only that you can get TCP\n\
+ \032 packets from the client to the server and back. It is insecure and\n\
+ \032 should not be used.\n\
+ \032 * Unix socket method: This method only works within a single machine.\n\
+ \032 It is similar to the TCP sockets method, but it is possible to\n\
+ \032 configure it securely.\n\
\n\
\032 Decide which of these you want to try, and continue with the section\n\
- \032 \"Remote Shell Method\" or the section \"Socket Method\" , as appropriate.\n\
+ \032 \226\128\156Remote Shell Method\226\128\157 or the section \226\128\156Socket Method\226\128\157 , as appropriate.\n\
\n\
Remote Shell Method\n\
\n\
- \032 The standard remote shell facility on Unix systems is ssh, which\n\
- \032 provides the same functionality as the older rsh but much better\n\
- \032 security. Ssh is available from http://www.openssh.org. See section\n\
- \032 [1]?? for installation instructions for the Windows version.\n\
+ \032 The standard remote shell facility on Unix systems is ssh.\n\
\n\
\032 Running ssh requires some coordination between the client and server\n\
\032 machines to establish that the client is allowed to invoke commands on\n\
\032 the server; please refer to the ssh documentation for information on\n\
- \032 how to set this up. The examples in this section use ssh, but you can\n\
- \032 substitute rsh for ssh if you wish.\n\
+ \032 how to set this up.\n\
\n\
\032 First, test that we can invoke Unison on the server from the client.\n\
\032 Typing\n\
@@ -543,9 +523,9 @@ let docs =
\032 unison -version\n\
\n\
\032 locally on the client. If remote execution fails, then either something\n\
- \032 is wrong with your ssh setup (e.g., \"permission denied\") or else the\n\
- \032 search path that's being used when executing commands on the server\n\
- \032 doesn't contain the unison executable (e.g., \"command not found\").\n\
+ \032 is wrong with your ssh setup (e.g., \226\128\156permission denied\226\128\157) or else the\n\
+ \032 search path that\226\128\153s being used when executing commands on the server\n\
+ \032 doesn\226\128\153t contain the unison executable (e.g., \226\128\156command not found\226\128\157).\n\
\n\
\032 Create a test directory a.tmp in your home directory on the client\n\
\032 machine.\n\
@@ -579,15 +559,33 @@ let docs =
\032 server by using the command-line option \"-servercmd\n\
\032 /full/path/name/of/unison\" or adding\n\
\032 \"servercmd=/full/path/name/of/unison\" to your profile (see the\n\
- \032 section \"Profiles\" ). Similarly, you can specify a explicit path\n\
+ \032 section \226\128\156Profiles\226\128\157 ). Similarly, you can specify an explicit path\n\
\032 for the ssh program using the \"-sshcmd\" option. Extra arguments can\n\
\032 be passed to ssh by setting the -sshargs preference.\n\
+ \032 * By leveraging \"-sshcmd\" and \"-sshargs\", you can effectively use any\n\
+ \032 remote shell program, not just ssh; just remember that the roots\n\
+ \032 are still specified with ssh as the protocol, that is, they have to\n\
+ \032 start with \"ssh://\".\n\
\n\
Socket Method\n\
\n\
- \032 Warning: The socket method is insecure: not only are the texts of\n\
- \032 your changes transmitted over the network in unprotected form, it is\n\
- \032 also possible for anyone in the world to connect to the server\n\
+ \032 To run Unison over a socket connection, you must start a Unison daemon\n\
+ \032 process on the server. This process runs continuously, waiting for\n\
+ \032 connections over a given socket from client machines running Unison and\n\
+ \032 processing their requests in turn.\n\
+ \n\
+ \032 Since the socket method is not used by many people, its functionality\n\
+ \032 is rather limited. For example, the server can only deal with one\n\
+ \032 client at a time.\n\
+ \n\
+ \032 Note that the Unison daemon process is always started with a\n\
+ \032 command-line argument; not from a profile.\n\
+ \n\
+ TCP Sockets\n\
+ \n\
+ \032 Warning: The TCP socket method is insecure: not only are the texts\n\
+ \032 of your changes transmitted over the network in unprotected form, it\n\
+ \032 is also possible for anyone in the world to connect to the server\n\
\032 process and read out the contents of your filesystem! (Of course, to\n\
\032 do this they must understand the protocol that Unison uses to\n\
\032 communicate between client and server, but all they need for this is\n\
@@ -595,39 +593,58 @@ let docs =
\032 for expert users with specific needs; everyone else should use the\n\
\032 ssh method.\n\
\n\
- \032 To run Unison over a socket connection, you must start a Unison daemon\n\
- \032 process on the server. This process runs continuously, waiting for\n\
- \032 connections over a given socket from client machines running Unison and\n\
- \032 processing their requests in turn.\n\
- \n\
- \032 Note that socket mode cannot be started from a profile. It should be\n\
- \032 started as a command-line argument only.\n\
- \n\
- \032 To start the daemon, type\n\
+ \032 To start the daemon for connections over a TCP socket, type\n\
\032 unison -socket NNNN\n\
\n\
- \032 on the server machine, where NNNN is the socket number that the daemon\n\
- \032 should listen on for connections from clients. (NNNN can be any large\n\
- \032 number that is not being used by some other program; if NNNN is already\n\
- \032 in use, Unison will exit with an error message.) Note that paths\n\
- \032 specified by the client will be interpreted relative to the directory\n\
- \032 in which you start the server process; this behavior is different from\n\
- \032 the ssh case, where the path is relative to your home directory on the\n\
- \032 server.\n\
+ \032 on the server machine, where NNNN is the TCP port number that the\n\
+ \032 daemon should listen on for connections from clients. (NNNN can be any\n\
+ \032 large number that is not being used by some other program; if NNNN is\n\
+ \032 already in use, Unison will exit with an error message.)\n\
\n\
\032 Create a test directory a.tmp in your home directory on the client\n\
\032 machine. Now type:\n\
\032 unison a.tmp socket://remotehostname:NNNN/a.tmp\n\
\n\
- \032 The result should be that the entire directory a.tmp is propagated from\n\
- \032 the client to the server (a.tmp will be created on the server in the\n\
- \032 directory that the server was started from). After finishing the first\n\
- \032 synchronization, change a few files and try synchronizing again. You\n\
- \032 should see similar results as in the local case.\n\
- \n\
- \032 Since the socket method is not used by many people, its functionality\n\
- \032 is rather limited. For example, the server can only deal with one\n\
- \032 client at a time.\n\
+ \032 Note that paths specified by the client will be interpreted relative to\n\
+ \032 the directory in which you start the server process; this behavior is\n\
+ \032 different from the ssh case, where the path is relative to your home\n\
+ \032 directory on the server. The result should be that the entire directory\n\
+ \032 a.tmp is propagated from the client to the server (a.tmp will be\n\
+ \032 created on the server in the directory that the server was started\n\
+ \032 from). After finishing the first synchronization, change a few files\n\
+ \032 and try synchronizing again. You should see similar results as in the\n\
+ \032 local case.\n\
+ \n\
+ \032 By default Unison will listen for incoming connections on all\n\
+ \032 interfaces. If you want to limit this to certain interfaces or\n\
+ \032 addresses then you can use the -listen command-line argument,\n\
+ \032 specifying a host name or an IP address to listen on. -listen can be\n\
+ \032 given multiple times to listen on several addresses.\n\
+ \n\
+ Unix Domain Sockets\n\
+ \n\
+ \032 To start the daemon for connections over a Unix domain socket, type\n\
+ \032 unison -socket PPPP\n\
+ \n\
+ \032 where PPPP is the path to a Unix socket that the daemon should open for\n\
+ \032 connections from clients. (PPPP can be any absolute or relative path\n\
+ \032 the server process has access to but it must not exist yet; the socket\n\
+ \032 is created at that path when the daemon process is started.) You are\n\
+ \032 responsible for securing access to the socket path. For example, this\n\
+ \032 can be done by controlling the permissions of socket\226\128\153s parent\n\
+ \032 directory, or ensuring a restrictive umask value when starting Unison.\n\
+ \n\
+ \032 Clients can connect to a server over a Unix domain socket by specifying\n\
+ \032 the absolute or relative path to the socket, instead of a server\n\
+ \032 address and port number:\n\
+ \032 unison a.tmp socket://{path/to/unix/socket}/a.tmp\n\
+ \n\
+ \032 (socket path is enclosed in curly braces).\n\
+ \n\
+ \032 Note that Unix domain sockets are local sockets (they exist in the\n\
+ \032 filesystem namespace). One could use Unixs socket remotely, by\n\
+ \032 forwarding access to the socket by other means, for example by using\n\
+ \032 spiped secure pipe daemon.\n\
\n\
Using Unison for All Your Files\n\
\n\
@@ -635,7 +652,7 @@ let docs =
\032 find yourself wanting to use it regularly to synchronize your commonly\n\
\032 used files. There are several possible ways of going about this:\n\
\032 1. Synchronize your whole home directory, using the Ignore facility\n\
- \032 (see the section \"Ignoring Paths\" ) to avoid synchronizing\n\
+ \032 (see the section \226\128\156Ignoring Paths\226\128\157 ) to avoid synchronizing\n\
\032 temporary files and things that only belong on one host.\n\
\032 2. Create a subdirectory called shared (or current, or whatever) in\n\
\032 your home directory on each host, and put all the files you want to\n\
@@ -643,7 +660,7 @@ let docs =
\032 3. Create a subdirectory called shared (or current, or whatever) in\n\
\032 your home directory on each host, and put links to all the files\n\
\032 you want to synchronize into this directory. Use the follow\n\
- \032 preference (see the section \"Symbolic Links\" ) to make Unison treat\n\
+ \032 preference (see the section \226\128\156Symbolic Links\226\128\157 ) to make Unison treat\n\
\032 these links as transparent.\n\
\032 4. Make your home directory the root of the synchronization, but tell\n\
\032 Unison to synchronize only some of the files and subdirectories\n\
@@ -659,19 +676,19 @@ let docs =
\032 -path .netscape/bookmarks.html\n\
\n\
\032 These -path arguments can also be put in your preference file. See\n\
- \032 the section \"Preferences\" for an example.\n\
+ \032 the section \226\128\156Preferences\226\128\157 for an example.\n\
\n\
\032 Most people find that they only need to maintain a profile (or\n\
\032 profiles) on one of the hosts that they synchronize, since Unison is\n\
- \032 always initiated from this host. (For example, if you're synchronizing\n\
- \032 a laptop with a fileserver, you'll probably always run Unison on the\n\
+ \032 always initiated from this host. (For example, if you\226\128\153re synchronizing\n\
+ \032 a laptop with a fileserver, you\226\128\153ll probably always run Unison on the\n\
\032 laptop.) This is a bit different from the usual situation with\n\
\032 asymmetric mirroring programs like rdist, where the mirroring operation\n\
\032 typically needs to be initiated from the machine with the most recent\n\
- \032 changes. the section \"Profiles\" covers the syntax of Unison profiles,\n\
+ \032 changes. the section \226\128\156Profiles\226\128\157 covers the syntax of Unison profiles,\n\
\032 together with some sample profiles.\n\
\n\
- \032 Some tips on improving Unison's performance can be found on the\n\
+ \032 Some tips on improving Unison\226\128\153s performance can be found on the\n\
\032 Frequently Asked Questions page\n\
\032 (http://www.cis.upenn.edu/~bcpierce/unison/faq.html).\n\
\n\
@@ -682,11 +699,11 @@ let docs =
\032 performing multiple pairwise synchronizations.\n\
\n\
\032 If you need to do this, the most reliable way to set things up is to\n\
- \032 organize the machines into a \"star topology,\" with one machine\n\
- \032 designated as the \"hub\" and the rest as \"spokes,\" and with each spoke\n\
+ \032 organize the machines into a \226\128\156star topology,\226\128\157 with one machine\n\
+ \032 designated as the \226\128\156hub\226\128\157 and the rest as \226\128\156spokes,\226\128\157 and with each spoke\n\
\032 machine synchronizing only with the hub. The big advantage of the star\n\
- \032 topology is that it eliminates the possibility of confusing \"spurious\n\
- \032 conflicts\" arising from the fact that a separate archive is maintained\n\
+ \032 topology is that it eliminates the possibility of confusing \226\128\156spurious\n\
+ \032 conflicts\226\128\157 arising from the fact that a separate archive is maintained\n\
\032 by Unison for every pair of hosts that it synchronizes.\n\
\n\
Going Further\n\
@@ -697,12 +714,12 @@ let docs =
\n\
\032 at the command line, or by selecting the Help menu in the graphical\n\
\032 user interface. The same information is also available in a typeset\n\
- \032 User's Manual (HTML or PostScript format) through\n\
+ \032 User\226\128\153s Manual (HTML or PostScript format) through\n\
\032 http://www.cis.upenn.edu/~bcpierce/unison.\n\
\n\
\032 If you use Unison regularly, you should subscribe to one of the mailing\n\
\032 lists, to receive announcements of new versions. See the section\n\
- \032 \"Mailing Lists and Bug Reporting\" .\n\
+ \032 \226\128\156Mailing Lists and Bug Reporting\226\128\157 .\n\
\n\
"))
::
@@ -710,14 +727,16 @@ let docs =
"Basic Concepts\n\
\n\
\032 To understand how Unison works, it is necessary to discuss a few\n\
- \032 straightforward concepts. These concepts are developed more rigorously\n\
- \032 and at more length in a number of papers, available at\n\
+ \032 straightforward concepts.\n\
+ \n\
+ \032 These concepts are developed more rigorously and at more length in a\n\
+ \032 number of papers, available at\n\
\032 http://www.cis.upenn.edu/~bcpierce/papers. But the informal\n\
\032 presentation here should be enough for most users.\n\
\n\
Roots\n\
\n\
- \032 A replica's root tells Unison where to find a set of files to be\n\
+ \032 A replica\226\128\153s root tells Unison where to find a set of files to be\n\
\032 synchronized, either on the local machine or on a remote host. For\n\
\032 example,\n\
\032 relative/path/of/root\n\
@@ -728,18 +747,23 @@ let docs =
\n\
\032 specifies a root relative to the top of the local filesystem,\n\
\032 independent of where Unison is running. Remote roots can begin with\n\
- \032 ssh://, rsh:// to indicate that the remote server should be started\n\
- \032 with rsh or ssh:\n\
+ \032 ssh:// to indicate that the remote server should be started with ssh:\n\
\032 ssh://remotehost//absolute/path/of/root\n\
- \032 rsh://user@remotehost/relative/path/of/root\n\
+ \032 ssh://user@remotehost/relative/path/of/root\n\
\n\
\032 If the remote server is already running (in the socket mode), then the\n\
\032 syntax\n\
\032 socket://remotehost:portnum//absolute/path/of/root\n\
\032 socket://remotehost:portnum/relative/path/of/root\n\
+ \032 socket://[IPv6literal]:portnum/path\n\
\n\
\032 is used to specify the hostname and the port that the client Unison\n\
- \032 should use to contact it.\n\
+ \032 should use to contact it. Syntax\n\
+ \032 socket://{path/of/socket}//absolute/path/of/root\n\
+ \032 socket://{path/of/socket}/relative/path/of/root\n\
+ \n\
+ \032 is used to specify the Unix domain socket the client Unison should use\n\
+ \032 to contact the server.\n\
\n\
\032 The syntax for roots is based on that of URIs (described in RFC 2396).\n\
\032 The full grammar is:\n\
@@ -749,11 +773,14 @@ let docs =
\032 protocol ::= file\n\
\032 | socket\n\
\032 | ssh\n\
- \032 | rsh\n\
\n\
\032 user ::= [-_a-zA-Z0-9]+\n\
\n\
\032 host ::= [-_a-zA-Z0-9.]+\n\
+ \032 | \\[ [a-f0-9:.]+ zone? \\] IPv6 literals (no future format).\n\
+ \032 | { [^}]+ } For Unix domain sockets only.\n\
+ \n\
+ \032 zone ::= %[-_a-zA-Z0-9~%.]+\n\
\n\
\032 port ::= [0-9]+\n\
\n\
@@ -794,7 +821,7 @@ let docs =
\032 /home/bcpierce/current/todo.txt on the server.)\n\
\n\
\032 The empty path (i.e., the empty sequence of names) denotes the whole\n\
- \032 replica. Unison displays the empty path as \"[root].\"\n\
+ \032 replica. Unison displays the empty path as \226\128\156[root].\226\128\157\n\
\n\
\032 If p is a path and q is a path beginning with p, then q is said to be a\n\
\032 descendant of p. (Each path is also a descendant of itself.)\n\
@@ -810,10 +837,10 @@ let docs =
\032 * If p refers to a symbolic link, then the contents of p are just the\n\
\032 string specifying where the link points.\n\
\032 * If p refers to a directory, then the contents of p are just the\n\
- \032 token \"DIRECTORY\" plus the current permission bits of the\n\
+ \032 token \226\128\156DIRECTORY\226\128\157 plus the current permission bits of the\n\
\032 directory.\n\
\032 * If p does not refer to anything in this replica, then the contents\n\
- \032 of p are the token \"ABSENT.\"\n\
+ \032 of p are the token \226\128\156ABSENT.\226\128\157\n\
\n\
\032 Unison keeps a record of the contents of each path after each\n\
\032 successful synchronization of that path (i.e., it remembers the\n\
@@ -823,15 +850,15 @@ let docs =
\032 We say that a path is updated (in some replica) if its current contents\n\
\032 are different from its contents the last time it was successfully\n\
\032 synchronized. Note that whether a path is updated has nothing to do\n\
- \032 with its last modification time--Unison considers only the contents\n\
- \032 when determining whether an update has occurred. This means that\n\
- \032 touching a file without changing its contents will not be recognized as\n\
- \032 an update. A file can even be changed several times and then changed\n\
- \032 back to its original contents; as long as Unison is only run at the end\n\
- \032 of this process, no update will be recognized.\n\
+ \032 with its last modification time\226\128\148Unison considers only the contents when\n\
+ \032 determining whether an update has occurred. This means that touching a\n\
+ \032 file without changing its contents will not be recognized as an update.\n\
+ \032 A file can even be changed several times and then changed back to its\n\
+ \032 original contents; as long as Unison is only run at the end of this\n\
+ \032 process, no update will be recognized.\n\
\n\
\032 What Unison actually calculates is a close approximation to this\n\
- \032 definition; see the section \"Caveats and Shortcomings\" .\n\
+ \032 definition; see the section \226\128\156Caveats and Shortcomings\226\128\157 .\n\
\n\
What is a Conflict?\n\
\n\
@@ -848,7 +875,7 @@ let docs =
\032 of each path in the replica when it was last synchronized) with the\n\
\032 current contents of the replica, to determine which paths have been\n\
\032 updated.\n\
- \032 2. It checks for \"false conflicts\" -- paths that have been updated on\n\
+ \032 2. It checks for \226\128\156false conflicts\226\128\157 \226\128\148 paths that have been updated on\n\
\032 both replicas, but whose current values are identical. These paths\n\
\032 are silently marked as synchronized in the archive files in both\n\
\032 replicas.\n\
@@ -882,7 +909,7 @@ let docs =
\032 original contents (i.e., no change at all has been made to this\n\
\032 path), or (2) its correct final contents (i.e., the value that the\n\
\032 user expected to be propagated from the other replica).\n\
- \032 * At every moment, the information stored on disk about Unison's\n\
+ \032 * At every moment, the information stored on disk about Unison\226\128\153s\n\
\032 private state can be either (1) unchanged, or (2) updated to\n\
\032 reflect those paths that have been successfully synchronized.\n\
\n\
@@ -900,7 +927,7 @@ let docs =
\n\
\032 If an interruption happens while it is propagating updates, then there\n\
\032 may be some paths for which an update has been propagated but which\n\
- \032 have not been marked as synchronized in Unison's archives. This is no\n\
+ \032 have not been marked as synchronized in Unison\226\128\153s archives. This is no\n\
\032 problem: the next time Unison runs, it will detect changes to these\n\
\032 paths in both replicas, notice that the contents are now equal, and\n\
\032 mark the paths as successfully updated when it writes back its private\n\
@@ -919,7 +946,7 @@ let docs =
\032 them is that the clock on each system always runs forward.\n\
\n\
\032 If Unison finds that its archive files have been deleted (or that the\n\
- \032 archive format has changed and they cannot be read, or that they don't\n\
+ \032 archive format has changed and they cannot be read, or that they don\226\128\153t\n\
\032 exist because this is the first run of Unison on these particular\n\
\032 roots), it takes a conservative approach: it behaves as though the\n\
\032 replicas had both been completely empty at the point of the last\n\
@@ -930,15 +957,15 @@ let docs =
\n\
\032 Touching a file without changing its contents should never affect\n\
\032 whether or not Unison does an update. (When running with the fastcheck\n\
- \032 preference set to true--the default on Unix systems--Unison uses file\n\
+ \032 preference set to true\226\128\148the default on Unix systems\226\128\148Unison uses file\n\
\032 modtimes for a quick first pass to tell which files have definitely not\n\
\032 changed; then, for each file that might have changed, it computes a\n\
- \032 fingerprint of the file's contents and compares it against the\n\
+ \032 fingerprint of the file\226\128\153s contents and compares it against the\n\
\032 last-synchronized contents. Also, the -times option allows you to\n\
\032 synchronize file times, but it does not cause identical files to be\n\
\032 changed; Unison will only modify the file times.)\n\
\n\
- \032 It is safe to \"brainwash\" Unison by deleting its archive files on both\n\
+ \032 It is safe to \226\128\156brainwash\226\128\157 Unison by deleting its archive files on both\n\
\032 replicas. The next time it runs, it will assume that all the files it\n\
\032 sees in the replicas are new.\n\
\n\
@@ -948,7 +975,7 @@ let docs =
\032 for that file. Run Unison again to propagate the latest change.\n\
\n\
\032 Changes to the ignore patterns from the user interface (e.g., using the\n\
- \032 `i' key) are immediately reflected in the current profile.\n\
+ \032 \226\128\152i\226\128\153 key) are immediately reflected in the current profile.\n\
\n\
Caveats and Shortcomings\n\
\n\
@@ -956,15 +983,15 @@ let docs =
\032 * In the interests of speed, the update detection algorithm may\n\
\032 (depending on which OS architecture that you run Unison on)\n\
\032 actually use an approximation to the definition given in the\n\
- \032 section \"What is an Update?\" .\n\
+ \032 section \226\128\156What is an Update?\226\128\157 .\n\
\032 In particular, the Unix implementation does not compare the actual\n\
\032 contents of files to their previous contents, but simply looks at\n\
- \032 each file's inode number and modtime; if neither of these have\n\
+ \032 each file\226\128\153s inode number and modtime; if neither of these have\n\
\032 changed, then it concludes that the file has not been changed.\n\
\032 Under normal circumstances, this approximation is safe, in the\n\
- \032 sense that it may sometimes detect \"false updates\" but will never\n\
+ \032 sense that it may sometimes detect \226\128\156false updates\226\128\157 but will never\n\
\032 miss a real one. However, it is possible to fool it, for example by\n\
- \032 using retouch to change a file's modtime back to a time in the\n\
+ \032 using retouch to change a file\226\128\153s modtime back to a time in the\n\
\032 past.\n\
\032 * If you synchronize between a single-user filesystem and a shared\n\
\032 Unix server, you should pay attention to your permission bits: by\n\
@@ -972,7 +999,7 @@ let docs =
\032 leave group-writable files on the server that could be written over\n\
\032 by a lot of people.\n\
\032 You can control this by setting your umask on both computers to\n\
- \032 something like 022, masking out the \"world write\" and \"group write\"\n\
+ \032 something like 022, masking out the \226\128\156world write\226\128\157 and \226\128\156group write\226\128\157\n\
\032 permission bits.\n\
\032 Unison does not synchronize the setuid and setgid bits, for\n\
\032 security.\n\
@@ -985,12 +1012,12 @@ let docs =
\032 * It is important to be a little careful when renaming directories\n\
\032 containing ignored files.\n\
\032 For example, suppose Unison is synchronizing directory A between\n\
- \032 the two machines called the \"local\" and the \"remote\" machine;\n\
+ \032 the two machines called the \226\128\156local\226\128\157 and the \226\128\156remote\226\128\157 machine;\n\
\032 suppose directory A contains a subdirectory D; and suppose D on the\n\
\032 local machine contains a file or subdirectory P that matches an\n\
\032 ignore directive in the profile used to synchronize. Thus path\n\
\032 A/D/P exists on the local machine but not on the remote machine.\n\
- \032 If D is renamed to D' on the remote machine, and this change is\n\
+ \032 If D is renamed to D\226\128\153 on the remote machine, and this change is\n\
\032 propagated to the local machine, all such files or subdirectories P\n\
\032 will be deleted. This is because Unison sees the rename as a delete\n\
\032 and a separate create: it deletes the old directory (including the\n\
@@ -1010,16 +1037,16 @@ let docs =
"Running Unison\n\
\n\
\032 There are several ways to start Unison.\n\
- \032 * Typing \"unison profile\" on the command line. Unison will look for a\n\
+ \032 * Typing \226\128\156unison profile\226\128\157 on the command line. Unison will look for a\n\
\032 file profile.prf in the .unison directory. If this file does not\n\
\032 specify a pair of roots, Unison will prompt for them and add them\n\
\032 to the information specified by the profile.\n\
- \032 * Typing \"unison profile root1 root2\" on the command line. In this\n\
+ \032 * Typing \226\128\156unison profile root1 root2\226\128\157 on the command line. In this\n\
\032 case, Unison will use profile, which should not contain any root\n\
\032 directives.\n\
- \032 * Typing \"unison root1 root2\" on the command line. This has the same\n\
- \032 effect as typing \"unison default root1 root2.\"\n\
- \032 * Typing just \"unison\" (or invoking Unison by clicking on a desktop\n\
+ \032 * Typing \226\128\156unison root1 root2\226\128\157 on the command line. This has the same\n\
+ \032 effect as typing \226\128\156unison default root1 root2.\226\128\157\n\
+ \032 * Typing just \226\128\156unison\226\128\157 (or invoking Unison by clicking on a desktop\n\
\032 icon). In this case, Unison will ask for the profile to use for\n\
\032 synchronization (or create a new one, if necessary).\n\
\n\
@@ -1030,7 +1057,7 @@ let docs =
\032 will be used as the path/folder name for this directory. This can be\n\
\032 just a name, or a path.\n\
\n\
- \032 A name on it's own, for example UNISON=mytestname will place a folder\n\
+ \032 A name on it\226\128\153s own, for example UNISON=mytestname will place a folder\n\
\032 in the same directory that the Unison binary was run in, with that\n\
\032 name. Using a path like UNISON=../mytestname2 will place that folder in\n\
\032 the folder above where the Unison binary was run from.\n\
@@ -1045,7 +1072,7 @@ let docs =
\032 default.\n\
\n\
\032 The archive file for each replica is found in the .unison directory on\n\
- \032 that replica's host. Profiles (described below) are always taken from\n\
+ \032 that replica\226\128\153s host. Profiles (described below) are always taken from\n\
\032 the .unison directory on the client host.\n\
\n\
\032 Note that Unison maintains a completely different set of archive files\n\
@@ -1077,7 +1104,7 @@ let docs =
\032 to remember which files have been synchronized) normally uses the\n\
\032 gethostname operating system call. However, if the environment variable\n\
\032 UNISONLOCALHOSTNAME is set, its value will be used instead. This makes\n\
- \032 it easier to use Unison in situations where a machine's name changes\n\
+ \032 it easier to use Unison in situations where a machine\226\128\153s name changes\n\
\032 frequently (e.g., because it is a laptop and gets moved around a lot).\n\
\n\
\032 A more powerful way of changing archive names is provided by the\n\
@@ -1097,21 +1124,21 @@ let docs =
\032 file systems.\n\
\n\
\032 Warning: The rootalias option is dangerous and should only be used if\n\
- \032 you are sure you know what you're doing. In particular, it should only\n\
+ \032 you are sure you know what you\226\128\153re doing. In particular, it should only\n\
\032 be used if you are positive that either (1) both the original root and\n\
\032 the new alias refer to the same set of files, or (2) the files have\n\
\032 been relocated so that the original name is now invalid and will never\n\
\032 be used again. (If the original root and the alias refer to different\n\
- \032 sets of files, Unison's update detector could get confused.) After\n\
+ \032 sets of files, Unison\226\128\153s update detector could get confused.) After\n\
\032 introducing a new rootalias, it is a good idea to run Unison a few\n\
\032 times interactively (with the batch flag off, etc.) and carefully check\n\
- \032 that things look reasonable--in particular, that update detection is\n\
+ \032 that things look reasonable\226\128\148in particular, that update detection is\n\
\032 working as expected.\n\
\n\
Preferences\n\
\n\
- \032 Many details of Unison's behavior are configurable by user-settable\n\
- \032 \"preferences.\"\n\
+ \032 Many details of Unison\226\128\153s behavior are configurable by user-settable\n\
+ \032 \226\128\156preferences.\226\128\157\n\
\n\
\032 Some preferences are boolean-valued; these are often called flags.\n\
\032 Others take numeric or string arguments, indicated in the preferences\n\
@@ -1143,131 +1170,167 @@ let docs =
\032 or unison profilename [options]\n\
\n\
Basic options:\n\
- \032-auto automatically accept default (nonconflicting) actions\n\
- \032-batch batch mode: ask no questions at all\n\
- \032-doc xxx show documentation ('-doc topics' lists topics)\n\
- \032-fat use appropriate options for FAT filesystems\n\
- \032-group synchronize group attributes\n\
- \032-i interactive profile mode (text UI); command-line only\n\
- \032-ignore xxx add a pattern to the ignore list\n\
- \032-ignorenot xxx add a pattern to the ignorenot list\n\
- \032-nocreation xxx prevent file creations on one replica\n\
- \032-nodeletion xxx prevent file deletions on one replica\n\
- \032-noupdate xxx prevent file updates and deletions on one replica\n\
- \032-owner synchronize owner\n\
- \032-path xxx path to synchronize\n\
- \032-perms n part of the permissions which is synchronized\n\
- \032-root xxx root of a replica (should be used exactly twice)\n\
- \032-silent print nothing except error messages\n\
- \032-terse suppress status messages\n\
- \032-testserver exit immediately after the connection to the server\n\
- \032-times synchronize modification times\n\
- \032-version print version and exit\n\
+ \n\
+ \032 General:\n\
+ \032 -doc xxx show documentation ('-doc topics' lists topics)\n\
+ \032 -version print version and exit\n\
+ \n\
+ \032 What to sync:\n\
+ \032 -group synchronize group attributes\n\
+ \032 -ignore xxx add a pattern to the ignore list\n\
+ \032 -ignorenot xxx add a pattern to the ignorenot list\n\
+ \032 -nocreation xxx prevent file creations on one replica\n\
+ \032 -nodeletion xxx prevent file deletions on one replica\n\
+ \032 -noupdate xxx prevent file updates and deletions on one replica\n\
+ \032 -owner synchronize owner\n\
+ \032 -path xxx path to synchronize\n\
+ \032 -perms n part of the permissions which is synchronized\n\
+ \032 -root xxx root of a replica (should be used exactly twice)\n\
+ \032 -times synchronize modification times\n\
+ \n\
+ \032 How to sync:\n\
+ \032 -batch batch mode: ask no questions at all\n\
+ \n\
+ \032 How to sync (text interface (CLI) only):\n\
+ \032 -auto automatically accept default (nonconflicting) actions\n\
+ \032 -silent print nothing except error messages\n\
+ \032 -terse suppress status messages\n\
+ \n\
+ \032 Text interface (CLI):\n\
+ \032 -i interactive profile mode (text UI); command-line only\n\
\n\
Advanced options:\n\
- \032-addprefsto xxx file to add new prefs to\n\
- \032-addversionno add version number to name of unison on server\n\
- \032-atomic xxx add a pattern to the atomic list\n\
- \032-backup xxx add a pattern to the backup list\n\
- \032-backupcurr xxx add a pattern to the backupcurr list\n\
- \032-backupcurrnot xxx add a pattern to the backupcurrnot list\n\
- \032-backupdir xxx directory for storing centralized backups\n\
- \032-backuploc xxx where backups are stored ('local' or 'central')\n\
- \032-backupnot xxx add a pattern to the backupnot list\n\
- \032-backupprefix xxx prefix for the names of backup files\n\
- \032-backups keep backup copies of all files (see also 'backup')\n\
- \032-backupsuffix xxx a suffix to be added to names of backup files\n\
- \032-clientHostName xxx set host name of client\n\
- \032-color xxx use color output for text UI (true/false/default)\n\
- \032-confirmbigdel ask about whole-replica (or path) deletes (default true)\n\
- \032-confirmmerge ask for confirmation before committing results of a merge\n\
- \032-contactquietly suppress the 'contacting server' message during startup\n\
- \032-copymax n maximum number of simultaneous copyprog transfers\n\
- \032-copyonconflict keep copies of conflicting files\n\
- \032-copyprog xxx external program for copying large files\n\
- \032-copyprogrest xxx variant of copyprog for resuming partial transfers\n\
- \032-copyquoterem xxx add quotes to remote file name for copyprog (true/false/defa\n\
- ult)\n\
- \032-copythreshold n use copyprog on files bigger than this (if >=0, in Kb)\n\
- \032-debug xxx debug module xxx ('all' -> everything, 'verbose' -> more)\n\
- \032-diff xxx set command for showing differences between files\n\
- \032-dontchmod when set, never use the chmod system call\n\
- \032-dumbtty do not change terminal settings in text UI\n\
- \032-fastcheck xxx do fast update detection (true/false/default)\n\
- \032-fastercheckUNSAFE skip computing fingerprints for new files (experts only!)\n\
- \032-follow xxx add a pattern to the follow list\n\
- \032-force xxx force changes from this replica to the other\n\
- \032-forcepartial xxx add a pattern to the forcepartial list\n\
- \032-halfduplex force half-duplex communication with the server\n\
- \032-height n height (in lines) of main window in graphical interface\n\
- \032-host xxx bind the socket to this host name in server socket mode\n\
- \032-ignorearchives ignore existing archive files\n\
- \032-ignorecase xxx identify upper/lowercase filenames (true/false/default)\n\
- \032-ignoreinodenumbers ignore inode number changes when detecting updates\n\
- \032-ignorelocks ignore locks left over from previous run (dangerous!)\n\
- \032-immutable xxx add a pattern to the immutable list\n\
- \032-immutablenot xxx add a pattern to the immutablenot list\n\
- \032-key xxx define a keyboard shortcut for this profile (in some UIs)\n\
- \032-killserver kill server when done (even when using sockets)\n\
- \032-label xxx provide a descriptive string label for this profile\n\
- \032-links xxx allow the synchronization of symbolic links (true/false/defa\n\
- ult)\n\
- \032-log record actions in logfile (default true)\n\
- \032-logfile xxx logfile name\n\
- \032-maxbackups n number of backed up versions of a file\n\
- \032-maxerrors n maximum number of errors before a directory transfer is abor\n\
- ted\n\
- \032-maxsizethreshold n prevent transfer of files bigger than this (if >=0, in Kb)\n\
- \032-maxthreads n maximum number of simultaneous file transfers\n\
- \032-merge xxx add a pattern to the merge list\n\
- \032-mountpoint xxx abort if this path does not exist\n\
- \032-nocreationpartial xxx add a pattern to the nocreationpartial list\n\
- \032-nodeletionpartial xxx add a pattern to the nodeletionpartial list\n\
- \032-noupdatepartial xxx add a pattern to the noupdatepartial list\n\
- \032-numericids don't map uid/gid values by user/group names\n\
- \032-prefer xxx choose this replica's version for conflicting changes\n\
- \032-preferpartial xxx add a pattern to the preferpartial list\n\
- \032-repeat xxx synchronize repeatedly (text interface only)\n\
- \032-retry n re-try failed synchronizations N times (text ui only)\n\
- \032-rootalias xxx register alias for canonical root names\n\
- \032-rsrc xxx synchronize resource forks (true/false/default)\n\
- \032-rsync activate the rsync transfer mode (default true)\n\
- \032-selftest run internal tests and exit\n\
- \032-servercmd xxx name of unison executable on remote server\n\
- \032-showarchive show 'true names' (for rootalias) of roots and archive\n\
- \032-socket xxx act as a server on a socket\n\
- \032-sortbysize list changed files by size, not name\n\
- \032-sortfirst xxx add a pattern to the sortfirst list\n\
- \032-sortlast xxx add a pattern to the sortlast list\n\
- \032-sortnewfirst list new before changed files\n\
- \032-sshargs xxx other arguments (if any) for remote shell command\n\
- \032-sshcmd xxx path to the ssh executable\n\
- \032-stream use a streaming protocol for transferring file contents (def\n\
- ault true)\n\
- \032-ui xxx select UI ('text' or 'graphic'); command-line only\n\
- \032-unicode xxx assume Unicode encoding in case insensitive mode\n\
- \032-watch when set, use a file watcher process to detect changes\n\
- \032-xferbycopying optimize transfers using local copies (default true)\n\
- \n\
- Special command line options:\n\
- \032-include xxx include a profile file's preferences\n\
- \032-source xxx include a file's preferences\n\
+ \n\
+ \032 Fine-tune sync:\n\
+ \032 -acl synchronize ACLs\n\
+ \032 -atomic xxx add a pattern to the atomic list\n\
+ \032 -follow xxx add a pattern to the follow list\n\
+ \032 -force xxx force changes from this replica to the other\n\
+ \032 -forcepartial xxx add a pattern to the forcepartial list\n\
+ \032 -ignorecase xxx identify upper/lowercase filenames (true/false/default)\n\
+ \032 -immutable xxx add a pattern to the immutable list\n\
+ \032 -immutablenot xxx add a pattern to the immutablenot list\n\
+ \032 -links xxx allow the synchronization of symbolic links\n\
+ \032 (true/false/default)\n\
+ \032 -merge xxx add a pattern to the merge list\n\
+ \032 -nocreationpartial xxx add a pattern to the nocreationpartial list\n\
+ \032 -nodeletionpartial xxx add a pattern to the nodeletionpartial list\n\
+ \032 -noupdatepartial xxx add a pattern to the noupdatepartial list\n\
+ \032 -prefer xxx choose this replica's version for conflicting changes\n\
+ \032 -preferpartial xxx add a pattern to the preferpartial list\n\
+ \032 -rsrc xxx synchronize resource forks (true/false/default)\n\
+ \032 -xattrignore xxx add a pattern to the xattrignore list\n\
+ \032 -xattrignorenot xxx add a pattern to the xattrignorenot list\n\
+ \032 -xattrs synchronize extended attributes (xattrs)\n\
+ \n\
+ \032 How to sync:\n\
+ \032 -backup xxx add a pattern to the backup list\n\
+ \032 -backupcurr xxx add a pattern to the backupcurr list\n\
+ \032 -backupcurrnot xxx add a pattern to the backupcurrnot list\n\
+ \032 -backupdir xxx directory for storing centralized backups\n\
+ \032 -backuploc xxx where backups are stored ('local' or 'central')\n\
+ \032 -backupnot xxx add a pattern to the backupnot list\n\
+ \032 -backupprefix xxx prefix for the names of backup files\n\
+ \032 -backups (deprecated) keep backup copies of all files (see also\n\
+ \032 'backup')\n\
+ \032 -backupsuffix xxx a suffix to be added to names of backup files\n\
+ \032 -confirmbigdel ask about whole-replica (or path) deletes (default true)\n\
+ \032 -confirmmerge ask for confirmation before committing results of a merge\n\
+ \032 -copyonconflict keep copies of conflicting files\n\
+ \032 -dontchmod when set, never use the chmod system call\n\
+ \032 -fastcheck xxx do fast update detection (true/false/default)\n\
+ \032 -fat use appropriate options for FAT filesystems\n\
+ \032 -ignoreinodenumbers ignore inode number changes when detecting updates\n\
+ \032 -maxbackups n number of backed up versions of a file\n\
+ \032 -numericids don't map uid/gid values by user/group names\n\
+ \032 -sortbysize list changed files by size, not name\n\
+ \032 -sortfirst xxx add a pattern to the sortfirst list\n\
+ \032 -sortlast xxx add a pattern to the sortlast list\n\
+ \032 -sortnewfirst list new before changed files\n\
+ \n\
+ \032 How to sync (text interface (CLI) only):\n\
+ \032 -repeat xxx synchronize repeatedly (text interface only)\n\
+ \032 -retry n re-try failed synchronizations N times (text ui only)\n\
+ \n\
+ \032 Text interface (CLI):\n\
+ \032 -color xxx use color output for text UI (true/false/default)\n\
+ \032 -dumbtty do not change terminal settings in text UI\n\
+ \n\
+ \032 Graphical interface (GUI):\n\
+ \032 -height n height (in lines) of main window in graphical interface\n\
+ \n\
+ \032 Remote connections:\n\
+ \032 -addversionno add version number to name of unison on server\n\
+ \032 -clientHostName xxx set host name of client\n\
+ \032 -halfduplex (deprecated) force half-duplex communication with the\n\
+ \032 server\n\
+ \032 -killserver kill server when done (even when using sockets)\n\
+ \032 -listen xxx listen on this name or addr in server socket mode (can\n\
+ \032 repeat)\n\
+ \032 -rsync activate the rsync transfer mode (default true)\n\
+ \032 -servercmd xxx name of unison executable on remote server\n\
+ \032 -socket xxx act as a server on a socket\n\
+ \032 -sshargs xxx other arguments (if any) for remote shell command\n\
+ \032 -sshcmd xxx path to the ssh executable\n\
+ \032 -stream (deprecated) use a streaming protocol for transferring\n\
+ \032 file contents (default true)\n\
+ \032 -testserver exit immediately after the connection to the server\n\
+ \032 -xferbycopying optimize transfers using local copies (default true)\n\
+ \n\
+ \032 Archive management:\n\
+ \032 -ignorearchives ignore existing archive files\n\
+ \n\
+ \032 Other:\n\
+ \032 -addprefsto xxx file to add new prefs to\n\
+ \032 -contactquietly suppress the 'contacting server' message during startup\n\
+ \032 -copymax n maximum number of simultaneous copyprog transfers\n\
+ \032 -copyprog xxx external program for copying large files\n\
+ \032 -copyprogrest xxx variant of copyprog for resuming partial transfers\n\
+ \032 -copythreshold n use copyprog on files bigger than this (if >=0, in Kb)\n\
+ \032 -diff xxx set command for showing differences between files\n\
+ \032 -ignorelocks ignore locks left over from previous run (dangerous!)\n\
+ \032 -include xxx include a profile's preferences\n\
+ \032 -key xxx define a keyboard shortcut for this profile (in some UIs)\n\
+ \032 -label xxx provide a descriptive string label for this profile\n\
+ \032 -log record actions in logfile (default true)\n\
+ \032 -logfile xxx logfile name\n\
+ \032 -maxerrors n maximum number of errors before a directory transfer is\n\
+ \032 aborted\n\
+ \032 -maxsizethreshold n prevent transfer of files bigger than this (if >=0, in\n\
+ \032 Kb)\n\
+ \032 -maxthreads n maximum number of simultaneous file transfers\n\
+ \032 -mountpoint xxx abort if this path does not exist\n\
+ \032 -rootalias xxx register alias for canonical root names\n\
+ \032 -showarchive show 'true names' (for rootalias) of roots and archive\n\
+ \032 -source xxx include a file's preferences\n\
+ \032 -ui xxx select UI ('text' or 'graphic'); command-line only\n\
+ \032 -unicode xxx assume Unicode encoding in case insensitive mode\n\
+ \032 -watch when set, use a file watcher process to detect changes\n\
+ \n\
+ Expert options:\n\
+ \032 -debug xxx debug module xxx ('all' -> everything, 'verbose' -> more)\n\
+ \032 -dumparchives dump contents of archives just after loading\n\
+ \032 -fastercheckUNSAFE skip computing fingerprints for new files (experts only!)\n\
+ \032 -selftest run internal tests and exit\n\
\n\
\n\
\032 Here, in more detail, is what they do. Many are discussed in greater\n\
\032 detail in other sections of the manual.\n\
\n\
\032 It should be noted that some command-line arguments are handled\n\
- \032 specially during startup, including -doc, -help, -version, -server,\n\
- \032 -socket, and -ui. They are expected to appear on the command-line only,\n\
- \032 not in a profile. In particular, -version and -doc will print to the\n\
- \032 standard output, so they only make sense if invoked from the\n\
- \032 command-line (and not a click-launched gui that has no standard\n\
- \032 output). Furthermore, the actions associated with these command-line\n\
- \032 arguments are executed without loading a profile or doing the usual\n\
- \032 command-line parsing. This is because we want to run the actions\n\
- \032 without loading a profile; and then we can't do command-line parsing\n\
- \032 because it is intertwined with profile loading.\n\
+ \032 specially during startup, including -doc, -help, -version, -socket, and\n\
+ \032 -ui. They are expected to appear on the command-line only, not in a\n\
+ \032 profile. In particular, -version and -doc will print to the standard\n\
+ \032 output, so they only make sense if invoked from the command-line (and\n\
+ \032 not a click-launched gui that has no standard output). Furthermore, the\n\
+ \032 actions associated with these command-line arguments are executed\n\
+ \032 without loading a profile or doing the usual command-line parsing.\n\
+ \n\
+ \032 acl\n\
+ \032 When this flag is set to true, the ACLs of files and directories\n\
+ \032 are synchronized. The type of ACLs depends on the platform and\n\
+ \032 filesystem support. On Unix-like platforms it can be NFSv4 ACLs,\n\
+ \032 for example.\n\
\n\
\032 addprefsto xxx\n\
\032 By default, new preferences added by Unison (e.g., new ignore\n\
@@ -1280,7 +1343,7 @@ let docs =
\032 When this flag is set to true, Unison will use\n\
\032 unison-currentmajorversionnumber instead of just unison as the\n\
\032 remote server command (note that the minor version number is\n\
- \032 dropped - e.g., unison-2.51). This allows multiple binaries for\n\
+ \032 dropped \226\128\147 e.g., unison-2.51). This allows multiple binaries for\n\
\032 different versions of unison to coexist conveniently on the same\n\
\032 server: whichever version is run on the client, the same version\n\
\032 will be selected on the server.\n\
@@ -1310,20 +1373,20 @@ let docs =
\032 versions that are kept is determined by the maxbackups\n\
\032 preference.\n\
\n\
- \032 The syntax of pathspec is described in the section \"Path\n\
- \032 Specification\" .\n\
+ \032 The syntax of pathspec is described in the section \226\128\156Path\n\
+ \032 Specification\226\128\157 .\n\
\n\
\032 backupcurr xxx\n\
\032 Including the preference -backupcurr pathspec causes Unison to\n\
\032 keep a backup of the current version of every file matching\n\
\032 pathspec. This file will be saved as a backup with version\n\
\032 number 000. Such backups can be used as inputs to external\n\
- \032 merging programs, for instance. See the documentatation for the\n\
- \032 merge preference. For more details, see the section \"Merging\n\
- \032 Conflicting Versions\" .\n\
+ \032 merging programs, for instance. See the documentation for the\n\
+ \032 merge preference. For more details, see the section \226\128\156Merging\n\
+ \032 Conflicting Versions\226\128\157 .\n\
\n\
- \032 The syntax of pathspec is described in the section \"Path\n\
- \032 Specification\" .\n\
+ \032 The syntax of pathspec is described in the section \226\128\156Path\n\
+ \032 Specification\226\128\157 .\n\
\n\
\032 backupcurrnot xxx\n\
\032 Exceptions to backupcurr, like the ignorenot preference.\n\
@@ -1344,7 +1407,7 @@ let docs =
\032 backupnot xxx\n\
\032 The values of this preference specify paths or individual files\n\
\032 or regular expressions that should not be backed up, even if the\n\
- \032 backup preference selects them--i.e., it selectively overrides\n\
+ \032 backup preference selects them\226\128\148i.e., it selectively overrides\n\
\032 backup.\n\
\n\
\032 backupprefix xxx\n\
@@ -1353,7 +1416,7 @@ let docs =
\032 backupprefixNAMEbackupsuffix. backupprefix can include a\n\
\032 directory name (causing Unison to keep all backup files for a\n\
\032 given directory in a subdirectory with this name), and both\n\
- \032 backupprefix and backupsuffix can contain the string$VERSION,\n\
+ \032 backupprefix and backupsuffix can contain the string $VERSION,\n\
\032 which will be replaced by the age of the backup (1 for the most\n\
\032 recent, 2 for the second most recent, and so on...). This\n\
\032 keyword is ignored if it appears in a directory name in the\n\
@@ -1368,7 +1431,7 @@ let docs =
\032 sufficiently different from the names of your real files.\n\
\n\
\032 backups\n\
- \032 Setting this flag to true is equivalent to setting\n\
+ \032 (Deprecated) Setting this flag to true is equivalent to setting\n\
\032 backuplocation to local and backup to Name *.\n\
\n\
\032 backupsuffix xxx\n\
@@ -1380,9 +1443,8 @@ let docs =
\032 conflicts will be skipped.\n\
\n\
\032 clientHostName xxx\n\
- \032 When specified, the host name of the client will not be\n\
- \032 guessedand the provided host name will be used to find the\n\
- \032 archive.\n\
+ \032 When specified, the host name of the client will not be guessed\n\
+ \032 and the provided host name will be used to find the archive.\n\
\n\
\032 color xxx\n\
\032 When set to true, this flag enables color output in text mode\n\
@@ -1409,8 +1471,8 @@ let docs =
\032 Default is false.\n\
\n\
\032 contactquietly\n\
- \032 If this flag is set, Unison will skip displaying the `Contacting\n\
- \032 server' message (which some users find annoying) during startup.\n\
+ \032 If this flag is set, Unison will skip displaying the \226\128\152Contacting\n\
+ \032 server\226\128\153 message (which some users find annoying) during startup.\n\
\n\
\032 copymax n\n\
\032 A number indicating how many instances of the external copying\n\
@@ -1429,7 +1491,7 @@ let docs =
\032 A string giving the name of an external program that can be used\n\
\032 to copy large files efficiently (plus command-line switches\n\
\032 telling it to copy files in-place). The default setting invokes\n\
- \032 rsync with appropriate options--most users should not need to\n\
+ \032 rsync with appropriate options\226\128\148most users should not need to\n\
\032 change it.\n\
\n\
\032 copyprogrest xxx\n\
@@ -1438,24 +1500,15 @@ let docs =
\032 already been partially transferred. Typically, copyprogrest will\n\
\032 just be copyprog with one extra option (e.g., --partial, for\n\
\032 rsync). The default setting invokes rsync with appropriate\n\
- \032 options--most users should not need to change it.\n\
- \n\
- \032 copyquoterem xxx\n\
- \032 When set to true, this flag causes Unison to add an extra layer\n\
- \032 of quotes to the remote path passed to the external copy\n\
- \032 program. This is needed by rsync, for example, which internally\n\
- \032 uses an ssh connection requiring an extra level of quoting for\n\
- \032 paths containing spaces. When this flag is set to default, extra\n\
- \032 quotes are added if the value of copyprog contains the string\n\
- \032 rsync.\n\
+ \032 options\226\128\148most users should not need to change it.\n\
\n\
\032 copythreshold n\n\
\032 A number indicating above what filesize (in kilobytes) Unison\n\
\032 should use the external copying utility specified by copyprog.\n\
\032 Specifying 0 will cause all copies to use the external program;\n\
\032 a negative number will prevent any files from using it. The\n\
- \032 default is -1. See the section \"Making Unison Faster on Large\n\
- \032 Files\" for more information.\n\
+ \032 default is -1. See the section \226\128\156Making Unison Faster on Large\n\
+ \032 Files\226\128\157 for more information.\n\
\n\
\032 debug xxx\n\
\032 This preference is used to make Unison print various sorts of\n\
@@ -1474,7 +1527,7 @@ let docs =
\032 diff xxx\n\
\032 This preference can be used to control the name and command-line\n\
\032 arguments of the system utility used to generate displays of\n\
- \032 file differences. The default is `diff -u OLDER NEWER'. If the\n\
+ \032 file differences. The default is \226\128\152diff -u OLDER NEWER\226\128\153. If the\n\
\032 value of this preference contains the substrings CURRENT1 and\n\
\032 CURRENT2, these will be replaced by the names of the files to be\n\
\032 diffed. If the value of this preference contains the substrings\n\
@@ -1493,7 +1546,7 @@ let docs =
\032 of the various sections that can be printed.\n\
\n\
\032 dontchmod\n\
- \032 By default, Unison uses the 'chmod' system call to set the\n\
+ \032 By default, Unison uses the \226\128\153chmod\226\128\153 system call to set the\n\
\032 permission bits of files after it has copied them. But in some\n\
\032 circumstances (and under some operating systems), the chmod call\n\
\032 always fails. Setting this preference completely prevents Unison\n\
@@ -1502,7 +1555,7 @@ let docs =
\032 dumbtty\n\
\032 When set to true, this flag makes the text mode user interface\n\
\032 avoid trying to change any of the terminal settings. (Normally,\n\
- \032 Unison puts the terminal in `raw mode', so that it can do things\n\
+ \032 Unison puts the terminal in \226\128\152raw mode\226\128\153, so that it can do things\n\
\032 like overwriting the current line.) This is useful, for example,\n\
\032 when Unison runs in a shell inside of Emacs.\n\
\n\
@@ -1520,8 +1573,8 @@ let docs =
\n\
\032 fastcheck xxx\n\
\032 When this preference is set to true, Unison will use the\n\
- \032 modification time and length of a file as a `pseudo inode\n\
- \032 number' when scanning replicas for updates, instead of reading\n\
+ \032 modification time and length of a file as a \226\128\152pseudo inode\n\
+ \032 number\226\128\153 when scanning replicas for updates, instead of reading\n\
\032 the full contents of every file. (This does not apply to the\n\
\032 very first run, when Unison will always scan all files\n\
\032 regardless of this switch). Under Windows, this may cause Unison\n\
@@ -1534,7 +1587,7 @@ let docs =
\032 Unison once with fastcheck set to false, if you are worried that\n\
\032 Unison may have overlooked an update. For backward\n\
\032 compatibility, yes, no, and default can be used in place of\n\
- \032 true, false, and auto. See the section \"Fast Update Detection\"\n\
+ \032 true, false, and auto. See the section \226\128\156Fast Update Detection\226\128\157\n\
\032 for more information.\n\
\n\
\032 fastercheckUNSAFE\n\
@@ -1542,7 +1595,7 @@ let docs =
\032 EXTREME CAUTION.\n\
\n\
\032 When this flag is set to true, Unison will compute a\n\
- \032 'pseudo-fingerprint' the first time it sees a file (either\n\
+ \032 \226\128\153pseudo-fingerprint\226\128\153 the first time it sees a file (either\n\
\032 because the file is new or because Unison is running for the\n\
\032 first time). This enormously speeds update detection, but it\n\
\032 must be used with care, as it can cause Unison to miss\n\
@@ -1560,13 +1613,13 @@ let docs =
\032 has no record of the earlier contents) and show it as needing to\n\
\032 be propagated to the other replica.\n\
\n\
- \032 Most users should leave this flag off - the small time savings\n\
+ \032 Most users should leave this flag off \226\128\147 the small time savings\n\
\032 of not fingerprinting new files is not worth the cost in terms\n\
\032 of safety. However, it can be very useful for power users with\n\
\032 huge replicas that are known to be already synchronized (e.g.,\n\
\032 because one replica is a newly created duplicate of the other,\n\
\032 or because they have previously been synchronized with Unison\n\
- \032 but Unison's archives need to be rebuilt). In such situations,\n\
+ \032 but Unison\226\128\153s archives need to be rebuilt). In such situations,\n\
\032 it is recommended that this flag be set only for the initial run\n\
\032 of Unison, so that new archives can be created quickly, and then\n\
\032 turned off for normal use.\n\
@@ -1575,7 +1628,7 @@ let docs =
\032 When this is set to true, Unison will use appropriate options to\n\
\032 synchronize efficiently and without error a replica located on a\n\
\032 FAT filesystem on a non-Windows machine: do not synchronize\n\
- \032 permissions (perms = 0); never use chmod ( t dontchmod = true);\n\
+ \032 permissions (perms = 0); never use chmod (dontchmod = true);\n\
\032 treat filenames as case insensitive (ignorecase = true); do not\n\
\032 attempt to synchronize symbolic links (links = false); ignore\n\
\032 inode number changes when detecting updates (ignoreinodenumbers\n\
@@ -1584,11 +1637,11 @@ let docs =
\n\
\032 follow xxx\n\
\032 Including the preference -follow pathspec causes Unison to treat\n\
- \032 symbolic links matching pathspec as `invisible' and behave as if\n\
+ \032 symbolic links matching pathspec as \226\128\152invisible\226\128\153 and behave as if\n\
\032 the object pointed to by the link had appeared literally at this\n\
- \032 position in the replica. See the section \"Symbolic Links\" for\n\
+ \032 position in the replica. See the section \226\128\156Symbolic Links\226\128\157 for\n\
\032 more details. The syntax of pathspec is described in the section\n\
- \032 \"Path Specification\" .\n\
+ \032 \226\128\156Path Specification\226\128\157 .\n\
\n\
\032 force xxx\n\
\032 Including the preference -force root causes Unison to resolve\n\
@@ -1596,6 +1649,10 @@ let docs =
\032 This effectively changes Unison from a synchronizer into a\n\
\032 mirroring utility.\n\
\n\
+ \032 You can also specify a unique prefix or suffix of the path of\n\
+ \032 one of the roots or a unique prefix of the hostname of a remote\n\
+ \032 root.\n\
+ \n\
\032 You can also specify -force newer (or -force older) to force\n\
\032 Unison to choose the file with the later (earlier) modtime. In\n\
\032 this case, the -times preference must also be enabled.\n\
@@ -1609,12 +1666,16 @@ let docs =
\032 Including the preference forcepartial = PATHSPEC -> root causes\n\
\032 Unison to resolve all differences (even non-conflicting changes)\n\
\032 in favor of root for the files in PATHSPEC (see the section\n\
- \032 \"Path Specification\" for more information). This effectively\n\
+ \032 \226\128\156Path Specification\226\128\157 for more information). This effectively\n\
\032 changes Unison from a synchronizer into a mirroring utility.\n\
\n\
+ \032 You can also specify a unique prefix or suffix of the path of\n\
+ \032 one of the roots or a unique prefix of the hostname of a remote\n\
+ \032 root.\n\
+ \n\
\032 You can also specify forcepartial PATHSPEC -> newer (or\n\
- \032 forcepartial PATHSPEC older) to force Unison to choose the file\n\
- \032 with the later (earlier) modtime. In this case, the -times\n\
+ \032 forcepartial PATHSPEC -> older) to force Unison to choose the\n\
+ \032 file with the later (earlier) modtime. In this case, the -times\n\
\032 preference must also be enabled.\n\
\n\
\032 This preference should be used only if you are sure you know\n\
@@ -1626,13 +1687,10 @@ let docs =
\032 identifiers are synchronized depends on the preference numerids.\n\
\n\
\032 halfduplex\n\
- \032 When this flag is set to true, Unison network communication is\n\
- \032 forced to be half duplex (the client and the server never\n\
- \032 simultaneously emit data). If you experience unstabilities with\n\
- \032 your network link, this may help. The communication is always\n\
- \032 half-duplex when synchronizing with a Windows machine due to a\n\
- \032 limitation of Unison current implementation that could result in\n\
- \032 a deadlock.\n\
+ \032 (Deprecated) When this flag is set to true, Unison network\n\
+ \032 communication is forced to be half duplex (the client and the\n\
+ \032 server never simultaneously emit data). If you experience\n\
+ \032 unstabilities with your network link, this may help.\n\
\n\
\032 height n\n\
\032 Used to set the height (in lines) of the main window in the\n\
@@ -1650,8 +1708,8 @@ let docs =
\032 completely ignore paths that match pathspec (as well as their\n\
\032 children). This is useful for avoiding synchronizing temporary\n\
\032 files, object files, etc. The syntax of pathspec is described in\n\
- \032 the section \"Path Specification\" , and further details on\n\
- \032 ignoring paths is found in the section \"Ignoring Paths\" .\n\
+ \032 the section \226\128\156Path Specification\226\128\157 , and further details on\n\
+ \032 ignoring paths is found in the section \226\128\156Ignoring Paths\226\128\157 .\n\
\n\
\032 ignorearchives\n\
\032 When this preference is set, Unison will ignore any existing\n\
@@ -1661,8 +1719,8 @@ let docs =
\n\
\032 ignorecase xxx\n\
\032 When set to true, this flag causes Unison to treat filenames as\n\
- \032 case insensitive--i.e., files in the two replicas whose names\n\
- \032 differ in (upper- and lower-case) `spelling' are treated as the\n\
+ \032 case insensitive\226\128\148i.e., files in the two replicas whose names\n\
+ \032 differ in (upper- and lower-case) \226\128\152spelling\226\128\153 are treated as the\n\
\032 same file. When the flag is set to false, Unison will treat all\n\
\032 filenames as case sensitive. Ordinarily, when the flag is set to\n\
\032 default, filenames are automatically taken to be\n\
@@ -1710,7 +1768,7 @@ let docs =
\n\
\032 immutable xxx\n\
\032 This preference specifies paths for directories whose immediate\n\
- \032 children are all immutable files -- i.e., once a file has been\n\
+ \032 children are all immutable files \226\128\148 i.e., once a file has been\n\
\032 created, its contents never changes. When scanning for updates,\n\
\032 Unison does not check whether these files have been modified;\n\
\032 this can speed update detection significantly (in particular,\n\
@@ -1719,6 +1777,12 @@ let docs =
\032 immutablenot xxx\n\
\032 This preference overrides immutable.\n\
\n\
+ \032 include xxx\n\
+ \032 Include preferences from a profile. include name reads the\n\
+ \032 profile \"name\" (or file \"name\" in the .unison directory if\n\
+ \032 profile \"name\" does not exist) and includes its contents as if\n\
+ \032 it was part of a profile or given directly on command line.\n\
+ \n\
\032 key xxx\n\
\032 Used in a profile to define a numeric key (0-9) that can be used\n\
\032 in the user interface to switch immediately to this profile.\n\
@@ -1736,18 +1800,27 @@ let docs =
\032 label xxx\n\
\032 Used in a profile to provide a descriptive string documenting\n\
\032 its settings. (This is useful for users that switch between\n\
- \032 several profiles, especially using the `fast switch' feature of\n\
+ \032 several profiles, especially using the \226\128\152fast switch\226\128\153 feature of\n\
\032 the graphical user interface.)\n\
\n\
\032 links xxx\n\
\032 When set to true, this flag causes Unison to synchronize\n\
\032 symbolic links. When the flag is set to false, symbolic links\n\
- \032 will result in an error during update detection. Ordinarily,\n\
- \032 when the flag is set to default, symbolic links are synchronized\n\
- \032 except when one of the hosts is running Windows. On a Windows\n\
- \032 client, Unison makes an attempt to detect if symbolic links are\n\
+ \032 will be ignored during update detection. Ordinarily, when the\n\
+ \032 flag is set to default, symbolic links are synchronized except\n\
+ \032 when one of the hosts is running Windows. On a Windows client,\n\
+ \032 Unison makes an attempt to detect if symbolic links are\n\
\032 supported and allowed by user privileges. You may have to get\n\
- \032 elevated privileges to create symbolic links.\n\
+ \032 elevated privileges to create symbolic links. When the flag is\n\
+ \032 set to default and symbolic links can\226\128\153t be synchronized then an\n\
+ \032 error is produced during update detection.\n\
+ \n\
+ \032 listen xxx\n\
+ \032 When acting as a server on a TCP socket, Unison will by default\n\
+ \032 listen on \"any\" address (0.0.0.0 and [::]). This command-line\n\
+ \032 argument allows to specify a different listening address and can\n\
+ \032 be repeated to listen on multiple addresses. Listening address\n\
+ \032 can be specified as a host name or an IP address.\n\
\n\
\032 log\n\
\032 When this flag is set, Unison will log all changes to the\n\
@@ -1786,37 +1859,41 @@ let docs =
\032 the transport phase. Normally, it should be set reasonably high\n\
\032 to maximize performance, but when Unison is used over a\n\
\032 low-bandwidth link it may be helpful to set it lower (e.g. to 1)\n\
- \032 so that Unison doesn't soak up all the available bandwidth. The\n\
+ \032 so that Unison doesn\226\128\153t soak up all the available bandwidth. The\n\
\032 default is the special value 0, which mean 20 threads when file\n\
- \032 content streaming is desactivated and 1000 threads when it is\n\
+ \032 content streaming is deactivated and 1000 threads when it is\n\
\032 activated.\n\
\n\
\032 merge xxx\n\
\032 This preference can be used to run a merge program which will\n\
\032 create a new version for each of the files and the backup, with\n\
\032 the last backup and both replicas. The syntax of pathspec -> cmd\n\
- \032 is described in the section \"Path Specification\" , and further\n\
- \032 details on Merging functions are present in the section \"Merging\n\
- \032 Conflicting Versions\" .\n\
+ \032 is described in the section \226\128\156Path Specification\226\128\157 , and further\n\
+ \032 details on Merging functions are present in the section \226\128\156Merging\n\
+ \032 Conflicting Versions\226\128\157 .\n\
\n\
\032 mountpoint xxx\n\
\032 Including the preference -mountpoint PATH causes Unison to\n\
\032 double-check, at the end of update detection, that PATH exists\n\
\032 and abort if it does not. This is useful when Unison is used to\n\
\032 synchronize removable media. This preference can be given more\n\
- \032 than once. See the section \"Mount Points and Removable Media\" .\n\
+ \032 than once. See the section \226\128\156Mount Points and Removable Media\226\128\157 .\n\
\n\
\032 nocreation xxx\n\
\032 Including the preference -nocreation root prevents Unison from\n\
\032 performing any file creation on root root.\n\
\n\
+ \032 You can also specify a unique prefix or suffix of the path of\n\
+ \032 one of the roots or a unique prefix of the hostname of a remote\n\
+ \032 root.\n\
+ \n\
\032 This preference can be included twice, once for each root, if\n\
\032 you want to prevent any creation.\n\
\n\
\032 nocreationpartial xxx\n\
\032 Including the preference nocreationpartial = PATHSPEC -> root\n\
\032 prevents Unison from performing any file creation in PATHSPEC on\n\
- \032 root root (see the section \"Path Specification\" for more\n\
+ \032 root root (see the section \226\128\156Path Specification\226\128\157 for more\n\
\032 information). It is recommended to use BelowPath patterns when\n\
\032 selecting a directory and all its contents.\n\
\n\
@@ -1824,13 +1901,17 @@ let docs =
\032 Including the preference -nodeletion root prevents Unison from\n\
\032 performing any file deletion on root root.\n\
\n\
+ \032 You can also specify a unique prefix or suffix of the path of\n\
+ \032 one of the roots or a unique prefix of the hostname of a remote\n\
+ \032 root.\n\
+ \n\
\032 This preference can be included twice, once for each root, if\n\
\032 you want to prevent any deletion.\n\
\n\
\032 nodeletionpartial xxx\n\
\032 Including the preference nodeletionpartial = PATHSPEC -> root\n\
\032 prevents Unison from performing any file deletion in PATHSPEC on\n\
- \032 root root (see the section \"Path Specification\" for more\n\
+ \032 root root (see the section \226\128\156Path Specification\226\128\157 for more\n\
\032 information). It is recommended to use BelowPath patterns when\n\
\032 selecting a directory and all its contents.\n\
\n\
@@ -1838,13 +1919,17 @@ let docs =
\032 Including the preference -noupdate root prevents Unison from\n\
\032 performing any file update or deletion on root root.\n\
\n\
+ \032 You can also specify a unique prefix or suffix of the path of\n\
+ \032 one of the roots or a unique prefix of the hostname of a remote\n\
+ \032 root.\n\
+ \n\
\032 This preference can be included twice, once for each root, if\n\
\032 you want to prevent any update.\n\
\n\
\032 noupdatepartial xxx\n\
\032 Including the preference noupdatepartial = PATHSPEC -> root\n\
\032 prevents Unison from performing any file update or deletion in\n\
- \032 PATHSPEC on root root (see the section \"Path Specification\" for\n\
+ \032 PATHSPEC on root root (see the section \226\128\156Path Specification\226\128\157 for\n\
\032 more information). It is recommended to use BelowPath patterns\n\
\032 when selecting a directory and all its contents.\n\
\n\
@@ -1866,20 +1951,20 @@ let docs =
\032 If one or more path preferences are given, then Unison will\n\
\032 synchronize only these paths and their children. (This is useful\n\
\032 for doing a fast sync of just one directory, for example.) Note\n\
- \032 that path preferences are interpreted literally--they are not\n\
+ \032 that path preferences are interpreted literally\226\128\148they are not\n\
\032 regular expressions.\n\
\n\
\032 perms n\n\
\032 The integer value of this preference is a mask indicating which\n\
\032 permission bits should be synchronized. It is set by default to\n\
\032 0o1777: all bits but the set-uid and set-gid bits are\n\
- \032 synchronised (synchronizing theses latter bits can be a security\n\
+ \032 synchronised (synchronizing these latter bits can be a security\n\
\032 hazard). If you want to synchronize all bits, you can set the\n\
- \032 value of this preference to -1. If one of the replica is on a\n\
- \032 FAT [Windows] filesystem, you should consider using the t fat\n\
+ \032 value of this preference to \226\136\1461. If one of the replica is on a\n\
+ \032 FAT [Windows] filesystem, you should consider using the fat\n\
\032 preference instead of this preference. If you need Unison not to\n\
\032 set permissions at all, set the value of this preference to 0\n\
- \032 and set the preference t dontchmod to t true.\n\
+ \032 and set the preference dontchmod to true.\n\
\n\
\032 prefer xxx\n\
\032 Including the preference -prefer root causes Unison always to\n\
@@ -1888,6 +1973,10 @@ let docs =
\032 preference merge. (The syntax of root is the same as for the\n\
\032 root preference, plus the special values newer and older.)\n\
\n\
+ \032 You can also specify a unique prefix or suffix of the path of\n\
+ \032 one of the roots or a unique prefix of the hostname of a remote\n\
+ \032 root.\n\
+ \n\
\032 This preference is overridden by the preferpartial preference.\n\
\n\
\032 This preference should be used only if you are sure you know\n\
@@ -1897,10 +1986,14 @@ let docs =
\032 Including the preference preferpartial = PATHSPEC -> root causes\n\
\032 Unison always to resolve conflicts in favor of root, rather than\n\
\032 asking for guidance from the user, for the files in PATHSPEC\n\
- \032 (see the section \"Path Specification\" for more information).\n\
+ \032 (see the section \226\128\156Path Specification\226\128\157 for more information).\n\
\032 (The syntax of root is the same as for the root preference, plus\n\
\032 the special values newer and older.)\n\
\n\
+ \032 You can also specify a unique prefix or suffix of the path of\n\
+ \032 one of the roots or a unique prefix of the hostname of a remote\n\
+ \032 root.\n\
+ \n\
\032 This preference should be used only if you are sure you know\n\
\032 what you are doing!\n\
\n\
@@ -1910,7 +2003,11 @@ let docs =
\032 stopping. If the argument is a number, Unison will pause for\n\
\032 that many seconds before beginning again. When the argument is\n\
\032 watch, Unison relies on an external file monitoring process to\n\
- \032 synchronize whenever a change happens.\n\
+ \032 synchronize whenever a change happens. You can combine the two\n\
+ \032 with a + character to use file monitoring and also do a full\n\
+ \032 scan every specificed number of seconds. For example, watch+3600\n\
+ \032 will react to changes immediately and additionally do a full\n\
+ \032 scan every hour.\n\
\n\
\032 retry n\n\
\032 Setting this preference causes the text-mode interface to try\n\
@@ -1923,11 +2020,11 @@ let docs =
\032 needed, so normal modes of usage are either to give two values\n\
\032 for root in the profile, or to give no values in the profile and\n\
\032 provide two on the command line. Details of the syntax of roots\n\
- \032 can be found in the section \"Roots\" .\n\
+ \032 can be found in the section \226\128\156Roots\226\128\157 .\n\
\n\
\032 The two roots can be given in either order; Unison will sort\n\
\032 them into a canonical order before doing anything else. It also\n\
- \032 tries to `canonize' the machine names and paths that appear in\n\
+ \032 tries to \226\128\152canonize\226\128\153 the machine names and paths that appear in\n\
\032 the roots, so that, if Unison is invoked later with a slightly\n\
\032 different name for the same root, it will be able to locate the\n\
\032 correct archives.\n\
@@ -1937,16 +2034,6 @@ let docs =
\032 of roots, Unison replaces any roots matching the left-hand side\n\
\032 of any rootalias rule by the corresponding right-hand side.\n\
\n\
- \032 rshargs xxx\n\
- \032 The string value of this preference will be passed as additional\n\
- \032 arguments (besides the host name and the name of the Unison\n\
- \032 executable on the remote system) to the rsh command used to\n\
- \032 invoke the remote server. The backslash is an escape character.\n\
- \n\
- \032 rshcmd xxx\n\
- \032 This preference can be used to explicitly set the name of the\n\
- \032 rsh executable (e.g., giving a full path name), if necessary.\n\
- \n\
\032 rsrc xxx\n\
\032 When set to true, this flag causes Unison to synchronize\n\
\032 resource forks and HFS meta-data. On filesystems that do not\n\
@@ -1958,11 +2045,11 @@ let docs =
\032 circumstances it is useful to set the flag manually.\n\
\n\
\032 rsync\n\
- \032 Unison uses the 'rsync algorithm' for 'diffs-only' transfer of\n\
+ \032 Unison uses the \226\128\153rsync algorithm\226\128\153 for \226\128\153diffs-only\226\128\153 transfer of\n\
\032 updates to large files. Setting this flag to false makes Unison\n\
\032 use whole-file transfers instead. Under normal circumstances,\n\
\032 there is no reason to do this, but if you are having trouble\n\
- \032 with repeated 'rsync failure' errors, setting it to false should\n\
+ \032 with repeated \226\128\153rsync failure\226\128\153 errors, setting it to false should\n\
\032 permit you to synchronize the offending files.\n\
\n\
\032 selftest\n\
@@ -1985,15 +2072,20 @@ let docs =
\032 name), if necessary.\n\
\n\
\032 showarchive\n\
- \032 When this preference is set, Unison will print out the 'true\n\
- \032 names'of the roots, in the same form as is expected by the\n\
- \032 rootaliaspreference.\n\
+ \032 When this preference is set, Unison will print out the \226\128\153true\n\
+ \032 names\226\128\153of the roots, in the same form as is expected by the\n\
+ \032 rootalias preference.\n\
\n\
\032 silent\n\
\032 When this preference is set to true, the textual user interface\n\
\032 will print nothing at all, except in the case of errors. Setting\n\
\032 silent to true automatically sets the batch preference to true.\n\
\n\
+ \032 socket xxx\n\
+ \032 Start unison as a server listening on a TCP socket (with TCP\n\
+ \032 port number as argument) or a local socket (aka Unix domain\n\
+ \032 socket) (with socket path as argument).\n\
+ \n\
\032 sortbysize\n\
\032 When this flag is set, the user interface will list changed\n\
\032 files by size (smallest first) rather than by name. This is\n\
@@ -2003,14 +2095,14 @@ let docs =
\n\
\032 This preference (as well as the other sorting flags, but not the\n\
\032 sorting preferences that require patterns as arguments) can be\n\
- \032 set interactively and temporarily using the 'Sort' menu in the\n\
+ \032 set interactively and temporarily using the \226\128\153Sort\226\128\153 menu in the\n\
\032 graphical and text user interfaces.\n\
\n\
\032 sortfirst xxx\n\
\032 Each argument to sortfirst is a pattern pathspec, which\n\
\032 describes a set of paths. Files matching any of these patterns\n\
\032 will be listed first in the user interface. The syntax of\n\
- \032 pathspec is described in the section \"Path Specification\" .\n\
+ \032 pathspec is described in the section \226\128\156Path Specification\226\128\157 .\n\
\n\
\032 sortlast xxx\n\
\032 Similar to sortfirst, except that files matching one of these\n\
@@ -2019,9 +2111,14 @@ let docs =
\032 sortnewfirst\n\
\032 When this flag is set, the user interface will list newly\n\
\032 created files before all others. This is useful, for example,\n\
- \032 for checking that newly created files are not `junk', i.e., ones\n\
+ \032 for checking that newly created files are not \226\128\152junk\226\128\153, i.e., ones\n\
\032 that should be ignored or deleted rather than synchronized.\n\
\n\
+ \032 source xxx\n\
+ \032 Include preferences from a file. source name reads the file\n\
+ \032 \"name\" in the .unison directory and includes its contents as if\n\
+ \032 it was part of a profile or given directly on command line.\n\
+ \n\
\032 sshargs xxx\n\
\032 The string value of this preference will be passed as additional\n\
\032 arguments (besides the host name and the name of the Unison\n\
@@ -2032,18 +2129,10 @@ let docs =
\032 This preference can be used to explicitly set the name of the\n\
\032 ssh executable (e.g., giving a full path name), if necessary.\n\
\n\
- \032 sshversion xxx\n\
- \032 This preference can be used to control which version of ssh\n\
- \032 should be used to connect to the server. Legal values are 1 and\n\
- \032 2, which will cause unison to try to use ssh1 orssh2 instead of\n\
- \032 just ssh to invoke ssh. The default value is empty, which will\n\
- \032 make unison use whatever version of ssh is installed as the\n\
- \032 default `ssh' command.\n\
- \n\
\032 stream\n\
- \032 When this preference is set, Unison will use an experimental\n\
- \032 streaming protocol for transferring file contents more\n\
- \032 efficiently. The default value is true.\n\
+ \032 (Deprecated) When this preference is set, Unison will use an\n\
+ \032 experimental streaming protocol for transferring file contents\n\
+ \032 more efficiently. The default value is true.\n\
\n\
\032 terse\n\
\032 When this preference is set to true, the user interface will not\n\
@@ -2063,7 +2152,7 @@ let docs =
\032 This preference selects either the graphical or the textual user\n\
\032 interface. Legal values are graphic or text.\n\
\n\
- \032 Because this option is processed specially during Unison's\n\
+ \032 Because this option is processed specially during Unison\226\128\153s\n\
\032 start-up sequence, it can only be used on the command line. In\n\
\032 preference files it has no effect.\n\
\n\
@@ -2074,13 +2163,13 @@ let docs =
\032 unicode xxx\n\
\032 When set to true, this flag causes Unison to perform case\n\
\032 insensitive file comparisons assuming Unicode encoding. This is\n\
- \032 the default. When the flag is set to false, a Latin 1 encoding\n\
- \032 is assumed. When Unison runs in case sensitive mode, this flag\n\
- \032 only makes a difference if one host is running Windows or Mac OS\n\
- \032 X. Under Windows, the flag selects between using the Unicode or\n\
- \032 8bit Windows API for accessing the filesystem. Under Mac OS X,\n\
- \032 it selects whether comparing the filenames up to decomposition,\n\
- \032 or byte-for-byte.\n\
+ \032 the default. When the flag is set to false, Latin 1 encoding is\n\
+ \032 assumed (this means that all bytes that are not letters in Latin\n\
+ \032 1 encoding will be compared byte-for-byte, even if they may be\n\
+ \032 valid characters in some other encoding). When Unison runs in\n\
+ \032 case sensitive mode, this flag only makes a difference if one\n\
+ \032 host is running Mac OS X. Under Mac OS X, it selects whether\n\
+ \032 comparing the filenames up to decomposition, or byte-for-byte.\n\
\n\
\032 version\n\
\032 Print the current version number and exit. (This option only\n\
@@ -2091,12 +2180,57 @@ let docs =
\032 filesystem changes; this is used to speed up update detection.\n\
\032 Setting this flag to false disables the use of this process.\n\
\n\
+ \032 xattrignore xxx\n\
+ \032 Preference -xattrignore namespec causes Unison to ignore\n\
+ \032 extended attributes with names that match namespec. This can be\n\
+ \032 used to exclude extended attributes that would fail\n\
+ \032 synchronization due to lack of permissions or technical\n\
+ \032 differences at replicas. The syntax of namespec is the same as\n\
+ \032 used for path specification (described in the section \226\128\156Path\n\
+ \032 Specification\226\128\157 ); prefer the Path and Regex forms over the Name\n\
+ \032 form. The pattern is applied to the name of extended attribute,\n\
+ \032 not to path. On Linux, attributes in the security and trusted\n\
+ \032 namespaces are ignored by default (this is achieved by pattern\n\
+ \032 Regex !(security|trusted)[.].*); also attributes used to store\n\
+ \032 POSIX ACL are ignored by default (this is achieved by pattern\n\
+ \032 Path !system.posix_acl_*). To sync attributes in one or both of\n\
+ \032 these namespaces, see the xattrignorenot preference. Note that\n\
+ \032 the namespace name must be prefixed with a \"!\" (applies on Linux\n\
+ \032 only). All names not prefixed with a \"!\" are taken as strictly\n\
+ \032 belonging to the user namespace and therefore the \"!user.\"\n\
+ \032 prefix is never used.\n\
+ \n\
+ \032 xattrignorenot xxx\n\
+ \032 This preference overrides the preference xattrignore. It gives a\n\
+ \032 list of patterns (in the same format as xattrignore) for\n\
+ \032 extended attributes that should not be ignored, whether or not\n\
+ \032 they happen to match one of the xattrignore patterns. It is\n\
+ \032 possible to synchronize only desired attributes by ignoring all\n\
+ \032 attributes (for example, by setting xattrignore to Path * and\n\
+ \032 then adding xattrignorenot for extended attributes that should\n\
+ \032 be synchronized. On Linux, attributes in the security and\n\
+ \032 trusted namespaces are ignored by default. To sync attributes in\n\
+ \032 one or both of these namespaces, you may add an xattrignorenot\n\
+ \032 pattern like Path !security.* to sync all attributes in the\n\
+ \032 security namespace, or Path !security.selinux to sync a specific\n\
+ \032 attribute in an otherwise ignored namespace. A pattern like Path\n\
+ \032 !system.posix_acl_* can be used to sync POSIX ACLs on Linux.\n\
+ \032 Note that the namespace name must be prefixed with a \"!\"\n\
+ \032 (applies on Linux only). All names not prefixed with a \"!\" are\n\
+ \032 taken as strictly belonging to the user namespace and therefore\n\
+ \032 the \"!user.\" prefix is never used.\n\
+ \n\
+ \032 xattrs\n\
+ \032 When this flag is set to true, the extended attributes of files\n\
+ \032 and directories are synchronized. System extended attributes are\n\
+ \032 not synchronized.\n\
+ \n\
\032 xferbycopying\n\
\032 When this preference is set, Unison will try to avoid\n\
\032 transferring file contents across the network by recognizing\n\
\032 when a file with the required contents already exists in the\n\
\032 target replica. This usually allows file moves to be propagated\n\
- \032 very quickly. The default value istrue.\n\
+ \032 very quickly. The default value is true.\n\
\n\
Profiles\n\
\n\
@@ -2121,8 +2255,14 @@ let docs =
\n\
\032 for a preference of any other type.\n\
\n\
- \032 Whitespaces around p and xxx are ignored. A profile may also include\n\
- \032 blank lines and lines beginning with #; both are ignored.\n\
+ \032 A profile may include blank lines and lines beginning with #; both are\n\
+ \032 ignored.\n\
+ \n\
+ \032 Spaces and tabs before and after p and xxx are ignored. Spaces, tabs,\n\
+ \032 and non-printable characters within values are not treated specially,\n\
+ \032 so that e.g. root = /foo bar refers to a directory containing a space.\n\
+ \032 (On systems using newline for line ending, carriage returns are\n\
+ \032 currently ignored, but this is not part of the specification.)\n\
\n\
\032 When Unison starts, it first reads the profile and then the command\n\
\032 line, so command-line options will override settings from the profile.\n\
@@ -2135,10 +2275,10 @@ let docs =
\032 similar line of the form source name does the same except that it does\n\
\032 not attempt to add a suffix to name. Similar lines of the form include?\n\
\032 name or source? name do the same as their respective lines without the\n\
- \032 question mark except that it does not constitue an error to specify a\n\
+ \032 question mark except that it does not constitute an error to specify a\n\
\032 non-existing file name. In name the backslash is an escape character.\n\
\n\
- \032 A profile may include a preference `label = desc' to provide a\n\
+ \032 A profile may include a preference \226\128\152label = desc\226\128\153 to provide a\n\
\032 description of the options selected in this profile. The string desc is\n\
\032 listed along with the profile name in the profile selection dialog, and\n\
\032 displayed in the top-right corner of the main Unison window in the\n\
@@ -2146,7 +2286,7 @@ let docs =
\n\
\032 The graphical user-interface also supports one-key shortcuts for\n\
\032 commonly used profiles. If a profile contains a preference of the form\n\
- \032 `key = n', where n is a single digit, then pressing this digit key will\n\
+ \032 \226\128\152key = n\226\128\153, where n is a single digit, then pressing this digit key will\n\
\032 cause Unison to immediately switch to this profile and begin\n\
\032 synchronization again from scratch. In this case, all actions that have\n\
\032 been selected for a set of changes currently being displayed will be\n\
@@ -2209,8 +2349,8 @@ let docs =
\032 When Unison is used with large replicas, it is often convenient to be\n\
\032 able to synchronize just a part of the replicas on a given run (this\n\
\032 saves the time of detecting updates in the other parts). This can be\n\
- \032 accomplished by splitting up the profile into several parts -- a common\n\
- \032 part containing most of the preference settings, plus one \"top-level\"\n\
+ \032 accomplished by splitting up the profile into several parts \226\128\148 a common\n\
+ \032 part containing most of the preference settings, plus one \226\128\156top-level\226\128\157\n\
\032 file for each set of paths that need to be synchronized. (The include\n\
\032 mechanism can also be used to allow the same set of preference settings\n\
\032 to be used with different roots.)\n\
@@ -2245,14 +2385,14 @@ let docs =
\032 ignore = Name *.tmp\n\
\n\
\032 Note that there are no path preferences in common. This means that,\n\
- \032 when we invoke Unison with the default profile (e.g., by typing 'unison\n\
- \032 default' or just 'unison' on the command line), the whole replicas will\n\
+ \032 when we invoke Unison with the default profile (e.g., by typing \226\128\153unison\n\
+ \032 default\226\128\153 or just \226\128\153unison\226\128\153 on the command line), the whole replicas will\n\
\032 be synchronized. (If we never want to synchronize the whole replicas,\n\
\032 then default.prf would instead include settings for all the paths that\n\
\032 are usually synchronized.)\n\
\n\
\032 To synchronize just part of the replicas, Unison is invoked with an\n\
- \032 alternate preference file--e.g., doing 'unison workingset', where the\n\
+ \032 alternate preference file\226\128\148e.g., doing \226\128\153unison workingset\226\128\153, where the\n\
\032 preference file workingset.prf contains\n\
\032 path = current/papers\n\
\032 path = Mail/inbox\n\
@@ -2288,7 +2428,7 @@ let docs =
\032 example,\n\
\032 backup = Name *\n\
\n\
- \032 causes Unison to keep backups of all files and directories. The\n\
+ \032 causes Unison to create backups of all files and directories. The\n\
\032 backupnot preference can be used to give a few exceptions: it specifies\n\
\032 which files and directories should not be backed up, even if they match\n\
\032 the backup pathspec.\n\
@@ -2304,7 +2444,10 @@ let docs =
\n\
\032 Backup files can be stored either centrally or locally. This behavior\n\
\032 is controlled by the preference backuplocation, whose value must be\n\
- \032 either central or local. (The default is central.)\n\
+ \032 either central or local. (The default is central.) Note that central\n\
+ \032 storage of backups can lead to backup files being stored in a different\n\
+ \032 filesystem than the original files, which could have different security\n\
+ \032 properties and different amounts of available storage.\n\
\n\
\032 When backups are stored locally, they are kept in the same directory as\n\
\032 the original.\n\
@@ -2313,10 +2456,12 @@ let docs =
\032 controlled by the preference backupdir and the environment variable\n\
\032 UNISONBACKUPDIR. (The environment variable is checked first.) If\n\
\032 neither of these are set, then the directory .unison/backup in the\n\
- \032 user's home directory is used.\n\
+ \032 user\226\128\153s home directory is used.\n\
\n\
- \032 The preference maxbackups controls how many previous versions of each\n\
- \032 file are kept (including the current version).\n\
+ \032 The preference maxbackups (default 2) controls how many previous\n\
+ \032 versions of each file are kept (including the current version),\n\
+ \032 following the usual plan of deleting the oldest when creating a new\n\
+ \032 one.\n\
\n\
\032 By default, backup files are named .bak.VERSION.FILENAME, where\n\
\032 FILENAME is the original filename and VERSION is the backup number (1\n\
@@ -2335,6 +2480,9 @@ let docs =
\032 This can be used, for example, to ensure that backup files retain the\n\
\032 same extension as the originals.\n\
\n\
+ \032 Other than maxbackups (which will never delete the last backup), there\n\
+ \032 are no other mechanisms for deleting backups.\n\
+ \n\
\032 For backward compatibility, the backups preference is also supported.\n\
\032 It simply means backup = Name * and backuplocation = local.\n\
\n\
@@ -2350,8 +2498,8 @@ let docs =
\032 merge = <PATHSPEC> -> <MERGECMD>\n\
\n\
\032 The <PATHSPEC> here has exactly the same format as for the ignore\n\
- \032 preference (see the section \"Path Specification\" ). For example, using\n\
- \032 \"Name *.txt\" as the <PATHSPEC> tells Unison that this command should be\n\
+ \032 preference (see the section \226\128\156Path Specification\226\128\157 ). For example, using\n\
+ \032 \226\128\156Name *.txt\226\128\157 as the <PATHSPEC> tells Unison that this command should be\n\
\032 used whenever a file with extension .txt needs to be merged.\n\
\n\
\032 Many external merging programs require as inputs not just the two files\n\
@@ -2359,14 +2507,16 @@ let docs =
\032 synchronized version. You can ask Unison to keep a copy of the last\n\
\032 synchronized version for some files using the backupcurrent preference.\n\
\032 This preference is used in exactly the same way as backup and its\n\
- \032 meaning is similar, except that it causes backups to be kept of the\n\
+ \032 meaning is similar, except that it causes backups to be created of the\n\
\032 current contents of each file after it has been synchronized by Unison,\n\
\032 rather than the previous contents that Unison overwrote. These backups\n\
- \032 are kept on both replicas in the same place as ordinary backup\n\
- \032 files--i.e. according to the backuplocation and backupdir preferences.\n\
+ \032 are stored in both replicas in the same place as ordinary backup\n\
+ \032 files\226\128\148i.e. according to the backuplocation and backupdir preferences.\n\
\032 They are named like the original files if backupslocation is set to\n\
- \032 'central' and otherwise, Unison uses the backupprefix and backupsuffix\n\
- \032 preferences and assumes a version number 000 for these backups.\n\
+ \032 \226\128\153central\226\128\153 and otherwise, Unison uses the backupprefix and backupsuffix\n\
+ \032 preferences and assumes a version number 000 for these backups. Note\n\
+ \032 that there are no mechanisms (beyond the limit on the number of backups\n\
+ \032 for each file) to remove backup files.\n\
\n\
\032 The <MERGECMD> part of the preference specifies what external command\n\
\032 should be invoked to merge files at paths matching the <PATHSPEC>.\n\
@@ -2397,11 +2547,11 @@ let docs =
\032 Unison expects to be written by the merge program when it is only\n\
\032 able to partially merge the originals; in this case, NEW1 will be\n\
\032 written back to the local replica and NEW2 to the remote replica;\n\
- \032 NEWARCH, if present, will be used as the \"last common state\" of the\n\
+ \032 NEWARCH, if present, will be used as the \226\128\156last common state\226\128\157 of the\n\
\032 replicas. (These three options are provided for later compatibility\n\
\032 with the Harmony data synchronizer.)\n\
\032 * BATCHMODE is replaced according to the batch mode of Unison; if it\n\
- \032 is in batch mode, then a non empty string (\"batch\") is substituted,\n\
+ \032 is in batch mode, then a non empty string (\226\128\156batch\226\128\157) is substituted,\n\
\032 otherwise the empty string is substituted.\n\
\n\
\032 To accommodate the wide variety of programs that users might want to\n\
@@ -2435,7 +2585,7 @@ let docs =
\032 merge command only synchronizes some specific contents between two\n\
\032 files, skipping some irrelevant information (order between entries,\n\
\032 for instance). We assume that, if the merge command exits normally,\n\
- \032 then the two resulting files are \"as good as equal.\" (The reason we\n\
+ \032 then the two resulting files are \226\128\156as good as equal.\226\128\157 (The reason we\n\
\032 copy one on top of the other is to avoid Unison detecting that the\n\
\032 files are unequal the next time it is run and trying again to merge\n\
\032 them when, in fact, the merge program has already made them as\n\
@@ -2500,7 +2650,7 @@ let docs =
\032 preference instead of merge.\n\
\n\
\032 Please post suggestions for other useful values of the merge\n\
- \032 preference to the unison-users mailing list--we'd like to give\n\
+ \032 preference to the unison-users mailing list\226\128\148we\226\128\153d like to give\n\
\032 several examples here.\n\
\n\
The User Interface\n\
@@ -2508,15 +2658,51 @@ let docs =
\032 Both the textual and the graphical user interfaces are intended to be\n\
\032 mostly self-explanatory. Here are just a few tricks:\n\
\032 * By default, when running on Unix the textual user interface will\n\
- \032 try to put the terminal into the \"raw mode\" so that it reads the\n\
+ \032 try to put the terminal into the \226\128\156raw mode\226\128\157 so that it reads the\n\
\032 input a character at a time rather than a line at a time. (This\n\
- \032 means you can type just the single keystroke \">\" to tell Unison to\n\
- \032 propagate a file from left to right, rather than \"> Enter.\")\n\
- \032 There are some situations, though, where this will not work -- for\n\
+ \032 means you can type just the single keystroke \226\128\156>\226\128\157 to tell Unison to\n\
+ \032 propagate a file from left to right, rather than \226\128\156> Enter.\226\128\157)\n\
+ \032 There are some situations, though, where this will not work \226\128\148 for\n\
\032 example, when Unison is running in a shell window inside Emacs.\n\
\032 Setting the dumbtty preference will force Unison to leave the\n\
\032 terminal alone and process input a line at a time.\n\
\n\
+ Interrupting a Synchronization\n\
+ \n\
+ \032 It is possible to interrupt an ongoing synchronization process before\n\
+ \032 it completes. Different user interfaces offer different ways of doing\n\
+ \032 it.\n\
+ \n\
+ \032 Graphical Interface:\n\
+ \032 * In the graphical user interface the synchronization process can be\n\
+ \032 interrupted before it is finished by pressing the \226\128\156Stop\226\128\157 button or\n\
+ \032 by closing the window. The \226\128\156Stop\226\128\157 button causes the onging\n\
+ \032 propagation to be stopped as quickly as possible while still doing\n\
+ \032 proper cleanup. The application keeps running and a rescan can be\n\
+ \032 performed or a different profile selected. Closing the window in\n\
+ \032 the middle of update propagation process will exit the application\n\
+ \032 immediately without doing proper cleanup; it is therefore not\n\
+ \032 recommended unless the \226\128\156Stop\226\128\157 button does not react quickly enough.\n\
+ \n\
+ \032 Textual Interface:\n\
+ \032 * When not synchronizing continuously, the text interface terminates\n\
+ \032 when synchronization is finished normally or due to a fatal error\n\
+ \032 occurring.\n\
+ \032 In the text interface, to interrupt synchronization before it is\n\
+ \032 finished, press \226\128\156Ctrl-C\226\128\157 (or send signal SIGINT or SIGTERM). This\n\
+ \032 will interrupt update propagation as quickly as possible but still\n\
+ \032 complete proper cleanup. If the process does not stop even after\n\
+ \032 pressing \226\128\156Ctrl-C\226\128\157 then keep doing it repeatedly. This will bypass\n\
+ \032 cleanup procedures and terminates the process forcibly (similar to\n\
+ \032 SIGKILL). Doing so may leave the archives or replicas in an\n\
+ \032 inconsistent state or locked.\n\
+ \032 When synchronizing continuously (time interval repeat or with\n\
+ \032 filesystem monitoring), interrupting with \226\128\156Ctrl-C\226\128\157 or with signal\n\
+ \032 SIGINT or SIGTERM works the same way as described above and will\n\
+ \032 additionally stop the continuous process. To stop only the\n\
+ \032 continuous process and let the last synchronization complete\n\
+ \032 normally, send signal SIGUSR2 instead.\n\
+ \n\
Exit Code\n\
\n\
\032 When running in the textual mode, Unison returns an exit status, which\n\
@@ -2563,7 +2749,7 @@ let docs =
\n\
\032 matches the path path and any path below. The name and path\n\
\032 arguments of the latter forms of patterns are not regular\n\
- \032 expressions. Instead, standard \"globbing\" conventions can be used\n\
+ \032 expressions. Instead, standard \226\128\156globbing\226\128\157 conventions can be used\n\
\032 in name and path:\n\
\032 + a * matches any sequence of characters not including / (and\n\
\032 not beginning with ., when used at the beginning of a name)\n\
@@ -2573,11 +2759,11 @@ let docs =
\032 to put extra spaces after the commas: these will be\n\
\032 interpreted literally as part of the strings to be matched!)\n\
\032 * The path separator in path patterns is always the forward-slash\n\
- \032 character \"/\" -- even when the client or server is running under\n\
+ \032 character \226\128\156/\226\128\157 \226\128\148 even when the client or server is running under\n\
\032 Windows, where the normal separator character is a backslash. This\n\
\032 makes it possible to use the same set of path patterns for both\n\
\032 Unix and Windows file systems.\n\
- \032 * A path specification may be followed by the separator \" -> \" itself\n\
+ \032 * A path specification may be followed by the separator \226\128\156 -> \226\128\157 itself\n\
\032 followed by a string which will be associated to the matching\n\
\032 paths:\n\
\032 Path path -> associated string\n\
@@ -2590,16 +2776,16 @@ let docs =
\032 is not used. The associated string cannot contain the separator\n\
\032 string.\n\
\n\
- \032 Some examples of path patterns appear in the section \"Ignoring Paths\" .\n\
+ \032 Some examples of path patterns appear in the section \226\128\156Ignoring Paths\226\128\157 .\n\
\032 Associated strings are used by the preference merge.\n\
\n\
Ignoring Paths\n\
\n\
\032 Most users of Unison will find that their replicas contain lots of\n\
- \032 files that they don't ever want to synchronize -- temporary files, very\n\
+ \032 files that they don\226\128\153t ever want to synchronize \226\128\148 temporary files, very\n\
\032 large files, old stuff, architecture-specific binaries, etc. They can\n\
\032 instruct Unison to ignore these paths using patterns introduced in the\n\
- \032 section \"Path Specification\" .\n\
+ \032 section \226\128\156Path Specification\226\128\157 .\n\
\n\
\032 For example, the following pattern will make Unison ignore any path\n\
\032 containing the name CVS or a name ending in .cmo:\n\
@@ -2619,17 +2805,17 @@ let docs =
\032 and ending with a name ending by .ml.\n\
\032 ignore = Regex a/b/.*\\.ml\n\
\n\
- \032 Note that regular expression patterns are \"anchored\": they must match\n\
+ \032 Note that regular expression patterns are \226\128\156anchored\226\128\157: they must match\n\
\032 the whole path, not just a substring of the path.\n\
\n\
\032 Here are a few extra points regarding the ignore preference.\n\
\032 * If a directory is ignored, all its descendants will be too.\n\
\032 * The user interface provides some convenient commands for adding new\n\
\032 patterns to be ignored. To ignore a particular file, select it and\n\
- \032 press \"i\". To ignore all files with the same extension, select it\n\
- \032 and press \"E\" (with the shift key). To ignore all files with the\n\
+ \032 press \226\128\156i\226\128\157. To ignore all files with the same extension, select it\n\
+ \032 and press \226\128\156E\226\128\157 (with the shift key). To ignore all files with the\n\
\032 same name, no matter what directory they appear in, select it and\n\
- \032 press \"N\". These new patterns become permanent: they are\n\
+ \032 press \226\128\156N\226\128\157. These new patterns become permanent: they are\n\
\032 immediately added to the current profile on disk.\n\
\032 * If you use the include directive to include a common collection of\n\
\032 preferences in several top-level preference files, you will\n\
@@ -2650,7 +2836,7 @@ let docs =
\032 an ignore pattern. However, the interaction of these two sets of\n\
\032 patterns can be a little tricky. Here is exactly how it works:\n\
\032 + Unison starts detecting updates from the root of the\n\
- \032 replicas--i.e., from the empty path. If the empty path matches\n\
+ \032 replicas\226\128\148i.e., from the empty path. If the empty path matches\n\
\032 an ignore pattern and does not match an ignorenot pattern,\n\
\032 then the whole replica will be ignored. (For this reason, it\n\
\032 is not a good idea to include Name * as an ignore pattern. If\n\
@@ -2666,19 +2852,19 @@ let docs =
\n\
Symbolic Links\n\
\n\
- \032 Ordinarily, Unison treats symbolic links in Unix replicas as \"opaque\":\n\
+ \032 Ordinarily, Unison treats symbolic links in Unix replicas as \226\128\156opaque\226\128\157:\n\
\032 it considers the contents of the link to be just the string specifying\n\
\032 where the link points, and it will propagate changes in this string to\n\
\032 the other replica.\n\
\n\
- \032 It is sometimes useful to treat a symbolic link \"transparently,\" acting\n\
+ \032 It is sometimes useful to treat a symbolic link \226\128\156transparently,\226\128\157 acting\n\
\032 as though whatever it points to were physically in the replica at the\n\
\032 point where the symbolic link appears. To tell Unison to treat a link\n\
\032 in this manner, add a line of the form\n\
\032 follow = pathspec\n\
\n\
\032 to the profile, where pathspec is a path pattern as described in the\n\
- \032 section \"Path Specification\" .\n\
+ \032 section \226\128\156Path Specification\226\128\157 .\n\
\n\
\032 Not all Windows versions and file systems support symbolic links;\n\
\032 Unison will refuse to propagate an opaque symbolic link from Unix to\n\
@@ -2697,7 +2883,7 @@ let docs =
\n\
\032 Synchronizing the permission bits of files is slightly tricky when two\n\
\032 different filesystems are involved (e.g., when synchronizing a Windows\n\
- \032 client and a Unix server). In detail, here's how it works:\n\
+ \032 client and a Unix server). In detail, here\226\128\153s how it works:\n\
\032 * When the permission bits of an existing file or directory are\n\
\032 changed, the values of those bits that make sense on both operating\n\
\032 systems will be propagated to the other replica. The other bits\n\
@@ -2709,9 +2895,143 @@ let docs =
\032 Unix system).\n\
\032 * For security reasons, the Unix setuid and setgid bits are not\n\
\032 propagated.\n\
- \032 * The Unix owner and group ids are not propagated. (What would this\n\
- \032 mean, in general?) All files are created with the owner and group\n\
- \032 of the server process.\n\
+ \032 * The Unix owner and group ids can be propagated (see owner and group\n\
+ \032 preferences) by mapping names or by numeric ids (see numericids\n\
+ \032 preference).\n\
+ \n\
+ Access Control Lists - ACLs\n\
+ \n\
+ \032 Unison allows synchronizing access control lists (ACLs) on platforms\n\
+ \032 and filesystems that support them. In general, synchronization makes\n\
+ \032 sense only in case both replicas support the same type of ACLs and\n\
+ \032 recognize same users and groups. In some cases you may be able to go\n\
+ \032 beyond that and synchronize ACLs to a replica that couldn\226\128\153t fully use\n\
+ \032 them\226\128\148this may be be useful for the purpose of preserving ACLs.\n\
+ \n\
+ \032 If one of the replicas does not support any type of ACLs then Unison\n\
+ \032 will not attempt ACL synchronization. If the other replica does support\n\
+ \032 ACLs then those will remain intact.\n\
+ \n\
+ \032 If both replicas support ACLs of any supported type then you can\n\
+ \032 request Unison to try ACL synchronization (acl preference). Success of\n\
+ \032 synchronization depends on permissions of the owner and group of Unison\n\
+ \032 process (Unison must have permissions to set ACL) and the compatibility\n\
+ \032 of ACL types on both replicas.\n\
+ \n\
+ \032 An ACL is propagated as a single unit, with all ACEs. There is no\n\
+ \032 merging of ACEs from the replicas.\n\
+ \n\
+ \032 Caveat: ACE inheritance may in certain scenarios cause synchronization\n\
+ \032 inconsistencies. In Windows, only explicit ACEs are synchronized;\n\
+ \032 inherited ACEs are not actively synchronized, but Windows will\n\
+ \032 propagate ACEs from parent directories (unless inheritance is\n\
+ \032 explicitly prevented on a file or a directory\226\128\148this prevention is also\n\
+ \032 synchronized). Due to inheritance, the ultimately effective ACL may be\n\
+ \032 different, or provide different access, even after synchronization.\n\
+ \n\
+ \032 Unison currently supports the following platforms and ACL types:\n\
+ \032 * Windows (Windows XP SP2 and later)\n\
+ \032 + NTFS ACL (discrete ACL (DACL) only)\n\
+ \032 * Solaris, OpenSolaris and illumos-based OS (OpenIndiana, SmartOS,\n\
+ \032 OmniOS, etc.)\n\
+ \032 + NFSv4 ACL (ZFS ACL)\n\
+ \032 + POSIX-draft ACL\n\
+ \032 + Some NFSv4 ACL (ZFS ACL) cross-synchronization with\n\
+ \032 POSIX-draft ACL\n\
+ \032 + Full cross-synchronization with other platforms that support\n\
+ \032 NFSv4 ACLs; limited cross-synchronization with POSIX-draft\n\
+ \032 ACLs\n\
+ \032 * FreeBSD, NetBSD\n\
+ \032 + NFSv4 ACL (ZFS ACL)\n\
+ \032 + Limited POSIX-draft ACL (access ACL only; not default ACL)\n\
+ \032 + Full cross-synchronization with other platforms that support\n\
+ \032 NFSv4 ACLs\n\
+ \032 * Darwin (macOS)\n\
+ \032 + Extended ACL\n\
+ \n\
+ \032 Not all filesystems on the listed platforms support all ACL types (or\n\
+ \032 any ACLs at all).\n\
+ \n\
+ \032 Synchronizing POSIX ACLs on Linux is not supported directly. However,\n\
+ \032 it is possible to synchronize these ACLs with another Linux system by\n\
+ \032 synchronizing extended attributes (xattrs) instead, because POSIX ACLs\n\
+ \032 are stored as xattrs by Linux. This is disabled by default (see the\n\
+ \032 section \226\128\156Extended Attributes - xattrs\226\128\157 ). A simple way to enable\n\
+ \032 syncing POSIX ACLs on Linux is to enable the preference xattrs and add\n\
+ \032 a preference xattrignorenot with a value Path !system.posix_acl_*. The\n\
+ \032 * will be expanded to include both posix_acl_access and\n\
+ \032 posix_acl_default attributes \226\128\147 if you only want to sync either one,\n\
+ \032 just remove the * and type out the attribute name in full. If you want\n\
+ \032 to prevent other xattrs from being synced then add an xattrignore with\n\
+ \032 a value Path * (value Regex .* will also work).\n\
+ \n\
+ Extended Attributes - xattrs\n\
+ \n\
+ \032 Unison allows synchronizing extended attributes on platforms and\n\
+ \032 filesystems that support them. System attributes are not synchronized.\n\
+ \032 What exactly is considered a system attribute is platform-dependent.\n\
+ \032 Synchronization is possible cross-platform, but see caveats below.\n\
+ \n\
+ \032 If one of the replicas does not support extended attributes then Unison\n\
+ \032 will not attempt attribute synchronization. If the other replica does\n\
+ \032 support extended attributes then those will remain intact.\n\
+ \n\
+ \032 If both replicas support extended attributes then you can request\n\
+ \032 Unison to try attribute synchronization (xattrs preference). Extended\n\
+ \032 attributes from both replicas will not be merged, all extended\n\
+ \032 attributes are propagated as a set from one replica to another.\n\
+ \n\
+ \032 Unison currently supports extended attributes on the following\n\
+ \032 platforms:\n\
+ \032 * Linux Attributes in user, trusted and security namespaces.\n\
+ \032 Synchronization of the latter two namespaces depends on unison\n\
+ \032 process privileges and is disabled by default. To sync one or more\n\
+ \032 attributes in the security namespace, for example, you can set the\n\
+ \032 preference xattrignorenot to Path !security.* (for all) or to Path\n\
+ \032 !security.selinux (for one specific attribute). Attributes in\n\
+ \032 system namespace are not synchronized, with the exception of\n\
+ \032 system.posix_acl_default and system.posix_acl_access (also disabled\n\
+ \032 by default).\n\
+ \032 * Solaris, OpenSolaris and illumos-based OS (OpenIndiana, SmartOS,\n\
+ \032 OmniOS, etc.)\n\
+ \032 * FreeBSD, NetBSD Attributes in user namespace.\n\
+ \032 * Darwin (macOS)\n\
+ \n\
+ \032 Not all filesystems on the listed platforms may support extended\n\
+ \032 attributes.\n\
+ \n\
+ \032 Caveats:\n\
+ \032 * Some platforms and file systems support very large extended\n\
+ \032 attribute values. Unison synchronizes only up to 16 MB of each\n\
+ \032 attribute value.\n\
+ \032 * Attributes are synchronized as simple name-value pairs. More\n\
+ \032 complex extended attribute concepts supported by some platforms are\n\
+ \032 not synchronized.\n\
+ \032 * On Linux, attribute names always have a fully qualified form\n\
+ \032 (namespace.attribute). Other platforms do not have the same\n\
+ \032 constraint. The consequence of this is that Unison will sync the\n\
+ \032 attribute names on Linux as follows: an ! is prepended to the\n\
+ \032 namespace name, except for the user namespace; the user. prefix is\n\
+ \032 stripped from attribute names instead. This allows syncing extended\n\
+ \032 attributes from Linux to other platforms. These transformations are\n\
+ \032 reversed when syncing to Linux, resulting in correct fully\n\
+ \032 qualified attribute names. The xattrignore and xattrignorenot\n\
+ \032 preferences work on the transformed attribute names. This means\n\
+ \032 that any patterns for the user namespace must be specified without\n\
+ \032 the user. prefix and any patterns intended for other namespaces\n\
+ \032 must begin with an !.\n\
+ \n\
+ \032 The xattrignore preference can be used to filter the names of extended\n\
+ \032 attributes that will be synchronized. The most useful ignore patterns\n\
+ \032 can be constructed with the Path form (where shell wildcards * and ?\n\
+ \032 are supported) and with the Regex form. The xattrignorenot preference\n\
+ \032 can be used to override xattrignore.\n\
+ \n\
+ \032 Disabling the security and trusted namespaces on Linux is achieved by\n\
+ \032 setting a default xattrignore pattern of Regex\n\
+ \032 !(security|trusted)[.].*. Disabling the syncing of attributes used to\n\
+ \032 store POSIX ACL on Linux is achieved by setting a default xattrignore\n\
+ \032 pattern of Path !system.posix_acl_*.\n\
\n\
Cross-Platform Synchronization\n\
\n\
@@ -2722,23 +3042,23 @@ let docs =
\032 refer to different files. In Windows, on the other hand, filenames are\n\
\032 not case sensitive: foo and FOO can only refer to the same file. This\n\
\032 means that a Unix foo and FOO cannot be synchronized onto a Windows\n\
- \032 system -- Windows won't allow two different files to have the \"same\"\n\
+ \032 system \226\128\148 Windows won\226\128\153t allow two different files to have the \226\128\156same\226\128\157\n\
\032 name. Unison detects this situation for you, and reports that it cannot\n\
\032 synchronize the files.\n\
\n\
\032 You can deal with a case conflict in a couple of ways. If you need to\n\
\032 have both files on the Windows system, your only choice is to rename\n\
\032 one of the Unix files to avoid the case conflict, and re-synchronize.\n\
- \032 If you don't need the files on the Windows system, you can simply\n\
- \032 disregard Unison's warning message, and go ahead with the\n\
- \032 synchronization; Unison won't touch those files. If you don't want to\n\
+ \032 If you don\226\128\153t need the files on the Windows system, you can simply\n\
+ \032 disregard Unison\226\128\153s warning message, and go ahead with the\n\
+ \032 synchronization; Unison won\226\128\153t touch those files. If you don\226\128\153t want to\n\
\032 see the warning on each synchronization, you can tell Unison to ignore\n\
- \032 the files (see the section \"Ignoring Paths\" ).\n\
+ \032 the files (see the section \226\128\156Ignoring Paths\226\128\157 ).\n\
\n\
\032 Illegal filenames. Unix allows some filenames that are illegal in\n\
- \032 Windows. For example, colons (`:') are not allowed in Windows\n\
+ \032 Windows. For example, colons (\226\128\152:\226\128\153) are not allowed in Windows\n\
\032 filenames, but they are legal in Unix filenames. This means that a Unix\n\
- \032 file foo:bar can't be synchronized to a Windows system. As with case\n\
+ \032 file foo:bar can\226\128\153t be synchronized to a Windows system. As with case\n\
\032 conflicts, Unison detects this situation for you, and you have the same\n\
\032 options: you can either rename the Unix file and re-synchronize, or you\n\
\032 can ignore it.\n\
@@ -2748,18 +3068,18 @@ let docs =
\032 Unison is built to run well even over relatively slow links such as\n\
\032 modems and DSL connections.\n\
\n\
- \032 Unison uses the \"rsync protocol\" designed by Andrew Tridgell and Paul\n\
+ \032 Unison uses the \226\128\156rsync protocol\226\128\157 designed by Andrew Tridgell and Paul\n\
\032 Mackerras to greatly speed up transfers of large files in which only\n\
\032 small changes have been made. More information about the rsync protocol\n\
\032 can be found at the rsync web site (http://samba.anu.edu.au/rsync/).\n\
\n\
\032 If you are using Unison with ssh, you may get some speed improvement by\n\
- \032 enabling ssh's compression feature. Do this by adding the option\n\
- \032 \"-sshargs -C\" to the command line or \"sshargs = -C\" to your profile.\n\
+ \032 enabling ssh\226\128\153s compression feature. Do this by adding the option\n\
+ \032 \226\128\156-sshargs -C\226\128\157 to the command line or \226\128\156sshargs = -C\226\128\157 to your profile.\n\
\n\
Making Unison Faster on Large Files\n\
\n\
- \032 Unison's built-in implementation of the rsync algorithm makes\n\
+ \032 Unison\226\128\153s built-in implementation of the rsync algorithm makes\n\
\032 transferring updates to existing files pretty fast. However, for\n\
\032 whole-file copies of newly created files, the built-in transfer method\n\
\032 is not highly optimized. Also, if Unison is interrupted in the middle\n\
@@ -2783,7 +3103,7 @@ let docs =
\032 than a megabyte).\n\
\n\
\032 If you want to use a different external copy utility, set both the\n\
- \032 copyprog and copyprogrest preferences--the former is used for the first\n\
+ \032 copyprog and copyprogrest preferences\226\128\148the former is used for the first\n\
\032 transfer of a file, while the latter is used when Unison sees a\n\
\032 partially transferred temp file on the receiving host. Be careful here:\n\
\032 Your external tool needs to be instructed to copy files in place\n\
@@ -2793,37 +3113,29 @@ let docs =
\032 copyprog = rsync --inplace --compress\n\
\032 copyprogrest = rsync --partial --inplace --compress\n\
\n\
- \032 You may also need to set the copyquoterem preference. When it is set to\n\
- \032 true, this causes Unison to add an extra layer of quotes to the remote\n\
- \032 path passed to the external copy program. This is is needed by rsync,\n\
- \032 for example, which internally uses an ssh connection, requiring an\n\
- \032 extra level of quoting for paths containing spaces. When this flag is\n\
- \032 set to default, extra quotes are added if the value of copyprog\n\
- \032 contains the string rsync. The default value is default, naturally.\n\
- \n\
\032 If a directory transfer is interrupted, the next run of Unison will\n\
\032 automatically skip any files that were completely transferred before\n\
\032 the interruption. (This behavior is always on: it does not depend on\n\
\032 the setting of the copythreshold preference.) Note, though, that the\n\
\032 new directory will not appear in the destination filesystem until\n\
- \032 everything has been transferred--partially transferred directories are\n\
+ \032 everything has been transferred\226\128\148partially transferred directories are\n\
\032 kept in a temporary location (with names like .unison.DIRNAME....)\n\
\032 until the transfer is complete.\n\
\n\
Fast Update Detection\n\
\n\
\032 If your replicas are large and at least one of them is on a Windows\n\
- \032 system, you may find that Unison's default method for detecting changes\n\
+ \032 system, you may find that Unison\226\128\153s default method for detecting changes\n\
\032 (which involves scanning the full contents of every file on every\n\
- \032 sync--the only completely safe way to do it under Windows) is too slow.\n\
+ \032 sync\226\128\148the only completely safe way to do it under Windows) is too slow.\n\
\032 Unison provides a preference fastcheck that, when set to true, causes\n\
- \032 it to use file creation times as 'pseudo inode numbers' when scanning\n\
+ \032 it to use file creation times as \226\128\153pseudo inode numbers\226\128\153 when scanning\n\
\032 replicas for updates, instead of reading the full contents of every\n\
\032 file.\n\
\n\
\032 When fastcheck is set to no, Unison will perform slow\n\
- \032 checking--re-scanning the contents of each file on each\n\
- \032 synchronization--on all replicas. When fastcheck is set to default\n\
+ \032 checking\226\128\148re-scanning the contents of each file on each\n\
+ \032 synchronization\226\128\148on all replicas. When fastcheck is set to default\n\
\032 (which, naturally, is the default), Unison will use fast checks on Unix\n\
\032 replicas and slow checks on Windows replicas.\n\
\n\
@@ -2847,8 +3159,7 @@ let docs =
\032 you are careful. If you synchronize a directory that is stored on\n\
\032 removable media when the media is not present, it will look to Unison\n\
\032 as though the whole directory has been deleted, and it will proceed to\n\
- \032 delete the directory from the other replica--probably not what you\n\
- \032 want!\n\
+ \032 delete the directory from the other replica\226\128\148probably not what you want!\n\
\n\
\032 To prevent accidents, Unison provides a preference called mountpoint.\n\
\032 Including a line like\n\
@@ -2868,1842 +3179,15 @@ let docs =
\032 you want to use ssh.\n\
\n\
\032 When you click on the Unison icon, two windows will be created:\n\
- \032 Unison's regular window, plus a console window, which is used only for\n\
+ \032 Unison\226\128\153s regular window, plus a console window, which is used only for\n\
\032 giving your password to ssh (if you do not use ssh to connect, you can\n\
- \032 ignore this window). When your password is requested, you'll need to\n\
+ \032 ignore this window). When your password is requested, you\226\128\153ll need to\n\
\032 activate the console window (e.g., by clicking in it) before typing. If\n\
- \032 you start Unison from a DOS window, Unison's regular window will appear\n\
+ \032 you start Unison from a DOS window, Unison\226\128\153s regular window will appear\n\
\032 and you will type your password in the DOS window you were using.\n\
\n\
\032 To use Unison in this mode, you must first create a profile (see the\n\
- \032 section \"Profiles\" ). Use your favorite editor for this.\n\
- \n\
- "))
-::
- ("ssh", ("Ssh",
- "Ssh\n\
- \n\
- \032 Your local host will need just an ssh client; the remote host needs an\n\
- \032 ssh server (or daemon). ssh is now normal, and Unison thus does not\n\
- \032 provide instructions.\n\
- \n\
- "))
-::
- ("news", ("Changes in Version 2.51.5",
- "Changes in Version 2.51.5\n\
- \n\
- \032 Changes since 2.51.4:\n\
- \032 * Restore OCaml compat to before 4.02\n\
- \032 * dune/opam improvements/fixes\n\
- \032 * Improve GTK UI by using GtkTreeView\n\
- \032 * Add support for syncing symlinks on Windows (NTFS)\n\
- \032 * Improve ssh support on Windows (hide Windows console in GUI mode)\n\
- \032 * Many bugfixes and minor improvements\n\
- \n\
- \032 Changes since 2.51.3:\n\
- \032 * OCaml 4.12 support\n\
- \032 * fsmonitor improvements and Solaris support\n\
- \032 * Color support in text UI, with a new preference, disabled by\n\
- \032 NO_COLOR.\n\
- \032 * Interactive profile selection in text UI, enabled by a new\n\
- \032 preference.\n\
- \032 * Working files are stored in the unison directory (typically\n\
- \032 /.unison) rather than $HOME.\n\
- \032 * Build cleanups, CI improvements, housekeeping\n\
- \032 * Many bugfixes and minor improvements\n\
- \n\
- \032 Changes since 2.51.2:\n\
- \032 * Some nontrivial changes to profile parsing (G.raud Meyer)\n\
- \032 + '=' has been considered whitespace until now: several\n\
- \032 following chars are considered as only one; trailing chars are\n\
- \032 discarded; any non empty sequence of char is splitting. This\n\
- \032 is non standard and leads to confusion, for example -ignore==\n\
- \032 'Name .*=*' is valid when -ignore='Name .*=*' is not, and\n\
- \032 worse -ignore='Name *=' is the same as -ignore='Name *'. The\n\
- \032 parser now takes just a single '=' as delimiter after the\n\
- \032 option name. Other = characters are considered as part of the\n\
- \032 value being assigned to the option.\n\
- \032 * Numerous improvements to the text user-interface (G.raud Meyer)\n\
- \032 + New key-commands that restrict the display to a set of\n\
- \032 \"matching\" items: ones that are offering to propagate changes\n\
- \032 in a particular direction, conflicts, files to be merged,\n\
- \032 etc., plus several more useful key-commands. Type \"?\" to\n\
- \032 Unison to see all available commands.\n\
- \n\
- \032 Changes since 2.48:\n\
- \032 * Repository transplanted from SVN to Git and moved to GitHub ()\n\
- \032 (https://github.com/bcpierce00/unison).\n\
- \032 * Add a new preference, 'atomic', for specifying directories that\n\
- \032 should be treated atomically: if there are changes within such a\n\
- \032 directory in both replicase, the whole directory is marked as a\n\
- \032 conflict instead of propagating any of the changes. Thanks to\n\
- \032 Julian Squires for submitting this patch!\n\
- \032 * OSX / macOS\n\
- \032 + Ported to 10.13, High Sierra, and Apple's new APFS (earlier\n\
- \032 versions of Unison break because of new behavior of\n\
- \032 AppleDouble files)\n\
- \032 + Replaced Growl with OS X native notification center.\n\
- \032 * Miscellaneous:\n\
- \032 + The OCaml compiler version is now included in the \"connection\n\
- \032 header -- the string that's printed when connecting to a\n\
- \032 remote server -- to facilitate debugging version mismatch\n\
- \032 issues.\n\
- \032 + Compatible with OCaml 4.06.\n\
- \032 + Added a DockerFile for the convenience of Docker users.\n\
- \032 + Many small bugfixes and UI improvements.\n\
- \n\
- \032 Changes since 2.45:\n\
- \032 * Incorporated a patch from Christopher Zimmermann to replace the\n\
- \032 Uprintf module (which doesn't work with OCaml 4.02, causing Unison\n\
- \032 to crash) with equivalent functionality from the standard library.\n\
- \032 * Incorporated a refresh of the OSX GUI, contributed by Alan Shutko.\n\
- \032 * Added a maxsizethreshold option, which prevents the transfer of\n\
- \032 files larger than the size specified (in Kb).\n\
- \032 * Added a \"copyonconflict\" preference, to make a copy of files that\n\
- \032 would otherwise be overwritten or deleted in case of conflicting\n\
- \032 changes. (This makes it possible to automatically resolve conflicts\n\
- \032 in a fairly safe way when synchronizing continuously, in\n\
- \032 combination with the \"repeat = watch\" and \"prefer = newer\"\n\
- \032 preferences.\n\
- \032 * File system monitoring:\n\
- \032 + The file watcher now fails when unable to watch a directory,\n\
- \032 rather than silently ignoring the issue.\n\
- \032 + File system monitoring: more robust communication with the\n\
- \032 helper program (in socket mode, the unison server will still\n\
- \032 work properly despite unexpected unison client\n\
- \032 disconnections).\n\
- \032 + A bytecode version of unison-fsmonitor is now produced by\n\
- \032 \"make NATIVE=false\"\n\
- \032 + Improved search for unison-fsmonitor\n\
- \032 + Detect when the helper process exits.\n\
- \032 + More robust file watching helper programs for Windows and\n\
- \032 Linux. They communicate with Unison through pipes (Unison\n\
- \032 redirects stdin and stdout), using a race-free protocol.\n\
- \032 + Retries paths with failures using an exponential backoff\n\
- \032 algorithm.\n\
- \032 + The information returned by the file watchers are used\n\
- \032 independently for each replica; thus, when only one replica\n\
- \032 has changes, Unison will only rescan this replica.\n\
- \032 + When available, used by the graphical UIs to speed up\n\
- \032 rescanning (can be disabled by setting the new watch\n\
- \032 preference to\n\
- \032 + Small fix to the way fsmonitor.py gets invoked when using the\n\
- \032 file watching functionality, suggested by Josh Berdine. Unison\n\
- \032 will now look for fsmonitor.py in the same directory where the\n\
- \032 Unison executable itself lives.\n\
- \032 * Minor:\n\
- \032 + Fixed a bug in export procedure that was messing up\n\
- \032 documentation strings.\n\
- \032 + Incorporated a patch from Ir\225nyossy Knoblauch Art\250r to make\n\
- \032 temp file names fit within 143 characters (to make eCryptFS\n\
- \032 happy).\n\
- \032 + Added a string to the Conflict direction to document the\n\
- \032 reason of the conflict.\n\
- \032 + Log conflicts and problems in the text UI even if nothing is\n\
- \032 propagated.\n\
- \032 + Use hash function from OCaml 3.x for comparing archives, even\n\
- \032 when compiled with OCaml 4.x.\n\
- \032 + Do not restart Unison in case of uncaught exception when the\n\
- \032 repeat preference is set. This seems safer. And it does not\n\
- \032 work, for instance, in case of lost connection.\n\
- \032 + Fix Unix.readlink invalid argument error under Windows\n\
- \032 + Fix a crash when the output of the diff program is too large.\n\
- \032 + Fixed Makefile for cross-compiling towards Windows (updated to\n\
- \032 MinGW-w64)\n\
- \n\
- \032 Changes since 2.40.63:\n\
- \032 * New preference fastercheckUNSAFE, which can be used (with care!) to\n\
- \032 achieve much faster update detection when all the common files in\n\
- \032 the two replicas are known to be identical. See the manual for more\n\
- \032 information.\n\
- \032 This feature should still be considered experimental, but it's\n\
- \032 ready for other people to try out.\n\
- \032 * Added option clientHostName. If specified, it will be used to as\n\
- \032 the client host name, overriding UNISONLOCALHOSTNAME and the actual\n\
- \032 host name.\n\
- \032 * OS X GUI:\n\
- \032 + fix crash under Lion, because of problems with the toolbar,\n\
- \032 using the fix suggested in\n\
- \032 http://blitzbasic.com/Community/posts.php?topic=95778.\n\
- \032 + uimacnew09 is now the standard graphical interface on OSX\n\
- \032 + A small improvement to the uimacnew09 interface from Alan\n\
- \032 Schmitt and Steve Kalkwarf: when Unison is run with the -batch\n\
- \032 flag, the interface will now automatically propagate changes\n\
- \032 and terminate, without waiting for user interaction.\n\
- \032 + Show a modal warning window if there is no archive for the\n\
- \032 hosts. The user can then choose to exit or proceed (proceed is\n\
- \032 the default). The window is not shown if the batch preference\n\
- \032 is true.\n\
- \032 + file details panel selectable\n\
- \032 * GTK GUI:\n\
- \032 + New version of uigtk2.ml from Matt Zagrabelny that reorganizes\n\
- \032 the icons in a slightly more intuitive way.\n\
- \032 * Minor fixes:\n\
- \032 + Setting the prefer preference to older or newer now propagates\n\
- \032 deletions when there is no conflict.\n\
- \032 + Correctly quote the path when running merge commands.\n\
- \032 + Add quotes to paths when calling external file watcher\n\
- \032 utility.\n\
- \032 + Incorporate a patch to fsmonitor.py (the external filewatcher\n\
- \032 utility) from Tomasz Zernicki to make it work better under\n\
- \032 Windows.\n\
- \032 + Incorporated new version of fsmonitor.py from Christophe Gohle\n\
- \032 + Fixed incompatibility with OpenSSH 5.6.\n\
- \032 + Fixed fingerprint cache: do not cache file properties\n\
- \032 + Some spelling corrections in documentation and comments from\n\
- \032 Stephane Glondu\n\
- \032 + Fixed O_APPEND mode for open under Windows\n\
- \032 + Fixed String.sub invalid argument error when an AppleDouble\n\
- \032 file does not contain a finder information field\n\
- \032 + Trim duplicate paths when using \"-repeat watch\"\n\
- \032 + Unison now passes path arguments and -follow directives to\n\
- \032 fsmonitor.py. This seems to work except for one small issue\n\
- \032 with how fsmonitor.py treats -follow directives for\n\
- \032 directories that don't exist (or maybe this is an issue with\n\
- \032 how it treats any kind of monitoring when the thing being\n\
- \032 monitored doesn't exist?). If we create a symlink to a\n\
- \032 nonexistent directory, give Unison (hence fsmonitor.py) a\n\
- \032 'follow' directive for the symlink, start unison, and then\n\
- \032 create the directory, fsmonitor.py misses the change.\n\
- \032 + Lines added in profile files by unison always start at a new\n\
- \032 line\n\
- \n\
- \032 Changes since 2.40.1:\n\
- \032 * Added \"BelowPath\" patterns, that match a path as well as all paths\n\
- \032 below (convenient to use with nodeletion,update,creationpartial\n\
- \032 preferences)\n\
- \032 * Added a \"fat\" preference that makes Unison use the right options\n\
- \032 when one of the replica is on a FAT filesystem.\n\
- \032 * Allow \"prefer/force=newer\" even when not synchronizing modification\n\
- \032 times. (The reconciler will not be aware of the modification time\n\
- \032 of unchanged files, so the synchronization choices of Unison can be\n\
- \032 different from when \"times=true\", but the behavior remains sane:\n\
- \032 changed files with the most recent modification time will be\n\
- \032 propagated.)\n\
- \032 * Minor fixes and improvements:\n\
- \032 + Compare filenames up to decomposition in case sensitive mode\n\
- \032 when one host is running MacOSX and the unicode preference is\n\
- \032 set to true.\n\
- \032 + Rsync: somewhat faster compressor\n\
- \032 + Make Unicode the default on all architectures (it was only the\n\
- \032 default when a Mac OS X or Windows machine was involved).\n\
- \n\
- \032 Changes since 2.32:\n\
- \032 * Major enhancement: Unicode support.\n\
- \032 + Unison should now handle unicode filenames correctly on all\n\
- \032 platforms.\n\
- \032 + This functionality is controlled by a new preference unicode.\n\
- \032 + Unicode mode is now the default when one of the hosts is under\n\
- \032 Windows or MacOS. This may make upgrades a bit more painful\n\
- \032 (the archives cannot be reused), but this is a much saner\n\
- \032 default.\n\
- \032 * Partial transfer of directories. If an error occurs while\n\
- \032 transferring a directory, the part transferred so far is copied\n\
- \032 into place (and the archives are updated accordingly). The\n\
- \032 \"maxerrors\" preference controls how many transfer error Unison will\n\
- \032 accept before stopping the transfer of a directory (by default,\n\
- \032 only one). This makes it possible to transfer most of a directory\n\
- \032 even if there are some errors. Currently, only the first error is\n\
- \032 reported by the GUIs.\n\
- \032 Also, allow partial transfer of a directory when there was an error\n\
- \032 deep inside this directory during update detection. At the moment,\n\
- \032 this is only activated with the text and GTK UIs, which have been\n\
- \032 modified so that they show that the transfer is going to be partial\n\
- \032 and so that they can display all errors.\n\
- \032 * Improvement to the code for resuming directory transfers:\n\
- \032 + if a file was not correctly transferred (or the source has\n\
- \032 been modified since, with unchanged size), Unison performs a\n\
- \032 new transfer rather than failing\n\
- \032 + spurious files are deleted (this can happen if a file is\n\
- \032 deleted on the source replica before resuming the transfer;\n\
- \032 not deleting the file would result in it reappearing on the\n\
- \032 target replica)\n\
- \032 * Experimental streaming protocol for transferring file contents (can\n\
- \032 be disabled by setting the directive \"stream\" to false): file\n\
- \032 contents is transferred asynchronously (without waiting for a\n\
- \032 response from the destination after each chunk sent) rather than\n\
- \032 using the synchronous RPC mechanism. As a consequence:\n\
- \032 + Unison now transfers the contents of a single file at a time\n\
- \032 (Unison used to transfer several contents simultaneously in\n\
- \032 order to hide the connection latency.)\n\
- \032 + the transfer of large files uses the full available bandwidth\n\
- \032 and is not slowed done due to the connection latency anymore\n\
- \032 + we get performance improvement for small files as well by\n\
- \032 scheduling many files simultaneously (as scheduling a file for\n\
- \032 transfer consume little resource: it does not mean allocating\n\
- \032 a large buffer anymore)\n\
- \032 * Changes to the internal implementation of the rsync algorithm:\n\
- \032 + use longer blocks for large files (the size of a block is the\n\
- \032 square root of the size of the file for large files);\n\
- \032 + transmit less checksum information per block (we still have\n\
- \032 less than one chance in a hundred million of transferring a\n\
- \032 file incorrectly, and Unison will catch any transfer error\n\
- \032 when fingerprinting the whole file)\n\
- \032 + avoid transfer overhead (which was 4 bytes per block)\n\
- \032 For a 1G file, the first optimization saves a factor 50 on the\n\
- \032 amount of data transferred from the target to the source (blocks\n\
- \032 are 32768 bytes rather than just 700 bytes). The two other\n\
- \032 optimizations save another factor of 2 (from 24 bytes per block\n\
- \032 down to 10).\n\
- \032 * Implemented an on-disk file fingerprint cache to speed-up update\n\
- \032 detection after a crash: this way, Unison does not have do\n\
- \032 recompute all the file fingerprints from scratch.\n\
- \032 + When Unison detects that the archive case-sensitivity mode\n\
- \032 does not match the current settings, it populates the\n\
- \032 fingerprint cache using the archive contents. This way,\n\
- \032 changing the case-sensitivity mode should be reasonably fast.\n\
- \032 * New preferences \"noupdate=root\", \"nodeletion=root\",\n\
- \032 \"nocreation=root\" that prevent Unison from performing files\n\
- \032 updates, deletions or creations on the given root. Also 'partial'\n\
- \032 versions of 'noupdate', 'nodeletion' and 'nocreation'\n\
- \032 * Limit the number of simultaneous external copy program (\"copymax\"\n\
- \032 preference)\n\
- \032 * New \"links\" preference. When set to false, Unison will report an\n\
- \032 error on symlinks during update detection. (This is the default\n\
- \032 when one host is running Windows but not Cygwin.) This is better\n\
- \032 than failing during propagation.\n\
- \032 * Added a preference \"halfduplex\" to force half-duplex communication\n\
- \032 with the server. This may be useful on unreliable links (as a more\n\
- \032 efficient alternative to \"maxthreads = 1\").\n\
- \032 * Renamed preference \"pretendwin\" to \"ignoreinodenumbers\" (an alias\n\
- \032 is kept for backwards compatibility).\n\
- \032 * Ignore one-second differences when synchronizing modification time.\n\
- \032 (Technically, this is an incompatible archive format change, but it\n\
- \032 is backward compatible. To trigger a problem, a user would have to\n\
- \032 synchronize modification times on a filesystem with a two-second\n\
- \032 granularity and then downgrade to a previous version of Unison,\n\
- \032 which does not work well in such a case. Thus, it does not seem\n\
- \032 worthwhile to increment the archive format number, which would\n\
- \032 impact all users.)\n\
- \032 * Do not keep many files simultaneously opened anymore when the rsync\n\
- \032 algorithm is in use.\n\
- \032 * Add \"ignorearchives\" preference to ignore existing archives (to\n\
- \032 avoid forcing users to delete them manually, in situations where\n\
- \032 one archive has gotten deleted or corrupted).\n\
- \032 * Mac OS\n\
- \032 + fixed rsync bug which could result in an \"index out of bounds\"\n\
- \032 error when transferring resource forks.\n\
- \032 + Fixed bug which made Unison ignore finder information and\n\
- \032 resource fork when compiled to 64bit on Mac OSX.\n\
- \032 + should now be 64 bit clean (the Growl framework is not up to\n\
- \032 date, though)\n\
- \032 + Made the bridge between Objective C and Ocaml code GC friendly\n\
- \032 (it was allocating ML values and putting them in an array\n\
- \032 which was not registered with the GC)\n\
- \032 + use darker grey arrows (patch contributed by Eric Y. Kow)\n\
- \032 * GTK user interface\n\
- \032 + assistant for creating profiles\n\
- \032 + profile editor\n\
- \032 + pop up a summary window when the replicas are not fully\n\
- \032 synchronized after transport\n\
- \032 + display estimated remaining time and transfer rate on the\n\
- \032 progress bar\n\
- \032 + allow simultaneous selection of several items\n\
- \032 + Do not reload the preference file before a new update\n\
- \032 detection if it is unchanged\n\
- \032 + disabled scrolling to the first unfinished item during\n\
- \032 transport. It goes way too fast when lot of small files are\n\
- \032 synchronized, and it makes it impossible to browse the file\n\
- \032 list during transport.\n\
- \032 + take into account the \"height\" preference again\n\
- \032 + the internal list of selected reconciler item was not always\n\
- \032 in sync with what was displayed (GTK bug?); workaround\n\
- \032 implemented\n\
- \032 + Do not display \"Looking for change\" messages during\n\
- \032 propagation (when checking the targe is unchanged) but only\n\
- \032 during update detection\n\
- \032 + Apply patch to fix some crashes in the OSX GUI, thanks to Onne\n\
- \032 Gorter.\n\
- \032 * Text UI\n\
- \032 + During update detection, display status by updating a single\n\
- \032 line rather than generating a new line of output every so\n\
- \032 often. Should be less confusing.\n\
- \032 * Windows\n\
- \032 + Fastcheck is now the default under Windows. People mostly use\n\
- \032 NTFS nowadays and the Unicode API provides an equivalent to\n\
- \032 inode numbers for this filesystem.\n\
- \032 + Only use long UNC path for accessing replicas (as '..' is not\n\
- \032 handled with this format of paths, but can be useful)\n\
- \032 + Windows text UI: now put the console into UTF-8 output mode.\n\
- \032 This is the right thing to do when in Unicode mode, and is no\n\
- \032 worse than what we had previously otherwise (the console use\n\
- \032 some esoteric encoding by default). This only works when using\n\
- \032 a Unicode font instead of the default raster font.\n\
- \032 + Don't get the home directory from environment variable HOME\n\
- \032 under Windows (except for Cygwin binaries): we don't want the\n\
- \032 behavior of Unison to depends on whether it is run from a\n\
- \032 Cygwin shell (where HOME is set) or in any other way (where\n\
- \032 HOME is usually not set).\n\
- \032 * Miscellaneous fixes and improvements\n\
- \032 + Made a server waiting on a socket more resilient to unexpected\n\
- \032 lost connections from the client.\n\
- \032 + Small patch to property setting code suggested by Ulrich\n\
- \032 Gernkow.\n\
- \032 + Several fixes to the change transfer functions (both the\n\
- \032 internal ones and external transfers using rsync). In\n\
- \032 particular, limit the number of simultaneous transfer using an\n\
- \032 rsync (as the rsync algorithm can use a large amount of memory\n\
- \032 when processing huge files)\n\
- \032 + Keep track of which file contents are being transferred, and\n\
- \032 delay the transfer of a file when another file with the same\n\
- \032 contents is currently being transferred. This way, the second\n\
- \032 transfer can be skipped and replaced by a local copy.\n\
- \032 + Experimental update detection optimization: do not read the\n\
- \032 contents of unchanged directories\n\
- \032 + When a file transfer fails, turn off fastcheck for this file\n\
- \032 on the next sync.\n\
- \032 + Fixed bug with case insensitive mode on a case sensitive\n\
- \032 filesystem:\n\
- \032 o if file \"a/a\" is created on one replica and directory \"A\"\n\
- \032 is created on the other, the file failed to be\n\
- \032 synchronized the first time Unison is run afterwards, as\n\
- \032 Unison uses the wrong path \"a/a\" (if Unison is run again,\n\
- \032 the directories are in the archive, so the right path is\n\
- \032 used);\n\
- \032 o if file \"a\" appears on one replica and file \"A\" appears\n\
- \032 on the other with different contents, Unison was unable\n\
- \032 to synchronize them.\n\
- \032 + Improved error reporting when the destination is updated\n\
- \032 during synchronization: Unison now tells which file has been\n\
- \032 updated, and how.\n\
- \032 + Limit the length of temporary file names\n\
- \032 + Case sensitivity information put in the archive (in a backward\n\
- \032 compatible way) and checked when the archive is loaded\n\
- \032 + Got rid of the 16mb marshalling limit by marshalling to a\n\
- \032 bigarray.\n\
- \032 + Resume copy of partially transferred files.\n\
- \n\
- \032 Changes since 2.31:\n\
- \032 * Small user interface changes\n\
- \032 + Small change to text UI \"scanning...\" messages, to print just\n\
- \032 directories (hopefully making it clearer that individual files\n\
- \032 are not necessarily being fingerprinted).\n\
- \032 * Minor fixes and improvements:\n\
- \032 + Ignore one hour differences when deciding whether a file may\n\
- \032 have been updated. This avoids slow update detection after\n\
- \032 daylight saving time changes under Windows. This makes Unison\n\
- \032 slightly more likely to miss an update, but it should be safe\n\
- \032 enough.\n\
- \032 + Fix a small bug that was affecting mainly windows users. We\n\
- \032 need to commit the archives at the end of the sync even if\n\
- \032 there are no updates to propagate because some files (in fact,\n\
- \032 if we've just switched to DST on windows, a LOT of files)\n\
- \032 might have new modtimes in the archive. (Changed the text UI\n\
- \032 only. It's less clear where to change the GUI.)\n\
- \032 + Don't delete the temp file when a transfer fails due to a\n\
- \032 fingerprint mismatch (so that we can have a look and see why!)\n\
- \032 We've also added more debugging code togive more informative\n\
- \032 error messages when we encounter the dreaded and longstanding\n\
- \032 \"assert failed during file transfer\" bug\n\
- \032 + Incorrect paths (\"path\" directive) now result in an error\n\
- \032 update item rather than a fatal error.\n\
- \032 + Create parent directories (with correct permissions) during\n\
- \032 transport for paths which point to non-existent locations in\n\
- \032 the destination replica.\n\
- \n\
- \032 Changes since 2.27:\n\
- \032 * If Unison is interrupted during a directory transfer, it will now\n\
- \032 leave the partially transferred directory intact in a temporary\n\
- \032 location. (This maintains the invariant that new files/directories\n\
- \032 are transferred either completely or not at all.) The next time\n\
- \032 Unison is run, it will continue filling in this temporary\n\
- \032 directory, skipping transferring files that it finds are already\n\
- \032 there.\n\
- \032 * We've added experimental support for invoking an external file\n\
- \032 transfer tool for whole-file copies instead of Unison's built-in\n\
- \032 transfer protocol. Three new preferences have been added:\n\
- \032 + copyprog is a string giving the name (and command-line\n\
- \032 switches, if needed) of an external program that can be used\n\
- \032 to copy large files efficiently. By default, rsync is invoked,\n\
- \032 but other tools such as scp can be used instead by changing\n\
- \032 the value of this preference. (Although this is not its\n\
- \032 primary purpose, rsync is actually a pretty fast way of\n\
- \032 copying files that don't already exist on the receiving host.)\n\
- \032 For files that do already exist on (but that have been changed\n\
- \032 in one replica), Unison will always use its built-in\n\
- \032 implementation of the rsync algorithm.\n\
- \032 + Added a \"copyprogrest\" preference, so that we can give\n\
- \032 different command lines for invoking the external copy utility\n\
- \032 depending on whether a partially transferred file already\n\
- \032 exists or not. (Rsync doesn't seem to care about this, but\n\
- \032 other utilities may.)\n\
- \032 + copythreshold is an integer (-1 by default), indicating above\n\
- \032 what filesize (in megabytes) Unison should use the external\n\
- \032 copying utility specified by copyprog. Specifying 0 will cause\n\
- \032 ALL copies to use the external program; a negative number will\n\
- \032 prevent any files from using it. (Default is -1.)\n\
- \032 Thanks to Alan Schmitt for a huge amount of hacking and to an\n\
- \032 anonymous sponsor for suggesting and underwriting this extension.\n\
- \032 * Small improvements:\n\
- \032 + Added a new preference, dontchmod. By default, Unison uses the\n\
- \032 chmod system call to set the permission bits of files after it\n\
- \032 has copied them. But in some circumstances (and under some\n\
- \032 operating systems), the chmod call always fails. Setting this\n\
- \032 preference completely prevents Unison from ever calling chmod.\n\
- \032 + Don't ignore files that look like backup files if the\n\
- \032 backuplocation preference is set to central\n\
- \032 + Shortened the names of several preferences. The old names are\n\
- \032 also still supported, for backwards compatibility, but they do\n\
- \032 not appear in the documentation.\n\
- \032 + Lots of little documentation tidying. (In particular,\n\
- \032 preferences are separated into Basic and Advanced! This should\n\
- \032 hopefully make Unison a little more approachable for new\n\
- \032 users.\n\
- \032 + Unison can sometimes fail to transfer a file, giving the\n\
- \032 unhelpful message \"Destination updated during synchronization\"\n\
- \032 even though the file has not been changed. This can be caused\n\
- \032 by programs that change either the file's contents or the\n\
- \032 file's extended attributes without changing its modification\n\
- \032 time. It's not clear what is the best fix for this - it is not\n\
- \032 Unison's fault, but it makes Unison's behavior puzzling - but\n\
- \032 at least Unison can be more helpful about suggesting a\n\
- \032 workaround (running once with fastcheck set to false). The\n\
- \032 failure message has been changed to give this advice.\n\
- \032 + Further improvements to the OS X GUI (thanks to Alan Schmitt\n\
- \032 and Craig Federighi).\n\
- \032 * Very preliminary support for triggering Unison from an external\n\
- \032 filesystem-watching utility. The current implementation is very\n\
- \032 simple, not efficient, and almost completely untested--not ready\n\
- \032 for real users. But if someone wants to help improve it (e.g., by\n\
- \032 writing a filesystem watcher for your favorite OS), please make\n\
- \032 yourself known!\n\
- \032 On the Unison side, the new behavior is very simple:\n\
- \032 + use the text UI\n\
- \032 + start Unison with the command-line flag \"-repeat FOO\", where\n\
- \032 FOO is name of a file where Unison should look for\n\
- \032 notifications of changes\n\
- \032 + when it starts up, Unison will read the whole contents of this\n\
- \032 file (on both hosts), which should be a newline-separated list\n\
- \032 of paths (relative to the root of the synchronization) and\n\
- \032 synchronize just these paths, as if it had been started with\n\
- \032 the \"-path=xxx\" option for each one of them\n\
- \032 + when it finishes, it will sleep for a few seconds and then\n\
- \032 examine the watchfile again; if anything has been added, it\n\
- \032 will read the new paths, synchronize them, and go back to\n\
- \032 sleep\n\
- \032 + that's it!\n\
- \032 To use this to drive Unison \"incrementally,\" just start it in this\n\
- \032 mode and start up a tool (on each host) to watch for new changes to\n\
- \032 the filesystem and append the appropriate paths to the watchfile.\n\
- \032 Hopefully such tools should not be too hard to write.\n\
- \032 * Bug fixes:\n\
- \032 + Fixed a bug that was causing new files to be created with\n\
- \032 permissions 0x600 instead of using a reasonable default (like\n\
- \032 0x644), if the 'perms' flag was set to 0. (Bug reported by Ben\n\
- \032 Crowell.)\n\
- \032 + Follow maxthreads preference when transferring directories.\n\
- \n\
- \032 Changes since 2.17:\n\
- \032 * Major rewrite and cleanup of the whole Mac OS X graphical user\n\
- \032 interface by Craig Federighi. Thanks, Craig!!!\n\
- \032 * Small fix to ctime (non-)handling in update detection under windows\n\
- \032 with fastcheck.\n\
- \032 * Several small fixes to the GTK2 UI to make it work better under\n\
- \032 Windows [thanks to Karl M for these].\n\
- \032 * The backup functionality has been completely rewritten. The\n\
- \032 external interface has not changed, but numerous bugs, irregular\n\
- \032 behaviors, and cross-platform inconsistencies have been corrected.\n\
- \032 * The Unison project now accepts donations via PayPal. If you'd like\n\
- \032 to donate, you can find a link to the donation page on the Unison\n\
- \032 home page (http://www.cis.upenn.edu/ bcpierce/unison/lists.html).\n\
- \032 * Some important safety improvements:\n\
- \032 + Added a new mountpoint preference, which can be used to\n\
- \032 specify a path that must exist in both replicas at the end of\n\
- \032 update detection (otherwise Unison aborts). This can be used\n\
- \032 to avoid potentially dangerous situations when Unison is used\n\
- \032 with removable media such as external hard drives and compact\n\
- \032 flash cards.\n\
- \032 + The confirmation of \"big deletes\" is now controlled by a\n\
- \032 boolean preference confirmbigdeletes. Default is true, which\n\
- \032 gives the same behavior as previously. (This functionality is\n\
- \032 at least partly superseded by the mountpoint preference, but\n\
- \032 it has been left in place in case it is useful to some\n\
- \032 people.)\n\
- \032 + If Unison is asked to \"follow\" a symbolic link but there is\n\
- \032 nothing at the other end of the link, it will now flag this\n\
- \032 path as an error, rather than treating the symlink itself as\n\
- \032 missing or deleted. This avoids a potentially dangerous\n\
- \032 situation where a followed symlink points to an external\n\
- \032 filesystem that might be offline when Unison is run (whereupon\n\
- \032 Unison would cheerfully delete the corresponding files in the\n\
- \032 other replica!).\n\
- \032 * Smaller changes:\n\
- \032 + Added forcepartial and preferpartial preferences, which behave\n\
- \032 like force and prefer but can be specified on a per-path\n\
- \032 basis. [Thanks to Alan Schmitt for this.]\n\
- \032 + A bare-bones self test feature was added, which runs unison\n\
- \032 through some of its paces and checks that the results are as\n\
- \032 expected. The coverage of the tests is still very limited, but\n\
- \032 the facility has already been very useful in debugging the new\n\
- \032 backup functionality (especially in exposing some subtle\n\
- \032 cross-platform issues).\n\
- \032 + Refined debugging code so that the verbosity of individual\n\
- \032 modules can be controlled separately. Instead of just putting\n\
- \032 '-debug verbose' on the command line, you can put '-debug\n\
- \032 update+', which causes all the extra messages in the Update\n\
- \032 module, but not other modules, to be printed. Putting '-debug\n\
- \032 verbose' causes all modules to print with maximum verbosity.\n\
- \032 + Removed mergebatch preference. (It never seemed very useful,\n\
- \032 and its semantics were confusing.)\n\
- \032 + Rewrote some of the merging functionality, for better\n\
- \032 cooperation with external Harmony instances.\n\
- \032 + Changed the temp file prefix from .# to .unison.\n\
- \032 + Compressed the output from the text user interface\n\
- \032 (particularly when run with the -terse flag) to make it easier\n\
- \032 to interpret the results when Unison is run several times in\n\
- \032 succession from a script.\n\
- \032 + Diff and merge functions now work under Windows.\n\
- \032 + Changed the order of arguments to the default diff command (so\n\
- \032 that the + and - annotations in diff's output are reversed).\n\
- \032 + Added .mpp files to the \"never fastcheck\" list (like .xls\n\
- \032 files).\n\
- \032 * Many small bugfixes, including:\n\
- \032 + Fixed a longstanding bug regarding fastcheck and daylight\n\
- \032 saving time under Windows when Unison is set up to synchronize\n\
- \032 modification times. (Modification times cannot be updated in\n\
- \032 the archive in this case, so we have to ignore one hour\n\
- \032 differences.)\n\
- \032 + Fixed a bug that would occasionally cause the archives to be\n\
- \032 left in non-identical states on the two hosts after\n\
- \032 synchronization.\n\
- \032 + Fixed a bug that prevented Unison from communicating correctly\n\
- \032 between 32- and 64-bit architectures.\n\
- \032 + On windows, file creation times are no longer used as a proxy\n\
- \032 for inode numbers. (This is unfortunate, as it makes fastcheck\n\
- \032 a little less safe. But it turns out that file creation times\n\
- \032 are not reliable under Windows: if a file is removed and a new\n\
- \032 file is created in its place, the new one will sometimes be\n\
- \032 given the same creation date as the old one!)\n\
- \032 + Set read-only file to R/W on OSX before attempting to change\n\
- \032 other attributes.\n\
- \032 + Fixed bug resulting in spurious \"Aborted\" errors during\n\
- \032 transport (thanks to Jerome Vouillon)\n\
- \032 + Enable diff if file contents have changed in one replica, but\n\
- \032 only properties in the other.\n\
- \032 + Removed misleading documentation for 'repeat' preference.\n\
- \032 + Fixed a bug in merging code where Unison could sometimes\n\
- \032 deadlock with the external merge program, if the latter\n\
- \032 produced large amounts of output.\n\
- \032 + Workaround for a bug compiling gtk2 user interface against\n\
- \032 current versions of gtk2+ libraries.\n\
- \032 + Added a better error message for \"ambiguous paths\".\n\
- \032 + Squashed a longstanding bug that would cause file transfer to\n\
- \032 fail with the message \"Failed: Error in readWrite: Is a\n\
- \032 directory.\"\n\
- \032 + Replaced symlinks with copies of their targets in the Growl\n\
- \032 framework in src/uimac. This should make the sources easier to\n\
- \032 check out from the svn repository on WinXP systems.\n\
- \032 + Added a workaround (suggested by Karl M.) for the problem\n\
- \032 discussed on the unison users mailing list where, on the\n\
- \032 Windows platform, the server would hang when transferring\n\
- \032 files. I conjecture that the problem has to do with the RPC\n\
- \032 mechanism, which was used to make a call back from the server\n\
- \032 to the client (inside the Trace.log function) so that the log\n\
- \032 message would be appended to the log file on the client. The\n\
- \032 workaround is to dump these messages (about when xferbycopying\n\
- \032 shortcuts are applied and whether they succeed) just to the\n\
- \032 standard output of the Unison process, not to the log file.\n\
- \n\
- \032 Changes since 2.13.0:\n\
- \032 * The features for performing backups and for invoking external merge\n\
- \032 programs have been completely rewritten by Stephane Lescuyer\n\
- \032 (thanks, Stephane!). The user-visible functionality should not\n\
- \032 change, but the internals have been rationalized and there are a\n\
- \032 number of new features. See the manual (in particular, the\n\
- \032 description of the backupXXX preferences) for details.\n\
- \032 * Incorporated patches for ipv6 support, contributed by Samuel\n\
- \032 Thibault. (Note that, due to a bug in the released OCaml 3.08.3\n\
- \032 compiler, this code will not actually work with ipv6 unless\n\
- \032 compiled with the CVS version of the OCaml compiler, where the bug\n\
- \032 has been fixed; however, ipv4 should continue to work normally.)\n\
- \032 * OSX interface:\n\
- \032 + Incorporated Ben Willmore's cool new icon for the Mac UI.\n\
- \032 * Small fixes:\n\
- \032 + Fixed off by one error in month numbers (in printed dates)\n\
- \032 reported by Bob Burger\n\
- \n\
- \032 Changes since 2.12.0:\n\
- \032 * New convention for release numbering: Releases will continue to be\n\
- \032 given numbers of the form X.Y.Z, but, from now on, just the major\n\
- \032 version number (X.Y) will be considered significant when checking\n\
- \032 compatibility between client and server versions. The third\n\
- \032 component of the version number will be used only to identify\n\
- \032 \"patch levels\" of releases.\n\
- \032 This change goes hand in hand with a change to the procedure for\n\
- \032 making new releases. Candidate releases will initially be given\n\
- \032 \"beta release\" status when they are announced for public\n\
- \032 consumption. Any bugs that are discovered will be fixed in a\n\
- \032 separate branch of the source repository (without changing the\n\
- \032 major version number) and new tarballs re-released as needed. When\n\
- \032 this process converges, the patched beta version will be dubbed\n\
- \032 stable.\n\
- \032 * Warning (failure in batch mode) when one path is completely\n\
- \032 emptied. This prevents Unison from deleting everything on one\n\
- \032 replica when the other disappear.\n\
- \032 * Fix diff bug (where no difference is shown the first time the diff\n\
- \032 command is given).\n\
- \032 * User interface changes:\n\
- \032 + Improved workaround for button focus problem (GTK2 UI)\n\
- \032 + Put leading zeroes in date fields\n\
- \032 + More robust handling of character encodings in GTK2 UI\n\
- \032 + Changed format of modification time displays, from modified at\n\
- \032 hh:mm:ss on dd MMM, yyyy to modified on yyyy-mm-dd hh:mm:ss\n\
- \032 + Changed time display to include seconds (so that people on FAT\n\
- \032 filesystems will not be confused when Unison tries to update a\n\
- \032 file time to an odd number of seconds and the filesystem\n\
- \032 truncates it to an even number!)\n\
- \032 + Use the diff \"-u\" option by default when showing differences\n\
- \032 between files (the output is more readable)\n\
- \032 + In text mode, pipe the diff output to a pager if the\n\
- \032 environment variable PAGER is set\n\
- \032 + Bug fixes and cleanups in ssh password prompting. Now works\n\
- \032 with the GTK2 UI under Linux. (Hopefully the Mac OS X one is\n\
- \032 not broken!)\n\
- \032 + Include profile name in the GTK2 window name\n\
- \032 + Added bindings ',' (same as '<') and '.' (same as '>') in the\n\
- \032 GTK2 UI\n\
- \032 * Mac GUI:\n\
- \032 + actions like < and > scroll to the next item as necessary.\n\
- \032 + Restart has a menu item and keyboard shortcut (command-R).\n\
- \032 + Added a command-line tool for Mac OS X. It can be installed\n\
- \032 from the Unison menu.\n\
- \032 + New icon.\n\
- \032 + Handle the \"help\" command-line argument properly.\n\
- \032 + Handle profiles given on the command line properly.\n\
- \032 + When a profile has been selected, the profile dialog is\n\
- \032 replaced by a \"connecting\" message while the connection is\n\
- \032 being made. This gives better feedback.\n\
- \032 + Size of left and right columns is now large enough so that\n\
- \032 \"PropsChanged\" is not cut off.\n\
- \032 * Minor changes:\n\
- \032 + Disable multi-threading when both roots are local\n\
- \032 + Improved error handling code. In particular, make sure all\n\
- \032 files are closed in case of a transient failure\n\
- \032 + Under Windows, use $UNISON for home directory as a last resort\n\
- \032 (it was wrongly moved before $HOME and $USERPROFILE in Unison\n\
- \032 2.12.0)\n\
- \032 + Reopen the logfile if its name changes (profile change)\n\
- \032 + Double-check that permissions and modification times have been\n\
- \032 properly set: there are some combination of OS and filesystem\n\
- \032 on which setting them can fail in a silent way.\n\
- \032 + Check for bad Windows filenames for pure Windows\n\
- \032 synchronization also (not just cross architecture\n\
- \032 synchronization). This way, filenames containing backslashes,\n\
- \032 which are not correctly handled by unison, are rejected right\n\
- \032 away.\n\
- \032 + Attempt to resolve issues with synchronizing modification\n\
- \032 times of read-only files under Windows\n\
- \032 + Ignore chmod failures when deleting files\n\
- \032 + Ignore trailing dots in filenames in case insensitive mode\n\
- \032 + Proper quoting of paths, files and extensions ignored using\n\
- \032 the UI\n\
- \032 + The strings CURRENT1 and CURRENT2 are now correctly substitued\n\
- \032 when they occur in the diff preference\n\
- \032 + Improvements to syncing resource forks between Macs via a\n\
- \032 non-Mac system.\n\
- \n\
- \032 Changes since 2.10.2:\n\
- \032 * INCOMPATIBLE CHANGE: Archive format has changed.\n\
- \032 * Source code availability: The Unison sources are now managed using\n\
- \032 Subversion. One nice side-effect is that anonymous checkout is now\n\
- \032 possible, like this:\n\
- \032 svn co https://cvs.cis.upenn.edu:3690/svnroot/unison/\n\
- \n\
- \032 We will also continue to export a \"developer tarball\" of the\n\
- \032 current (modulo one day) sources in the web export directory. To\n\
- \032 receive commit logs for changes to the sources, subscribe to the\n\
- \032 unison-hackers list (http://www.cis.upenn.edu/\n\
- \032 bcpierce/unison/lists.html).\n\
- \032 * Text user interface:\n\
- \032 + Substantial reworking of the internal logic of the text UI to\n\
- \032 make it a bit easier to modify.\n\
- \032 + The dumbtty flag in the text UI is automatically set to true\n\
- \032 if the client is running on a Unix system and the EMACS\n\
- \032 environment variable is set to anything other than the empty\n\
- \032 string.\n\
- \032 * Native OS X gui:\n\
- \032 + Added a synchronize menu item with keyboard shortcut\n\
- \032 + Added a merge menu item, still needs to be debugged\n\
- \032 + Fixes to compile for Panther\n\
- \032 + Miscellaneous improvements and bugfixes\n\
- \032 * Small changes:\n\
- \032 + Changed the filename checking code to apply to Windows only,\n\
- \032 instead of OS X as well.\n\
- \032 + Finder flags now synchronized\n\
- \032 + Fallback in copy.ml for filesystem that do not support O_EXCL\n\
- \032 + Changed buffer size for local file copy (was highly\n\
- \032 inefficient with synchronous writes)\n\
- \032 + Ignore chmod failure when deleting a directory\n\
- \032 + Fixed assertion failure when resolving a conflict content\n\
- \032 change / permission changes in favor of the content change.\n\
- \032 + Workaround for transferring large files using rsync.\n\
- \032 + Use buffered I/O for files (this is the only way to open files\n\
- \032 in binary mode under Cygwin).\n\
- \032 + On non-Cygwin Windows systems, the UNISON environment variable\n\
- \032 is now checked first to determine where to look for Unison's\n\
- \032 archive and preference files, followed by HOME and USERPROFILE\n\
- \032 in that order. On Unix and Cygwin systems, HOME is used.\n\
- \032 + Generalized diff preference so that it can be given either as\n\
- \032 just the command name to be used for calculating diffs or else\n\
- \032 a whole command line, containing the strings CURRENT1 and\n\
- \032 CURRENT2, which will be replaced by the names of the files to\n\
- \032 be diff'ed before the command is called.\n\
- \032 + Recognize password prompts in some newer versions of ssh.\n\
- \n\
- \032 Changes since 2.9.20:\n\
- \032 * INCOMPATIBLE CHANGE: Archive format has changed.\n\
- \032 * Major functionality changes:\n\
- \032 + Major tidying and enhancement of 'merge' functionality. The\n\
- \032 main user-visible change is that the external merge program\n\
- \032 may either write the merged output to a single new file, as\n\
- \032 before, or it may modify one or both of its input files, or it\n\
- \032 may write two new files. In the latter cases, its\n\
- \032 modifications will be copied back into place on both the local\n\
- \032 and the remote host, and (if the two files are now equal) the\n\
- \032 archive will be updated appropriately. More information can be\n\
- \032 found in the user manual. Thanks to Malo Denielou and Alan\n\
- \032 Schmitt for these improvements.\n\
- \032 Warning: the new merging functionality is not completely\n\
- \032 compatible with old versions! Check the manual for details.\n\
- \032 + Files larger than 2Gb are now supported.\n\
- \032 + Added preliminary (and still somewhat experimental) support\n\
- \032 for the Apple OS X operating system.\n\
- \032 o Resource forks should be transferred correctly. (See the\n\
- \032 manual for details of how this works when synchronizing\n\
- \032 HFS with non-HFS volumes.) Synchronization of file type\n\
- \032 and creator information is also supported.\n\
- \032 o On OSX systems, the name of the directory for storing\n\
- \032 Unison's archives, preference files, etc., is now\n\
- \032 determined as follows:\n\
- \032 # if ~/.unison exists, use it\n\
- \032 # otherwise, use ~/Library/Application Support/Unison,\n\
- \032 creating it if necessary.\n\
- \032 o A preliminary native-Cocoa user interface is under\n\
- \032 construction. This still needs some work, and some users\n\
- \032 experience unpredictable crashes, so it is only for\n\
- \032 hackers for now. Run make with UISTYLE=mac to build this\n\
- \032 interface.\n\
- \032 * Minor functionality changes:\n\
- \032 + Added an ignorelocks preference, which forces Unison to\n\
- \032 override left-over archive locks. (Setting this preference is\n\
- \032 dangerous! Use it only if you are positive you know what you\n\
- \032 are doing.)\n\
- \032 + Added a new preference assumeContentsAreImmutable. If a\n\
- \032 directory matches one of the patterns set in this preference,\n\
- \032 then update detection is skipped for files in this directory.\n\
- \032 (The purpose is to speed update detection for cases like Mail\n\
- \032 folders, which contain lots and lots of immutable files.) Also\n\
- \032 a preference assumeContentsAreImmutableNot, which overrides\n\
- \032 the first, similarly to ignorenot. (Later amendment: these\n\
- \032 preferences are now called immutable and immutablenot.)\n\
- \032 + The ignorecase flag has been changed from a boolean to a\n\
- \032 three-valued preference. The default setting, called default,\n\
- \032 checks the operating systems running on the client and server\n\
- \032 and ignores filename case if either of them is OSX or Windows.\n\
- \032 Setting ignorecase to true or false overrides this behavior.\n\
- \032 If you have been setting ignorecase on the command line using\n\
- \032 -ignorecase=true or -ignorecase=false, you will need to change\n\
- \032 to -ignorecase true or -ignorecase false.\n\
- \032 + a new preference, 'repeat', for the text user interface\n\
- \032 (only). If 'repeat' is set to a number, then, after it\n\
- \032 finishes synchronizing, Unison will wait for that many seconds\n\
- \032 and then start over, continuing this way until it is killed\n\
- \032 from outside. Setting repeat to true will automatically set\n\
- \032 the batch preference to true.\n\
- \032 + Excel files are now handled specially, so that the fastcheck\n\
- \032 optimization is skipped even if the fastcheck flag is set.\n\
- \032 (Excel does some naughty things with modtimes, making this\n\
- \032 optimization unreliable and leading to failures during change\n\
- \032 propagation.)\n\
- \032 + The ignorecase flag has been changed from a boolean to a\n\
- \032 three-valued preference. The default setting, called\n\
- \032 'default', checks the operating systems running on the client\n\
- \032 and server and ignores filename case if either of them is OSX\n\
- \032 or Windows. Setting ignorecase to 'true' or 'false' overrides\n\
- \032 this behavior.\n\
- \032 + Added a new preference, 'repeat', for the text user interface\n\
- \032 (only, at the moment). If 'repeat' is set to a number, then,\n\
- \032 after it finishes synchronizing, Unison will wait for that\n\
- \032 many seconds and then start over, continuing this way until it\n\
- \032 is killed from outside. Setting repeat to true will\n\
- \032 automatically set the batch preference to true.\n\
- \032 + The 'rshargs' preference has been split into 'rshargs' and\n\
- \032 'sshargs' (mainly to make the documentation clearer). In fact,\n\
- \032 'rshargs' is no longer mentioned in the documentation at all,\n\
- \032 since pretty much everybody uses ssh now anyway.\n\
- \032 * Documentation\n\
- \032 + The web pages have been completely redesigned and reorganized.\n\
- \032 (Thanks to Alan Schmitt for help with this.)\n\
- \032 * User interface improvements\n\
- \032 + Added a GTK2 user interface, capable (among other things) of\n\
- \032 displaying filenames in any locale encoding. Kudos to Stephen\n\
- \032 Tse for contributing this code!\n\
- \032 + The text UI now prints a list of failed and skipped transfers\n\
- \032 at the end of synchronization.\n\
- \032 + Restarting update detection from the graphical UI will reload\n\
- \032 the current profile (which in particular will reset the -path\n\
- \032 preference, in case it has been narrowed by using the \"Recheck\n\
- \032 unsynchronized items\" command).\n\
- \032 + Several small improvements to the text user interface,\n\
- \032 including a progress display.\n\
- \032 * Bug fixes (too numerous to count, actually, but here are some):\n\
- \032 + The maxthreads preference works now.\n\
- \032 + Fixed bug where warning message about uname returning an\n\
- \032 unrecognized result was preventing connection to server. (The\n\
- \032 warning is no longer printed, and all systems where 'uname'\n\
- \032 returns anything other than 'Darwin' are assumed not to be\n\
- \032 running OS X.)\n\
- \032 + Fixed a problem on OS X that caused some valid file names\n\
- \032 (e.g., those including colons) to be considered invalid.\n\
- \032 + Patched Path.followLink to follow links under cygwin in\n\
- \032 addition to Unix (suggested by Matt Swift).\n\
- \032 + Small change to the storeRootsName function, suggested by\n\
- \032 bliviero at ichips.intel.com, to fix a problem in unison with\n\
- \032 the `rootalias' option, which allows you to tell unison that\n\
- \032 two roots contain the same files. Rootalias was being applied\n\
- \032 after the hosts were sorted, so it wouldn't work properly in\n\
- \032 all cases.\n\
- \032 + Incorporated a fix by Dmitry Bely for setting utimes of\n\
- \032 read-only files on Win32 systems.\n\
- \032 * Installation / portability:\n\
- \032 + Unison now compiles with OCaml version 3.07 and later out of\n\
- \032 the box.\n\
- \032 + Makefile.OCaml fixed to compile out of the box under OpenBSD.\n\
- \032 + a few additional ports (e.g. OpenBSD, Zaurus/IPAQ) are now\n\
- \032 mentioned in the documentation\n\
- \032 + Unison can now be installed easily on OSX systems using the\n\
- \032 Fink package manager\n\
- \n\
- \032 Changes since 2.9.1:\n\
- \032 * Added a preference maxthreads that can be used to limit the number\n\
- \032 of simultaneous file transfers.\n\
- \032 * Added a backupdir preference, which controls where backup files are\n\
- \032 stored.\n\
- \032 * Basic support added for OSX. In particular, Unison now recognizes\n\
- \032 when one of the hosts being synchronized is running OSX and\n\
- \032 switches to a case-insensitive treatment of filenames (i.e., 'foo'\n\
- \032 and 'FOO' are considered to be the same file). (OSX is not yet\n\
- \032 fully working, however: in particular, files with resource forks\n\
- \032 will not be synchronized correctly.)\n\
- \032 * The same hash used to form the archive name is now also added to\n\
- \032 the names of the temp files created during file transfer. The\n\
- \032 reason for this is that, during update detection, we are going to\n\
- \032 silently delete any old temp files that we find along the way, and\n\
- \032 we want to prevent ourselves from deleting temp files belonging to\n\
- \032 other instances of Unison that may be running in parallel, e.g.\n\
- \032 synchronizing with a different host. Thanks to Ruslan Ermilov for\n\
- \032 this suggestion.\n\
- \032 * Several small user interface improvements\n\
- \032 * Documentation\n\
- \032 + FAQ and bug reporting instructions have been split out as\n\
- \032 separate HTML pages, accessible directly from the unison web\n\
- \032 page.\n\
- \032 + Additions to FAQ, in particular suggestions about performance\n\
- \032 tuning.\n\
- \032 * Makefile\n\
- \032 + Makefile.OCaml now sets UISTYLE=text or UISTYLE=gtk\n\
- \032 automatically, depending on whether it finds lablgtk installed\n\
- \032 + Unison should now compile \"out of the box\" under OSX\n\
- \n\
- \032 Changes since 2.8.1:\n\
- \032 * Changing profile works again under Windows\n\
- \032 * File movement optimization: Unison now tries to use local copy\n\
- \032 instead of transfer for moved or copied files. It is controlled by\n\
- \032 a boolean option \"xferbycopying\".\n\
- \032 * Network statistics window (transfer rate, amount of data\n\
- \032 transferred). [NB: not available in Windows-Cygwin version.]\n\
- \032 * symlinks work under the cygwin version (which is dynamically\n\
- \032 linked).\n\
- \032 * Fixed potential deadlock when synchronizing between Windows and\n\
- \032 Unix\n\
- \032 * Small improvements:\n\
- \032 + If neither the USERPROFILE nor the HOME environment variables\n\
- \032 are set, then Unison will put its temporary commit log (called\n\
- \032 DANGER.README) into the directory named by the UNISON\n\
- \032 environment variable, if any; otherwise it will use C:.\n\
- \032 + alternative set of values for fastcheck: yes = true; no =\n\
- \032 false; default = auto.\n\
- \032 + -silent implies -contactquietly\n\
- \032 * Source code:\n\
- \032 + Code reorganization and tidying. (Started breaking up some of\n\
- \032 the basic utility modules so that the non-unison-specific\n\
- \032 stuff can be made available for other projects.)\n\
- \032 + several Makefile and docs changes (for release);\n\
- \032 + further comments in \"update.ml\";\n\
- \032 + connection information is not stored in global variables\n\
- \032 anymore.\n\
- \n\
- \032 Changes since 2.7.78:\n\
- \032 * Small bugfix to textual user interface under Unix (to avoid leaving\n\
- \032 the terminal in a bad state where it would not echo inputs after\n\
- \032 Unison exited).\n\
- \n\
- \032 Changes since 2.7.39:\n\
- \032 * Improvements to the main web page (stable and beta version docs are\n\
- \032 now both accessible).\n\
- \032 * User manual revised.\n\
- \032 * Added some new preferences:\n\
- \032 + \"sshcmd\" and \"rshcmd\" for specifying paths to ssh and rsh\n\
- \032 programs.\n\
- \032 + \"contactquietly\" for suppressing the \"contacting server\"\n\
- \032 message during Unison startup (under the graphical UI).\n\
- \032 * Bug fixes:\n\
- \032 + Fixed small bug in UI that neglected to change the displayed\n\
- \032 column headers if loading a new profile caused the roots to\n\
- \032 change.\n\
- \032 + Fixed a bug that would put the text UI into an infinite loop\n\
- \032 if it encountered a conflict when run in batch mode.\n\
- \032 + Added some code to try to fix the display of non-Ascii\n\
- \032 characters in filenames on Windows systems in the GTK UI.\n\
- \032 (This code is currently untested--if you're one of the people\n\
- \032 that had reported problems with display of non-ascii\n\
- \032 filenames, we'd appreciate knowing if this actually fixes\n\
- \032 things.)\n\
- \032 + `-prefer/-force newer' works properly now. (The bug was\n\
- \032 reported by Sebastian Urbaniak and Sean Fulton.)\n\
- \032 * User interface and Unison behavior:\n\
- \032 + Renamed `Proceed' to `Go' in the graphical UI.\n\
- \032 + Added exit status for the textual user interface.\n\
- \032 + Paths that are not synchronized because of conflicts or errors\n\
- \032 during update detection are now noted in the log file.\n\
- \032 + [END] messages in log now use a briefer format\n\
- \032 + Changed the text UI startup sequence so that ./unison -ui text\n\
- \032 will use the default profile instead of failing.\n\
- \032 + Made some improvements to the error messages.\n\
- \032 + Added some debugging messages to remote.ml.\n\
- \n\
- \032 Changes since 2.7.7:\n\
- \032 * Incorporated, once again, a multi-threaded transport sub-system. It\n\
- \032 transfers several files at the same time, thereby making much more\n\
- \032 effective use of available network bandwidth. Unlike the earlier\n\
- \032 attempt, this time we do not rely on the native thread library of\n\
- \032 OCaml. Instead, we implement a light-weight, non-preemptive\n\
- \032 multi-thread library in OCaml directly. This version appears\n\
- \032 stable.\n\
- \032 Some adjustments to unison are made to accommodate the\n\
- \032 multi-threaded version. These include, in particular, changes to\n\
- \032 the user interface and logging, for example:\n\
- \032 + Two log entries for each transferring task, one for the\n\
- \032 beginning, one for the end.\n\
- \032 + Suppressed warning messages against removing temp files left\n\
- \032 by a previous unison run, because warning does not work nicely\n\
- \032 under multi-threading. The temp file names are made less\n\
- \032 likely to coincide with the name of a file created by the\n\
- \032 user. They take the form\n\
- \032 .#<filename>.<serial>.unison.tmp. [N.b. This was later changed\n\
- \032 to .unison.<filename>.<serial>.unison.tmp.]\n\
- \032 * Added a new command to the GTK user interface: pressing 'f' causes\n\
- \032 Unison to start a new update detection phase, using as paths just\n\
- \032 those paths that have been detected as changed and not yet marked\n\
- \032 as successfully completed. Use this command to quickly restart\n\
- \032 Unison on just the set of paths still needing attention after a\n\
- \032 previous run.\n\
- \032 * Made the ignorecase preference user-visible, and changed the\n\
- \032 initialization code so that it can be manually set to true, even if\n\
- \032 neither host is running Windows. (This may be useful, e.g., when\n\
- \032 using Unison running on a Unix system with a FAT volume mounted.)\n\
- \032 * Small improvements and bug fixes:\n\
- \032 + Errors in preference files now generate fatal errors rather\n\
- \032 than warnings at startup time. (I.e., you can't go on from\n\
- \032 them.) Also, we fixed a bug that was preventing these warnings\n\
- \032 from appearing in the text UI, so some users who have been\n\
- \032 running (unsuspectingly) with garbage in their prefs files may\n\
- \032 now get error reports.\n\
- \032 + Error reporting for preference files now provides file name\n\
- \032 and line number.\n\
- \032 + More intelligible message in the case of identical change to\n\
- \032 the same files: \"Nothing to do: replicas have been changed\n\
- \032 only in identical ways since last sync.\"\n\
- \032 + Files with prefix '.#' excluded when scanning for preference\n\
- \032 files.\n\
- \032 + Rsync instructions are send directly instead of first\n\
- \032 marshaled.\n\
- \032 + Won't try forever to get the fingerprint of a continuously\n\
- \032 changing file: unison will give up after certain number of\n\
- \032 retries.\n\
- \032 + Other bug fixes, including the one reported by Peter Selinger\n\
- \032 (force=older preference not working).\n\
- \032 * Compilation:\n\
- \032 + Upgraded to the new OCaml 3.04 compiler, with the LablGtk\n\
- \032 1.2.3 library (patched version used for compiling under\n\
- \032 Windows).\n\
- \032 + Added the option to compile unison on the Windows platform\n\
- \032 with Cygwin GNU C compiler. This option only supports building\n\
- \032 dynamically linked unison executables.\n\
- \n\
- \032 Changes since 2.7.4:\n\
- \032 * Fixed a silly (but debilitating) bug in the client startup\n\
- \032 sequence.\n\
- \n\
- \032 Changes since 2.7.1:\n\
- \032 * Added addprefsto preference, which (when set) controls which\n\
- \032 preference file new preferences (e.g. new ignore patterns) are\n\
- \032 added to.\n\
- \032 * Bug fix: read the initial connection header one byte at a time, so\n\
- \032 that we don't block if the header is shorter than expected. (This\n\
- \032 bug did not affect normal operation -- it just made it hard to tell\n\
- \032 when you were trying to use Unison incorrectly with an old version\n\
- \032 of the server, since it would hang instead of giving an error\n\
- \032 message.)\n\
- \n\
- \032 Changes since 2.6.59:\n\
- \032 * Changed fastcheck from a boolean to a string preference. Its legal\n\
- \032 values are yes (for a fast check), no (for a safe check), or\n\
- \032 default (for a fast check--which also happens to be safe--when\n\
- \032 running on Unix and a safe check when on Windows). The default is\n\
- \032 default.\n\
- \032 * Several preferences have been renamed for consistency. All\n\
- \032 preference names are now spelled out in lowercase. For backward\n\
- \032 compatibility, the old names still work, but they are not mentioned\n\
- \032 in the manual any more.\n\
- \032 * The temp files created by the 'diff' and 'merge' commands are now\n\
- \032 named by prepending a new prefix to the file name, rather than\n\
- \032 appending a suffix. This should avoid confusing diff/merge programs\n\
- \032 that depend on the suffix to guess the type of the file contents.\n\
- \032 * We now set the keepalive option on the server socket, to make sure\n\
- \032 that the server times out if the communication link is unexpectedly\n\
- \032 broken.\n\
- \032 * Bug fixes:\n\
- \032 + When updating small files, Unison now closes the destination\n\
- \032 file.\n\
- \032 + File permissions are properly updated when the file is behind\n\
- \032 a followed link.\n\
- \032 + Several other small fixes.\n\
- \n\
- \032 Changes since 2.6.38:\n\
- \032 * Major Windows performance improvement!\n\
- \032 We've added a preference fastcheck that makes Unison look only at a\n\
- \032 file's creation time and last-modified time to check whether it has\n\
- \032 changed. This should result in a huge speedup when checking for\n\
- \032 updates in large replicas.\n\
- \032 When this switch is set, Unison will use file creation times as\n\
- \032 'pseudo inode numbers' when scanning Windows replicas for updates,\n\
- \032 instead of reading the full contents of every file. This may cause\n\
- \032 Unison to miss propagating an update if the create time,\n\
- \032 modification time, and length of the file are all unchanged by the\n\
- \032 update (this is not easy to achieve, but it can be done). However,\n\
- \032 Unison will never overwrite such an update with a change from the\n\
- \032 other replica, since it always does a safe check for updates just\n\
- \032 before propagating a change. Thus, it is reasonable to use this\n\
- \032 switch most of the time and occasionally run Unison once with\n\
- \032 fastcheck set to false, if you are worried that Unison may have\n\
- \032 overlooked an update.\n\
- \032 Warning: This change is has not yet been thoroughly field-tested.\n\
- \032 If you set the fastcheck preference, pay careful attention to what\n\
- \032 Unison is doing.\n\
- \032 * New functionality: centralized backups and merging\n\
- \032 + This version incorporates two pieces of major new\n\
- \032 functionality, implemented by Sylvain Roy during a summer\n\
- \032 internship at Penn: a centralized backup facility that keeps a\n\
- \032 full backup of (selected files in) each replica, and a merging\n\
- \032 feature that allows Unison to invoke an external file-merging\n\
- \032 tool to resolve conflicting changes to individual files.\n\
- \032 + Centralized backups:\n\
- \032 o Unison now maintains full backups of the\n\
- \032 last-synchronized versions of (some of) the files in each\n\
- \032 replica; these function both as backups in the usual\n\
- \032 sense and as the \"common version\" when invoking external\n\
- \032 merge programs.\n\
- \032 o The backed up files are stored in a directory\n\
- \032 /.unison/backup on each host. (The name of this directory\n\
- \032 can be changed by setting the environment variable\n\
- \032 UNISONBACKUPDIR.)\n\
- \032 o The predicate backup controls which files are actually\n\
- \032 backed up: giving the preference 'backup = Path *' causes\n\
- \032 backing up of all files.\n\
- \032 o Files are added to the backup directory whenever unison\n\
- \032 updates its archive. This means that\n\
- \032 # When unison reconstructs its archive from scratch\n\
- \032 (e.g., because of an upgrade, or because the archive\n\
- \032 files have been manually deleted), all files will be\n\
- \032 backed up.\n\
- \032 # Otherwise, each file will be backed up the first\n\
- \032 time unison propagates an update for it.\n\
- \032 o The preference backupversions controls how many previous\n\
- \032 versions of each file are kept. The default is 2 (i.e.,\n\
- \032 the last synchronized version plus one backup).\n\
- \032 o For backward compatibility, the backups preference is\n\
- \032 also still supported, but backup is now preferred.\n\
- \032 o It is OK to manually delete files from the backup\n\
- \032 directory (or to throw away the directory itself). Before\n\
- \032 unison uses any of these files for anything important, it\n\
- \032 checks that its fingerprint matches the one that it\n\
- \032 expects.\n\
- \032 + Merging:\n\
- \032 o Both user interfaces offer a new 'merge' command, invoked\n\
- \032 by pressing 'm' (with a changed file selected).\n\
- \032 o The actual merging is performed by an external program.\n\
- \032 The preferences merge and merge2 control how this program\n\
- \032 is invoked. If a backup exists for this file (see the\n\
- \032 backup preference), then the merge preference is used for\n\
- \032 this purpose; otherwise merge2 is used. In both cases,\n\
- \032 the value of the preference should be a string\n\
- \032 representing the command that should be passed to a shell\n\
- \032 to invoke the merge program. Within this string, the\n\
- \032 special substrings CURRENT1, CURRENT2, NEW, and OLD may\n\
- \032 appear at any point. Unison will substitute these as\n\
- \032 follows before invoking the command:\n\
- \032 # CURRENT1 is replaced by the name of the local copy\n\
- \032 of the file;\n\
- \032 # CURRENT2 is replaced by the name of a temporary\n\
- \032 file, into which the contents of the remote copy of\n\
- \032 the file have been transferred by Unison prior to\n\
- \032 performing the merge;\n\
- \032 # NEW is replaced by the name of a temporary file that\n\
- \032 Unison expects to be written by the merge program\n\
- \032 when it finishes, giving the desired new contents of\n\
- \032 the file; and\n\
- \032 # OLD is replaced by the name of the backed up copy of\n\
- \032 the original version of the file (i.e., its state at\n\
- \032 the end of the last successful run of Unison), if\n\
- \032 one exists (applies only to merge, not merge2).\n\
- \032 For example, on Unix systems setting the merge preference\n\
- \032 to\n\
- \032 merge = diff3 -m CURRENT1 OLD CURRENT2 > NEW\n\
- \n\
- \032 will tell Unison to use the external diff3 program for\n\
- \032 merging.\n\
- \032 A large number of external merging programs are\n\
- \032 available. For example, emacs users may find the\n\
- \032 following convenient:\n\
- \032 merge2 = emacs -q --eval '(ediff-merge-files \"CURRENT1\" \"CURRENT2\"\n\
- \032 nil \"NEW\")'\n\
- \032 merge = emacs -q --eval '(ediff-merge-files-with-ancestor\n\
- \032 \"CURRENT1\" \"CURRENT2\" \"OLD\" nil \"NEW\")'\n\
- \n\
- \032 (These commands are displayed here on two lines to avoid\n\
- \032 running off the edge of the page. In your preference\n\
- \032 file, each should be written on a single line.)\n\
- \032 o If the external program exits without leaving any file at\n\
- \032 the path NEW, Unison considers the merge to have failed.\n\
- \032 If the merge program writes a file called NEW but exits\n\
- \032 with a non-zero status code, then Unison considers the\n\
- \032 merge to have succeeded but to have generated conflicts.\n\
- \032 In this case, it attempts to invoke an external editor so\n\
- \032 that the user can resolve the conflicts. The value of the\n\
- \032 editor preference controls what editor is invoked by\n\
- \032 Unison. The default is emacs.\n\
- \032 o Please send us suggestions for other useful values of the\n\
- \032 merge2 and merge preferences - we'd like to give several\n\
- \032 examples in the manual.\n\
- \032 * Smaller changes:\n\
- \032 + When one preference file includes another, unison no longer\n\
- \032 adds the suffix '.prf' to the included file by default. If a\n\
- \032 file with precisely the given name exists in the .unison\n\
- \032 directory, it will be used; otherwise Unison will add .prf, as\n\
- \032 it did before. (This change means that included preference\n\
- \032 files can be named blah.include instead of blah.prf, so that\n\
- \032 unison will not offer them in its 'choose a preference file'\n\
- \032 dialog.)\n\
- \032 + For Linux systems, we now offer both a statically linked and a\n\
- \032 dynamically linked executable. The static one is larger, but\n\
- \032 will probably run on more systems, since it doesn't depend on\n\
- \032 the same versions of dynamically linked library modules being\n\
- \032 available.\n\
- \032 + Fixed the force and prefer preferences, which were getting the\n\
- \032 propagation direction exactly backwards.\n\
- \032 + Fixed a bug in the startup code that would cause unison to\n\
- \032 crash when the default profile (~/.unison/default.prf) does\n\
- \032 not exist.\n\
- \032 + Fixed a bug where, on the run when a profile is first created,\n\
- \032 Unison would confusingly display the roots in reverse order in\n\
- \032 the user interface.\n\
- \032 * For developers:\n\
- \032 + We've added a module dependency diagram to the source\n\
- \032 distribution, in src/DEPENDENCIES.ps, to help new prospective\n\
- \032 developers with navigating the code.\n\
- \n\
- \032 Changes since 2.6.11:\n\
- \032 * INCOMPATIBLE CHANGE: Archive format has changed.\n\
- \032 * INCOMPATIBLE CHANGE: The startup sequence has been completely\n\
- \032 rewritten and greatly simplified. The main user-visible change is\n\
- \032 that the defaultpath preference has been removed. Its effect can be\n\
- \032 approximated by using multiple profiles, with include directives to\n\
- \032 incorporate common settings. All uses of defaultpath in existing\n\
- \032 profiles should be changed to path.\n\
- \032 Another change in startup behavior that will affect some users is\n\
- \032 that it is no longer possible to specify roots both in the profile\n\
- \032 and on the command line.\n\
- \032 You can achieve a similar effect, though, by breaking your profile\n\
- \032 into two:\n\
- \032 default.prf =\n\
- \032 root = blah\n\
- \032 root = foo\n\
- \032 include common\n\
- \n\
- \032 common.prf =\n\
- \032 <everything else>\n\
- \n\
- \032 Now do\n\
- \032 unison common root1 root2\n\
- \n\
- \032 when you want to specify roots explicitly.\n\
- \032 * The -prefer and -force options have been extended to allow users to\n\
- \032 specify that files with more recent modtimes should be propagated,\n\
- \032 writing either -prefer newer or -force newer. (For symmetry, Unison\n\
- \032 will also accept -prefer older or -force older.) The -force\n\
- \032 older/newer options can only be used when -times is also set.\n\
- \032 The graphical user interface provides access to these facilities on\n\
- \032 a one-off basis via the Actions menu.\n\
- \032 * Names of roots can now be \"aliased\" to allow replicas to be\n\
- \032 relocated without changing the name of the archive file where\n\
- \032 Unison stores information between runs. (This feature is for\n\
- \032 experts only. See the \"Archive Files\" section of the manual for\n\
- \032 more information.)\n\
- \032 * Graphical user-interface:\n\
- \032 + A new command is provided in the Synchronization menu for\n\
- \032 switching to a new profile without restarting Unison from\n\
- \032 scratch.\n\
- \032 + The GUI also supports one-key shortcuts for commonly used\n\
- \032 profiles. If a profile contains a preference of the form 'key\n\
- \032 = n', where n is a single digit, then pressing this key will\n\
- \032 cause Unison to immediately switch to this profile and begin\n\
- \032 synchronization again from scratch. (Any actions that may have\n\
- \032 been selected for a set of changes currently being displayed\n\
- \032 will be discarded.)\n\
- \032 + Each profile may include a preference 'label = <string>'\n\
- \032 giving a descriptive string that described the options\n\
- \032 selected in this profile. The string is listed along with the\n\
- \032 profile name in the profile selection dialog, and displayed in\n\
- \032 the top-right corner of the main Unison window.\n\
- \032 * Minor:\n\
- \032 + Fixed a bug that would sometimes cause the 'diff' display to\n\
- \032 order the files backwards relative to the main user interface.\n\
- \032 (Thanks to Pascal Brisset for this fix.)\n\
- \032 + On Unix systems, the graphical version of Unison will check\n\
- \032 the DISPLAY variable and, if it is not set, automatically fall\n\
- \032 back to the textual user interface.\n\
- \032 + Synchronization paths (path preferences) are now matched\n\
- \032 against the ignore preferences. So if a path is both specified\n\
- \032 in a path preference and ignored, it will be skipped.\n\
- \032 + Numerous other bugfixes and small improvements.\n\
- \n\
- \032 Changes since 2.6.1:\n\
- \032 * The synchronization of modification times has been disabled for\n\
- \032 directories.\n\
- \032 * Preference files may now include lines of the form include <name>,\n\
- \032 which will cause name.prf to be read at that point.\n\
- \032 * The synchronization of permission between Windows and Unix now\n\
- \032 works properly.\n\
- \032 * A binding CYGWIN=binmode in now added to the environment so that\n\
- \032 the Cygwin port of OpenSSH works properly in a non-Cygwin context.\n\
- \032 * The servercmd and addversionno preferences can now be used\n\
- \032 together: -addversionno appends an appropriate -NNN to the server\n\
- \032 command, which is found by using the value of the -servercmd\n\
- \032 preference if there is one, or else just unison.\n\
- \032 * Both '-pref=val' and '-pref val' are now allowed for boolean\n\
- \032 values. (The former can be used to set a preference to false.)\n\
- \032 * Lot of small bugs fixed.\n\
- \n\
- \032 Changes since 2.5.31:\n\
- \032 * The log preference is now set to true by default, since the log\n\
- \032 file seems useful for most users.\n\
- \032 * Several miscellaneous bugfixes (most involving symlinks).\n\
- \n\
- \032 Changes since 2.5.25:\n\
- \032 * INCOMPATIBLE CHANGE: Archive format has changed (again).\n\
- \032 * Several significant bugs introduced in 2.5.25 have been fixed.\n\
- \n\
- \032 Changes since 2.5.1:\n\
- \032 * INCOMPATIBLE CHANGE: Archive format has changed. Make sure you\n\
- \032 synchronize your replicas before upgrading, to avoid spurious\n\
- \032 conflicts. The first sync after upgrading will be slow.\n\
- \032 * New functionality:\n\
- \032 + Unison now synchronizes file modtimes, user-ids, and\n\
- \032 group-ids.\n\
- \032 These new features are controlled by a set of new preferences,\n\
- \032 all of which are currently false by default.\n\
- \032 o When the times preference is set to true, file\n\
- \032 modification times are propaged. (Because the\n\
- \032 representations of time may not have the same granularity\n\
- \032 on both replicas, Unison may not always be able to make\n\
- \032 the modtimes precisely equal, but it will get them as\n\
- \032 close as the operating systems involved allow.)\n\
- \032 o When the owner preference is set to true, file ownership\n\
- \032 information is synchronized.\n\
- \032 o When the group preference is set to true, group\n\
- \032 information is synchronized.\n\
- \032 o When the numericIds preference is set to true, owner and\n\
- \032 group information is synchronized numerically. By\n\
- \032 default, owner and group numbers are converted to names\n\
- \032 on each replica and these names are synchronized. (The\n\
- \032 special user id 0 and the special group 0 are never\n\
- \032 mapped via user/group names even if this preference is\n\
- \032 not set.)\n\
- \032 + Added an integer-valued preference perms that can be used to\n\
- \032 control the propagation of permission bits. The value of this\n\
- \032 preference is a mask indicating which permission bits should\n\
- \032 be synchronized. It is set by default to 0o1777: all bits but\n\
- \032 the set-uid and set-gid bits are synchronised (synchronizing\n\
- \032 theses latter bits can be a security hazard). If you want to\n\
- \032 synchronize all bits, you can set the value of this preference\n\
- \032 to -1.\n\
- \032 + Added a log preference (default false), which makes Unison\n\
- \032 keep a complete record of the changes it makes to the\n\
- \032 replicas. By default, this record is written to a file called\n\
- \032 unison.log in the user's home directory (the value of the HOME\n\
- \032 environment variable). If you want it someplace else, set the\n\
- \032 logfile preference to the full pathname you want Unison to\n\
- \032 use.\n\
- \032 + Added an ignorenot preference that maintains a set of patterns\n\
- \032 for paths that should definitely not be ignored, whether or\n\
- \032 not they match an ignore pattern. (That is, a path will now be\n\
- \032 ignored iff it matches an ignore pattern and does not match\n\
- \032 any ignorenot patterns.)\n\
- \032 * User-interface improvements:\n\
- \032 + Roots are now displayed in the user interface in the same\n\
- \032 order as they were given on the command line or in the\n\
- \032 preferences file.\n\
- \032 + When the batch preference is set, the graphical user interface\n\
- \032 no longer waits for user confirmation when it displays a\n\
- \032 warning message: it simply pops up an advisory window with a\n\
- \032 Dismiss button at the bottom and keeps on going.\n\
- \032 + Added a new preference for controlling how many status\n\
- \032 messages are printed during update detection: statusdepth\n\
- \032 controls the maximum depth for paths on the local machine\n\
- \032 (longer paths are not displayed, nor are non-directory paths).\n\
- \032 The value should be an integer; default is 1.\n\
- \032 + Removed the trace and silent preferences. They did not seem\n\
- \032 very useful, and there were too many preferences for\n\
- \032 controlling output in various ways.\n\
- \032 + The text UI now displays just the default command (the one\n\
- \032 that will be used if the user just types <return>) instead of\n\
- \032 all available commands. Typing ? will print the full list of\n\
- \032 possibilities.\n\
- \032 + The function that finds the canonical hostname of the local\n\
- \032 host (which is used, for example, in calculating the name of\n\
- \032 the archive file used to remember which files have been\n\
- \032 synchronized) normally uses the gethostname operating system\n\
- \032 call. However, if the environment variable UNISONLOCALHOSTNAME\n\
- \032 is set, its value will now be used instead. This makes it\n\
- \032 easier to use Unison in situations where a machine's name\n\
- \032 changes frequently (e.g., because it is a laptop and gets\n\
- \032 moved around a lot).\n\
- \032 + File owner and group are now displayed in the \"detail window\"\n\
- \032 at the bottom of the screen, when unison is configured to\n\
- \032 synchronize them.\n\
- \032 * For hackers:\n\
- \032 + Updated to Jacques Garrigue's new version of lablgtk, which\n\
- \032 means we can throw away our local patched version.\n\
- \032 If you're compiling the GTK version of unison from sources,\n\
- \032 you'll need to update your copy of lablgtk to the developers\n\
- \032 release. (Warning: installing lablgtk under Windows is\n\
- \032 currently a bit challenging.)\n\
- \032 + The TODO.txt file (in the source distribution) has been\n\
- \032 cleaned up and reorganized. The list of pending tasks should\n\
- \032 be much easier to make sense of, for people that may want to\n\
- \032 contribute their programming energies. There is also a\n\
- \032 separate file BUGS.txt for open bugs.\n\
- \032 + The Tk user interface has been removed (it was not being\n\
- \032 maintained and no longer compiles).\n\
- \032 + The debug preference now prints quite a bit of additional\n\
- \032 information that should be useful for identifying sources of\n\
- \032 problems.\n\
- \032 + The version number of the remote server is now checked right\n\
- \032 away during the connection setup handshake, rather than later.\n\
- \032 (Somebody sent a bug report of a server crash that turned out\n\
- \032 to come from using inconsistent versions: better to check this\n\
- \032 earlier and in a way that can't crash either client or\n\
- \032 server.)\n\
- \032 + Unison now runs correctly on 64-bit architectures (e.g. Alpha\n\
- \032 linux). We will not be distributing binaries for these\n\
- \032 architectures ourselves (at least for a while) but if someone\n\
- \032 would like to make them available, we'll be glad to provide a\n\
- \032 link to them.\n\
- \032 * Bug fixes:\n\
- \032 + Pattern matching (e.g. for ignore) is now case-insensitive\n\
- \032 when Unison is in case-insensitive mode (i.e., when one of the\n\
- \032 replicas is on a windows machine).\n\
- \032 + Some people had trouble with mysterious failures during\n\
- \032 propagation of updates, where files would be falsely reported\n\
- \032 as having changed during synchronization. This should be\n\
- \032 fixed.\n\
- \032 + Numerous smaller fixes.\n\
- \n\
- \032 Changes since 2.4.1:\n\
- \032 * Added a number of 'sorting modes' for the user interface. By\n\
- \032 default, conflicting changes are displayed at the top, and the rest\n\
- \032 of the entries are sorted in alphabetical order. This behavior can\n\
- \032 be changed in the following ways:\n\
- \032 + Setting the sortnewfirst preference to true causes newly\n\
- \032 created files to be displayed before changed files.\n\
- \032 + Setting sortbysize causes files to be displayed in increasing\n\
- \032 order of size.\n\
- \032 + Giving the preference sortfirst=<pattern> (where <pattern> is\n\
- \032 a path descriptor in the same format as 'ignore' and 'follow'\n\
- \032 patterns, causes paths matching this pattern to be displayed\n\
- \032 first.\n\
- \032 + Similarly, giving the preference sortlast=<pattern> causes\n\
- \032 paths matching this pattern to be displayed last.\n\
- \032 The sorting preferences are described in more detail in the user\n\
- \032 manual. The sortnewfirst and sortbysize flags can also be accessed\n\
- \032 from the 'Sort' menu in the grpahical user interface.\n\
- \032 * Added two new preferences that can be used to change unison's\n\
- \032 fundamental behavior to make it more like a mirroring tool instead\n\
- \032 of a synchronizer.\n\
- \032 + Giving the preference prefer with argument <root> (by adding\n\
- \032 -prefer <root> to the command line or prefer=<root>) to your\n\
- \032 profile) means that, if there is a conflict, the contents of\n\
- \032 <root> should be propagated to the other replica (with no\n\
- \032 questions asked). Non-conflicting changes are treated as\n\
- \032 usual.\n\
- \032 + Giving the preference force with argument <root> will make\n\
- \032 unison resolve all differences in favor of the given root,\n\
- \032 even if it was the other replica that was changed.\n\
- \032 These options should be used with care! (More information is\n\
- \032 available in the manual.)\n\
- \032 * Small changes:\n\
- \032 + Changed default answer to 'Yes' in all two-button dialogs in\n\
- \032 the graphical interface (this seems more intuitive).\n\
- \032 + The rsync preference has been removed (it was used to activate\n\
- \032 rsync compression for file transfers, but rsync compression is\n\
- \032 now enabled by default).\n\
- \032 + In the text user interface, the arrows indicating which\n\
- \032 direction changes are being propagated are printed differently\n\
- \032 when the user has overridden Unison's default recommendation\n\
- \032 (====> instead of ---->). This matches the behavior of the\n\
- \032 graphical interface, which displays such arrows in a different\n\
- \032 color.\n\
- \032 + Carriage returns (Control-M's) are ignored at the ends of\n\
- \032 lines in profiles, for Windows compatibility.\n\
- \032 + All preferences are now fully documented in the user manual.\n\
- \n\
- \032 Changes since 2.3.12:\n\
- \032 * INCOMPATIBLE CHANGE: Archive format has changed. Make sure you\n\
- \032 synchronize your replicas before upgrading, to avoid spurious\n\
- \032 conflicts. The first sync after upgrading will be slow.\n\
- \032 * New/improved functionality:\n\
- \032 + A new preference -sortbysize controls the order in which\n\
- \032 changes are displayed to the user: when it is set to true, the\n\
- \032 smallest changed files are displayed first. (The default\n\
- \032 setting is false.)\n\
- \032 + A new preference -sortnewfirst causes newly created files to\n\
- \032 be listed before other updates in the user interface.\n\
- \032 + We now allow the ssh protocol to specify a port.\n\
- \032 + Incompatible change: The unison: protocol is deprecated, and\n\
- \032 we added file: and socket:. You may have to modify your\n\
- \032 profiles in the .unison directory. If a replica is specified\n\
- \032 without an explicit protocol, we now assume it refers to a\n\
- \032 file. (Previously \"//saul/foo\" meant to use SSH to connect to\n\
- \032 saul, then access the foo directory. Now it means to access\n\
- \032 saul via a remote file mechanism such as samba; the old effect\n\
- \032 is now achieved by writing ssh://saul/foo.)\n\
- \032 + Changed the startup sequence for the case where roots are\n\
- \032 given but no profile is given on the command line. The new\n\
- \032 behavior is to use the default profile (creating it if it does\n\
- \032 not exist), and temporarily override its roots. The manual\n\
- \032 claimed that this case would work by reading no profile at\n\
- \032 all, but AFAIK this was never true.\n\
- \032 + In all user interfaces, files with conflicts are always listed\n\
- \032 first\n\
- \032 + A new preference 'sshversion' can be used to control which\n\
- \032 version of ssh should be used to connect to the server. Legal\n\
- \032 values are 1 and 2. (Default is empty, which will make unison\n\
- \032 use whatever version of ssh is installed as the default 'ssh'\n\
- \032 command.)\n\
- \032 + The situation when the permissions of a file was updated the\n\
- \032 same on both side is now handled correctly (we used to report\n\
- \032 a spurious conflict)\n\
- \032 * Improvements for the Windows version:\n\
- \032 + The fact that filenames are treated case-insensitively under\n\
- \032 Windows should now be handled correctly. The exact behavior is\n\
- \032 described in the cross-platform section of the manual.\n\
- \032 + It should be possible to synchronize with Windows shares,\n\
- \032 e.g., //host/drive/path.\n\
- \032 + Workarounds to the bug in syncing root directories in Windows.\n\
- \032 The most difficult thing to fix is an ocaml bug: Unix.opendir\n\
- \032 fails on c: in some versions of Windows.\n\
- \032 * Improvements to the GTK user interface (the Tk interface is no\n\
- \032 longer being maintained):\n\
- \032 + The UI now displays actions differently (in blue) when they\n\
- \032 have been explicitly changed by the user from Unison's default\n\
- \032 recommendation.\n\
- \032 + More colorful appearance.\n\
- \032 + The initial profile selection window works better.\n\
- \032 + If any transfers failed, a message to this effect is displayed\n\
- \032 along with 'Synchronization complete' at the end of the\n\
- \032 transfer phase (in case they may have scrolled off the top).\n\
- \032 + Added a global progress meter, displaying the percentage of\n\
- \032 total bytes that have been transferred so far.\n\
- \032 * Improvements to the text user interface:\n\
- \032 + The file details will be displayed automatically when a\n\
- \032 conflict is been detected.\n\
- \032 + when a warning is generated (e.g. for a temporary file left\n\
- \032 over from a previous run of unison) Unison will no longer wait\n\
- \032 for a response if it is running in -batch mode.\n\
- \032 + The UI now displays a short list of possible inputs each time\n\
- \032 it waits for user interaction.\n\
- \032 + The UI now quits immediately (rather than looping back and\n\
- \032 starting the interaction again) if the user presses 'q' when\n\
- \032 asked whether to propagate changes.\n\
- \032 + Pressing 'g' in the text user interface will proceed\n\
- \032 immediately with propagating updates, without asking any more\n\
- \032 questions.\n\
- \032 * Documentation and installation changes:\n\
- \032 + The manual now includes a FAQ, plus sections on common\n\
- \032 problems and on tricks contributed by users.\n\
- \032 + Both the download page and the download directory explicitly\n\
- \032 say what are the current stable and beta-test version numbers.\n\
- \032 + The OCaml sources for the up-to-the-minute developers' version\n\
- \032 (not guaranteed to be stable, or even to compile, at any given\n\
- \032 time!) are now available from the download page.\n\
- \032 + Added a subsection to the manual describing cross-platform\n\
- \032 issues (case conflicts, illegal filenames)\n\
- \032 * Many small bug fixes and random improvements.\n\
- \n\
- \032 Changes since 2.3.1:\n\
- \032 * Several bug fixes. The most important is a bug in the rsync module\n\
- \032 that would occasionally cause change propagation to fail with a\n\
- \032 'rename' error.\n\
- \n\
- \032 Changes since 2.2:\n\
- \032 * The multi-threaded transport system is now disabled by default. (It\n\
- \032 is not stable enough yet.)\n\
- \032 * Various bug fixes.\n\
- \032 * A new experimental feature:\n\
- \032 The final component of a -path argument may now be the wildcard\n\
- \032 specifier *. When Unison sees such a path, it expands this path on\n\
- \032 the client into into the corresponding list of paths by listing the\n\
- \032 contents of that directory.\n\
- \032 Note that if you use wildcard paths from the command line, you will\n\
- \032 probably need to use quotes or a backslash to prevent the * from\n\
- \032 being interpreted by your shell.\n\
- \032 If both roots are local, the contents of the first one will be used\n\
- \032 for expanding wildcard paths. (Nb: this is the first one after the\n\
- \032 canonization step - i.e., the one that is listed first in the user\n\
- \032 interface - not the one listed first on the command line or in the\n\
- \032 preferences file.)\n\
- \n\
- \032 Changes since 2.1:\n\
- \032 * The transport subsystem now includes an implementation by Sylvain\n\
- \032 Gommier and Norman Ramsey of Tridgell and Mackerras's rsync\n\
- \032 protocol. This protocol achieves much faster transfers when only a\n\
- \032 small part of a large file has been changed by sending just diffs.\n\
- \032 This feature is mainly helpful for transfers over slow links--on\n\
- \032 fast local area networks it can actually degrade performance--so we\n\
- \032 have left it off by default. Start unison with the -rsync option\n\
- \032 (or put rsync=true in your preferences file) to turn it on.\n\
- \032 * \"Progress bars\" are now displayed during remote file transfers,\n\
- \032 showing what percentage of each file has been transferred so far.\n\
- \032 * The version numbering scheme has changed. New releases will now be\n\
- \032 have numbers like 2.2.30, where the second component is incremented\n\
- \032 on every significant public release and the third component is the\n\
- \032 \"patch level.\"\n\
- \032 * Miscellaneous improvements to the GTK-based user interface.\n\
- \032 * The manual is now available in PDF format.\n\
- \032 * We are experimenting with using a multi-threaded transport\n\
- \032 subsystem to transfer several files at the same time, making much\n\
- \032 more effective use of available network bandwidth. This feature is\n\
- \032 not completely stable yet, so by default it is disabled in the\n\
- \032 release version of Unison.\n\
- \032 If you want to play with the multi-threaded version, you'll need to\n\
- \032 recompile Unison from sources (as described in the documentation),\n\
- \032 setting the THREADS flag in Makefile.OCaml to true. Make sure that\n\
- \032 your OCaml compiler has been installed with the -with-pthreads\n\
- \032 configuration option. (You can verify this by checking whether the\n\
- \032 file threads/threads.cma in the OCaml standard library directory\n\
- \032 contains the string -lpthread near the end.)\n\
- \n\
- \032 Changes since 1.292:\n\
- \032 * Reduced memory footprint (this is especially important during the\n\
- \032 first run of unison, where it has to gather information about all\n\
- \032 the files in both repositories).\n\
- \032 * Fixed a bug that would cause the socket server under NT to fail\n\
- \032 after the client exits.\n\
- \032 * Added a SHIFT modifier to the Ignore menu shortcut keys in GTK\n\
- \032 interface (to avoid hitting them accidentally).\n\
- \n\
- \032 Changes since 1.231:\n\
- \032 * Tunneling over ssh is now supported in the Windows version. See the\n\
- \032 installation section of the manual for detailed instructions.\n\
- \032 * The transport subsystem now includes an implementation of the rsync\n\
- \032 protocol, built by Sylvain Gommier and Norman Ramsey. This protocol\n\
- \032 achieves much faster transfers when only a small part of a large\n\
- \032 file has been changed by sending just diffs. The rsync feature is\n\
- \032 off by default in the current version. Use the -rsync switch to\n\
- \032 turn it on. (Nb. We still have a lot of tuning to do: you may not\n\
- \032 notice much speedup yet.)\n\
- \032 * We're experimenting with a multi-threaded transport subsystem,\n\
- \032 written by Jerome Vouillon. The downloadable binaries are still\n\
- \032 single-threaded: if you want to try the multi-threaded version,\n\
- \032 you'll need to recompile from sources. (Say make THREADS=true.)\n\
- \032 Native thread support from the compiler is required. Use the option\n\
- \032 -threads N to select the maximal number of concurrent threads\n\
- \032 (default is 5). Multi-threaded and single-threaded clients/servers\n\
- \032 can interoperate.\n\
- \032 * A new GTK-based user interface is now available, thanks to Jacques\n\
- \032 Garrigue. The Tk user interface still works, but we'll be shifting\n\
- \032 development effort to the GTK interface from now on.\n\
- \032 * OCaml 3.00 is now required for compiling Unison from sources. The\n\
- \032 modules uitk and myfileselect have been changed to use labltk\n\
- \032 instead of camltk. To compile the Tk interface in Windows, you must\n\
- \032 have ocaml-3.00 and tk8.3. When installing tk8.3, put it in c:\\Tcl\n\
- \032 rather than the suggested c:\\Program Files\\Tcl, and be sure to\n\
- \032 install the headers and libraries (which are not installed by\n\
- \032 default).\n\
- \032 * Added a new -addversionno switch, which causes unison to use\n\
- \032 unison-<currentversionnumber> instead of just unison as the remote\n\
- \032 server command. This allows multiple versions of unison to coexist\n\
- \032 conveniently on the same server: whichever version is run on the\n\
- \032 client, the same version will be selected on the server.\n\
- \n\
- \032 Changes since 1.219:\n\
- \032 * INCOMPATIBLE CHANGE: Archive format has changed. Make sure you\n\
- \032 synchronize your replicas before upgrading, to avoid spurious\n\
- \032 conflicts. The first sync after upgrading will be slow.\n\
- \032 * This version fixes several annoying bugs, including:\n\
- \032 + Some cases where propagation of file permissions was not\n\
- \032 working.\n\
- \032 + umask is now ignored when creating directories\n\
- \032 + directories are create writable, so that a read-only directory\n\
- \032 and its contents can be propagated.\n\
- \032 + Handling of warnings generated by the server.\n\
- \032 + Synchronizing a path whose parent is not a directory on both\n\
- \032 sides is now flagged as erroneous.\n\
- \032 + Fixed some bugs related to symnbolic links and nonexistent\n\
- \032 roots.\n\
- \032 o When a change (deletion or new contents) is propagated\n\
- \032 onto a 'follow'ed symlink, the file pointed to by the\n\
- \032 link is now changed. (We used to change the link itself,\n\
- \032 which doesn't fit our assertion that 'follow' means the\n\
- \032 link is completely invisible)\n\
- \032 o When one root did not exist, propagating the other root\n\
- \032 on top of it used to fail, because unison could not\n\
- \032 calculate the working directory into which to write\n\
- \032 changes. This should be fixed.\n\
- \032 * A human-readable timestamp has been added to Unison's archive\n\
- \032 files.\n\
- \032 * The semantics of Path and Name regular expressions now correspond\n\
- \032 better.\n\
- \032 * Some minor improvements to the text UI (e.g. a command for going\n\
- \032 back to previous items)\n\
- \032 * The organization of the export directory has changed -- should be\n\
- \032 easier to find / download things now.\n\
- \n\
- \032 Changes since 1.200:\n\
- \032 * INCOMPATIBLE CHANGE: Archive format has changed. Make sure you\n\
- \032 synchronize your replicas before upgrading, to avoid spurious\n\
- \032 conflicts. The first sync after upgrading will be slow.\n\
- \032 * This version has not been tested extensively on Windows.\n\
- \032 * Major internal changes designed to make unison safer to run at the\n\
- \032 same time as the replicas are being changed by the user.\n\
- \032 * Internal performance improvements.\n\
- \n\
- \032 Changes since 1.190:\n\
- \032 * INCOMPATIBLE CHANGE: Archive format has changed. Make sure you\n\
- \032 synchronize your replicas before upgrading, to avoid spurious\n\
- \032 conflicts. The first sync after upgrading will be slow.\n\
- \032 * A number of internal functions have been changed to reduce the\n\
- \032 amount of memory allocation, especially during the first\n\
- \032 synchronization. This should help power users with very big\n\
- \032 replicas.\n\
- \032 * Reimplementation of low-level remote procedure call stuff, in\n\
- \032 preparation for adding rsync-like smart file transfer in a later\n\
- \032 release.\n\
- \032 * Miscellaneous bug fixes.\n\
- \n\
- \032 Changes since 1.180:\n\
- \032 * INCOMPATIBLE CHANGE: Archive format has changed. Make sure you\n\
- \032 synchronize your replicas before upgrading, to avoid spurious\n\
- \032 conflicts. The first sync after upgrading will be slow.\n\
- \032 * Fixed some small bugs in the interpretation of ignore patterns.\n\
- \032 * Fixed some problems that were preventing the Windows version from\n\
- \032 working correctly when click-started.\n\
- \032 * Fixes to treatment of file permissions under Windows, which were\n\
- \032 causing spurious reports of different permissions when\n\
- \032 synchronizing between windows and unix systems.\n\
- \032 * Fixed one more non-tail-recursive list processing function, which\n\
- \032 was causing stack overflows when synchronizing very large replicas.\n\
- \n\
- \032 Changes since 1.169:\n\
- \032 * The text user interface now provides commands for ignoring files.\n\
- \032 * We found and fixed some more non-tail-recursive list processing\n\
- \032 functions. Some power users have reported success with very large\n\
- \032 replicas.\n\
- \032 * INCOMPATIBLE CHANGE: Files ending in .tmp are no longer ignored\n\
- \032 automatically. If you want to ignore such files, put an appropriate\n\
- \032 ignore pattern in your profile.\n\
- \032 * INCOMPATIBLE CHANGE: The syntax of ignore and follow patterns has\n\
- \032 changed. Instead of putting a line of the form\n\
- \032 ignore = <regexp>\n\
- \n\
- \032 in your profile (.unison/default.prf), you should put:\n\
- \032 ignore = Regex <regexp>\n\
- \n\
- \032 Moreover, two other styles of pattern are also recognized:\n\
- \032 ignore = Name <name>\n\
- \n\
- \032 matches any path in which one component matches <name>, while\n\
- \032 ignore = Path <path>\n\
- \n\
- \032 matches exactly the path <path>.\n\
- \032 Standard \"globbing\" conventions can be used in <name> and <path>:\n\
- \032 + a ? matches any single character except /\n\
- \032 + a * matches any sequence of characters not including /\n\
- \032 + [xyz] matches any character from the set {x, y, z }\n\
- \032 + {a,bb,ccc} matches any one of a, bb, or ccc.\n\
- \032 See the user manual for some examples.\n\
- \n\
- \032 Changes since 1.146:\n\
- \032 * Some users were reporting stack overflows when synchronizing huge\n\
- \032 directories. We found and fixed some non-tail-recursive list\n\
- \032 processing functions, which we hope will solve the problem. Please\n\
- \032 give it a try and let us know.\n\
- \032 * Major additions to the documentation.\n\
- \n\
- \032 Changes since 1.142:\n\
- \032 * Major internal tidying and many small bugfixes.\n\
- \032 * Major additions to the user manual.\n\
- \032 * Unison can now be started with no arguments - it will prompt\n\
- \032 automatically for the name of a profile file containing the roots\n\
- \032 to be synchronized. This makes it possible to start the graphical\n\
- \032 UI from a desktop icon.\n\
- \032 * Fixed a small bug where the text UI on NT was raising a 'no such\n\
- \032 signal' exception.\n\
- \n\
- \032 Changes since 1.139:\n\
- \032 * The precompiled windows binary in the last release was compiled\n\
- \032 with an old OCaml compiler, causing propagation of permissions not\n\
- \032 to work (and perhaps leading to some other strange behaviors we've\n\
- \032 heard reports about). This has been corrected. If you're using\n\
- \032 precompiled binaries on Windows, please upgrade.\n\
- \032 * Added a -debug command line flag, which controls debugging of\n\
- \032 various modules. Say -debug XXX to enable debug tracing for module\n\
- \032 XXX, or -debug all to turn on absolutely everything.\n\
- \032 * Fixed a small bug where the text UI on NT was raising a 'no such\n\
- \032 signal' exception.\n\
- \n\
- \032 Changes since 1.111:\n\
- \032 * INCOMPATIBLE CHANGE: The names and formats of the preference files\n\
- \032 in the .unison directory have changed. In particular:\n\
- \032 + the file \"prefs\" should be renamed to default.prf\n\
- \032 + the contents of the file \"ignore\" should be merged into\n\
- \032 default.prf. Each line of the form REGEXP in ignore should\n\
- \032 become a line of the form ignore = REGEXP in default.prf.\n\
- \032 * Unison now handles permission bits and symbolic links. See the\n\
- \032 manual for details.\n\
- \032 * You can now have different preference files in your .unison\n\
- \032 directory. If you start unison like this\n\
- \032 unison profilename\n\
- \n\
- \032 (i.e. with just one \"anonymous\" command-line argument), then the\n\
- \032 file ~/.unison/profilename.prf will be loaded instead of\n\
- \032 default.prf.\n\
- \032 * Some improvements to terminal handling in the text user interface\n\
- \032 * Added a switch -killServer that terminates the remote server\n\
- \032 process when the unison client is shutting down, even when using\n\
- \032 sockets for communication. (By default, a remote server created\n\
- \032 using ssh/rsh is terminated automatically, while a socket server is\n\
- \032 left running.)\n\
- \032 * When started in 'socket server' mode, unison prints 'server\n\
- \032 started' on stderr when it is ready to accept connections. (This\n\
- \032 may be useful for scripts that want to tell when a socket-mode\n\
- \032 server has finished initialization.)\n\
- \032 * We now make a nightly mirror of our current internal development\n\
- \032 tree, in case anyone wants an up-to-the-minute version to hack\n\
- \032 around with.\n\
- \032 * Added a file CONTRIB with some suggestions for how to help us make\n\
- \032 Unison better.\n\
+ \032 section \226\128\156Profiles\226\128\157 ). Use your favorite editor for this.\n\
\n\
"))
::
@@ -4711,12 +3195,11 @@ let docs =
"Junk\n\
\032 __________________________________________________________________\n\
\n\
- \032 This document was translated from L^AT[E]X by [2]H^EV^EA.\n\
+ \032 This document was translated from L^AT[E]X by [1]H^EV^EA.\n\
\n\
References\n\
\n\
- \032 1. file:///home/n0/gdt/SOFTWARE/FILESYSTEMS/unison/doc/temp.html#ssh-win\n\
- \032 2. http://hevea.inria.fr/index.html\n\
+ \032 1. http://hevea.inria.fr/index.html\n\
"))
::
[];;
diff --git a/src/system.ml b/src/system.ml
index 164a169..e376a7b 100644
--- a/src/system.ml
+++ b/src/system.ml
@@ -15,4 +15,4 @@
along with this program. If not, see <http://www.gnu.org/licenses/>.
*)
-include System_impl.System
+include System_impl
diff --git a/src/system/generic/system_impl.ml b/src/system/generic/system_impl.ml
index 09e17b1..31dffe7 100644
--- a/src/system/generic/system_impl.ml
+++ b/src/system/generic/system_impl.ml
@@ -15,9 +15,4 @@
along with this program. If not, see <http://www.gnu.org/licenses/>.
*)
-module System = System_generic
-module Fs = struct
- include System_generic
-
- let setUnicodeEncoding _ = ()
-end
+include System_generic
diff --git a/src/system/system_generic.ml b/src/system/system_generic.ml
index ae0138c..6f6c689 100644
--- a/src/system/system_generic.ml
+++ b/src/system/system_generic.ml
@@ -17,14 +17,11 @@
type fspath = string
-let fspathFromString f = f
-let fspathToPrintString f = f
-let fspathToString f = f
-let fspathToDebugString f = String.escaped f
+let mfspath = Umarshal.string
+
+let extendedPath f = f
-let fspathConcat = Filename.concat
-let fspathDirname = Filename.dirname
-let fspathAddSuffixToFinalName f suffix = f ^ suffix
+let fspathToDebugString f = String.escaped f
(****)
@@ -71,8 +68,13 @@ let open_in_bin = open_in_bin
let create_process = Unix.create_process
let open_process_in = Unix.open_process_in
+let open_process_args_in = Unix.open_process_args_in
let open_process_out = Unix.open_process_out
let open_process_full cmd = Unix.open_process_full cmd (Unix.environment ())
+let open_process_args_full cmd args = Unix.open_process_args_full cmd args (Unix.environment ())
+let process_in_pid = Unix.process_in_pid
+let process_out_pid = Unix.process_out_pid
+let process_full_pid = Unix.process_full_pid
let close_process_in = Unix.close_process_in
let close_process_out = Unix.close_process_out
let close_process_full = Unix.close_process_full
@@ -81,17 +83,13 @@ let close_process_full = Unix.close_process_full
let isNotWindows = Sys.os_type <> "Win32"
-let canSetTime f =
- isNotWindows ||
- try
- Unix.access f [Unix.W_OK];
- true
- with
- Unix.Unix_error _ -> false
-
(* Note that Cygwin provides some kind of inode numbers, but we only
have access to the lower 32 bits on 32bit systems... *)
-let hasInodeNumbers () = isNotWindows
+(* Best effort inode numbers are provided in Windows since OCaml 4.03 *)
+(* However, these inode numbers are not usable on FAT filesystems, as
+ renaming a file "b" over a file "a" does not change the inode
+ number of "a". *)
+let hasInodeNumbers () = true
let hasSymlink = Unix.has_symlink
@@ -122,10 +120,49 @@ let terminalStateFunctions () =
startReading = (fun () -> ());
stopReading = (fun () -> ()) }
+let termVtCapable fd = Unix.isatty fd
+
+let has_stdout ~info:_ = true
+let has_stderr ~info:_ = true
+
(****)
let fingerprint f =
let ic = open_in_bin f in
- let d = Digest.channel ic (-1) in
- close_in ic;
- d
+ try
+ let d = Digest.channel ic (-1) in
+ close_in ic;
+ d
+ with e ->
+ close_in_noerr ic;
+ raise e
+
+(****)
+
+exception XattrNotSupported
+let _ = Callback.register_exception "XattrNotSupported" XattrNotSupported
+
+external xattr_list : string -> (string * int) list = "unison_xattrs_list"
+external xattr_get_ : string -> string -> string = "unison_xattr_get"
+external xattr_set_ : string -> string -> string -> unit = "unison_xattr_set"
+external xattr_remove_ : string -> string -> unit = "unison_xattr_remove"
+external xattr_updates_ctime : unit -> bool = "unison_xattr_updates_ctime"
+
+let xattrUpdatesCTime = xattr_updates_ctime ()
+
+let xattr_get p n =
+ try xattr_get_ p n with
+ | Failure e -> failwith ("(attr: " ^ n ^ ") " ^ e)
+
+let xattr_set p n v =
+ try xattr_set_ p n v with
+ | Failure e -> failwith ("(attr: " ^ n ^ ") " ^ e)
+
+let xattr_remove p n =
+ try xattr_remove_ p n with
+ | Failure e -> failwith ("(attr: " ^ n ^ ") " ^ e)
+
+(****)
+
+external acl_get_text : string -> string = "unison_acl_to_text"
+external acl_set_text : string -> string -> unit = "unison_acl_from_text"
diff --git a/src/system/system_intf.ml b/src/system/system_intf.ml
index c6c8763..873f4ca 100644
--- a/src/system/system_intf.ml
+++ b/src/system/system_intf.ml
@@ -18,6 +18,7 @@
module type Core = sig
type fspath
+val mfspath : fspath Umarshal.t
type dir_handle = { readdir : unit -> string; closedir : unit -> unit }
val symlink : string -> fspath -> unit
@@ -44,7 +45,6 @@ val fingerprint : fspath -> Digest.t
(****)
-val canSetTime : fspath -> bool
val hasInodeNumbers : unit -> bool
val hasSymlink : unit -> bool
@@ -55,23 +55,39 @@ val hasSymlink : unit -> bool
* [hasCorrectCTime] can have a different value on different systems. *)
val hasCorrectCTime : bool
+(****)
+
+exception XattrNotSupported
+
+val xattr_list : fspath -> (string * int) list
+val xattr_get : fspath -> string -> string
+val xattr_set : fspath -> string -> string -> unit
+val xattr_remove : fspath -> string -> unit
+
+(* [xattrUpdatesCTime] is true if changes to extended attributes update the
+ * file ctime. This means that extended attribute changes can be quickly
+ * detected by looking at ctime change. If file ctime is not updated then
+ * xattrs have to be scanned every time to detect changes. *)
+val xattrUpdatesCTime : bool
+
+(****)
+
+val acl_get_text : fspath -> string
+val acl_set_text : fspath -> string -> unit
+
end
module type Full = sig
-include Core
+include Core with type fspath = string
+
+val extendedPath : string -> fspath
val putenv : string -> string -> unit
val getenv : string -> string
val argv : unit -> string array
-val fspathFromString : string -> fspath
-val fspathToPrintString : fspath -> string
val fspathToDebugString : fspath -> string
-val fspathToString : fspath -> string
-val fspathConcat : fspath -> string -> fspath
-val fspathDirname : fspath -> fspath
-val fspathAddSuffixToFinalName : fspath -> string -> fspath
val open_in_gen : open_flag list -> int -> fspath -> in_channel
@@ -83,9 +99,15 @@ val create_process :
string -> string array ->
Unix.file_descr -> Unix.file_descr -> Unix.file_descr -> int
val open_process_in : string -> in_channel
+val open_process_args_in : string -> string array -> in_channel
val open_process_out : string -> out_channel
val open_process_full :
string -> in_channel * out_channel * in_channel
+val open_process_args_full :
+ string -> string array -> in_channel * out_channel * in_channel
+val process_in_pid : in_channel -> int
+val process_out_pid : out_channel -> int
+val process_full_pid : in_channel * out_channel * in_channel -> int
val close_process_in : in_channel -> Unix.process_status
val close_process_out : out_channel -> Unix.process_status
val close_process_full :
@@ -96,4 +118,9 @@ type terminalStateFunctions =
startReading : unit -> unit; stopReading : unit -> unit }
val terminalStateFunctions : unit -> terminalStateFunctions
+val termVtCapable : Unix.file_descr -> bool
+
+val has_stdout : info:string -> bool
+val has_stderr : info:string -> bool
+
end
diff --git a/src/system/system_win.ml b/src/system/system_win.ml
index 03063ce..72b0061 100644
--- a/src/system/system_win.ml
+++ b/src/system/system_win.ml
@@ -22,61 +22,25 @@ http://www.codeproject.com/KB/cpp/unicode_console_output.aspx?display=Print
*)
-module M (P : sig val useLongUNCPaths : bool end) = struct
-
-type fspath = string
-
-let fspathFromString f = f
-let fspathToPrintString f = f
-let fspathToString f = f
-let fspathToDebugString f = String.escaped f
-
-let fspathConcat = Filename.concat
-let fspathDirname = Filename.dirname
-let fspathAddSuffixToFinalName f suffix = f ^ suffix
+include System_generic
(****)
-let fixPath f =
- let length = String.length f in
- let buffer = Bytes.create length in
- String.blit f 0 buffer 0 length;
- for i = 0 to length - 1 do
- if Bytes.get buffer i = '/' then Bytes.set buffer i '\\'
- done;
- Bytes.to_string buffer
+let fixPath f = String.map (function '/' -> '\\' | c -> c) f
let winRootRx = Rx.rx "[a-zA-Z]:[/\\].*"
-let winUncRx = Rx.rx "[/\\][/\\][^/\\]+[/\\][^/\\]+[/\\].*"
+let winUncRx = Rx.rx "[/\\][/\\][^?/\\]+[/\\][^/\\]+[/\\].*"
+let winFileNsPathRx = Rx.rx "//[?]/.+"
let extendedPath f =
- if not P.useLongUNCPaths then
- f
- else if Rx.match_string winRootRx f then
+ if Rx.match_string winRootRx f then
fixPath ("\\\\?\\" ^ f)
else if Rx.match_string winUncRx f then
fixPath ("\\\\?\\UNC" ^ String.sub f 1 (String.length f - 1))
+ else if Rx.match_string winFileNsPathRx f then
+ fixPath f
else
f
-let encodingError p =
- raise
- (Sys_error
- (Format.sprintf "The file path '%s' is not encoded in Unicode." p))
-
-let utf8 = Unicode.from_utf_16
-let utf16 s =
- try
- Unicode.to_utf_16 s
- with Unicode.Invalid ->
- raise (Sys_error
- (Format.sprintf "The text '%s' is not encoded in Unicode" s))
-let path8 = Unicode.from_utf_16(*_filename*)
-let path16 f =
- try Unicode.to_utf_16(*_filename*) f with Unicode.Invalid -> encodingError f
-let epath f =
- try
- Unicode.to_utf_16(*_filename*) (extendedPath f)
- with
- Unicode.Invalid -> encodingError f
+(****)
let sys_error e =
match e with
@@ -89,232 +53,102 @@ let sys_error e =
(****)
-external getenv_impl : string -> string = "win_getenv"
-external putenv_impl : string -> string -> string -> unit = "win_putenv"
-external argv_impl : unit -> string array = "win_argv"
+external stat_impl : string -> bool -> Unix.LargeFile.stats = "win_stat"
+let stat f = stat_impl f false
+let lstat f = stat_impl f true
-let getenv nm = utf8 (getenv_impl (utf16 nm))
-let putenv nm v = putenv_impl nm (utf16 nm) (utf16 v)
-let argv () = Array.map utf8 (argv_impl ())
-
-(****)
+let rename f1 f2 =
+ (* Comment from original C stub implementation:
+ Windows Unicode API: when a file cannot be renamed due to a sharing
+ violation error or an access denied error, retry for up to 1 second,
+ in case the file is temporarily opened by an indexer or an anti-virus. *)
+ let rec ren_aux delay =
+ try
+ Unix.rename f1 f2
+ with
+ | (Unix.Unix_error ((Unix.EACCES | Unix.EUNKNOWNERR (-32)), _, _)) as e ->
+ (* ERROR_SHARING_VIOLATION *)
+ if (delay < 1.) then begin
+ Unix.sleepf delay;
+ ren_aux (delay *. 2.)
+ end else
+ raise e
+ | e -> raise e
+ in
+ ren_aux 0.01
-type dir_entry = Dir_empty | Dir_read of string | Dir_toread
-type dir_handle = System_generic.dir_handle
- = { readdir : unit -> string; closedir : unit -> unit }
-
-external stat_impl : string -> string -> bool -> Unix.LargeFile.stats = "win_stat"
-external rmdir_impl : string -> string -> unit = "win_rmdir"
-external mkdir_impl : string -> string -> unit = "win_mkdir"
-external unlink_impl : string -> string -> unit = "win_unlink"
-external rename_impl : string -> string -> string -> unit = "win_rename"
-external link_impl : string -> string -> string -> unit = "win_link"
-external chmod_impl : string -> string -> int -> unit = "win_chmod"
-external utimes_impl :
- string -> string -> float -> float -> unit = "win_utimes"
-external open_impl :
- string -> string -> Unix.open_flag list -> Unix.file_perm -> Unix.file_descr = "win_open"
-external chdir_impl : string -> string -> unit = "win_chdir"
-external getcwd_impl : unit -> string = "win_getcwd"
-external findfirst : string -> string * int = "win_findfirstw"
-external findnext : int -> string = "win_findnextw"
-external findclose : int -> unit = "win_findclosew"
-
-let stat f = stat_impl f (epath f) false
-let lstat f = stat_impl f (epath f) true
-let rmdir f = rmdir_impl f (epath f)
-let mkdir f perms = mkdir_impl f (epath f)
-let unlink f = unlink_impl f (epath f)
-let rename f1 f2 = rename_impl f1 (epath f1) (epath f2)
-let chmod f perm = chmod_impl f (epath f) perm
let chown _ _ _ = raise (Unix.Unix_error (Unix.ENOSYS, "chown", ""))
-let utimes f t1 t2 = utimes_impl f (epath f) t1 t2
-let link f1 f2 = link_impl f1 (epath f1) (epath f2)
-let openfile f flags perm = open_impl f (epath f) flags perm
-let readlink = Unix.readlink
-let symlink f t = Unix.symlink f t
-let chdir f =
- try
- chdir_impl f (path16 f) (* Better not to use [epath] here *)
- with e -> sys_error e
+let openfile f flags perm =
+ let fd = Unix.openfile f flags perm in
+ (* Comment from original C stub implementation:
+ Windows: implement somewhat the O_APPEND flag, so that appending
+ lines to a profile (ignored files, for instance) works instead of
+ overwriting the beginning of the file (the file pointer is moved to
+ the end when the file is opened, rather that each time something is
+ written, which is good enough here) *)
+ if List.mem Unix.O_APPEND flags then
+ ignore (Unix.LargeFile.lseek fd 0L Unix.SEEK_END);
+ fd
+
+let readlink f =
+ (* Windows apparently mangles the link values if the value is an absolute
+ path. With [readlink] you're not getting back the same value you set
+ with [symlink] (except if it was a relative path). It's not clear if
+ this happens always or under certain circumstances only.
+
+ It's unclear how this mangling works, but it appears to convert the link
+ value to an NT namespace path under the \?? directory (with \DosDevices
+ being a symlink to it?). For regular DOS paths with a drive letter, this
+ is usually ok in terms of nearly-preserving the original link value, as it
+ only adds the \??\ prefix. For \\server\share\ network paths, it changes
+ the prefix to \??\UNC\server\share\.
+
+ https://docs.microsoft.com/en-us/windows-hardware/drivers/kernel/introduction-to-ms-dos-device-names
+ https://docs.microsoft.com/en-us/windows-hardware/drivers/kernel/object-directories
+ https://docs.microsoft.com/en-us/windows-hardware/drivers/kernel/object-names
+
+ This conversion happens to all(?) absolute paths to targets, whether they
+ were originally in the common DOS format, UNC, or already in Win32 file
+ namespace format (with \\?\ prefix).
+
+ Since we don't know what was the link value set by [symlink], we do as
+ little modification as possible to the output of [readlink]. This means
+ changing the prefix to \\?\ (because that's at least somewhat known to
+ user-space and something we can deal with) and hoping that the resulting
+ path is correct. Without this change the path will be rejected by some
+ (all?) filesystem syscalls. *)
+ let l = Unix.readlink f in
+ let len = String.length l in
+ if len > 3 && l.[0] = '\\' && l.[1] = '?' && l.[2] = '?' && l.[3] = '\\' then
+ "\\\\?\\" ^ (String.sub l 4 (len - 4))
+ else l
+
+external long_name : string -> string = "win_long_path_name"
let getcwd () =
try
- path8 (getcwd_impl ())
+ (* Normalize the path *)
+ let s = long_name (Sys.getcwd ()) in
+ (* Convert the drive letter to uppercase *)
+ match s.[0] with
+ | 'a' .. 'z' -> String.capitalize_ascii s
+ | _ -> s
with e -> sys_error e
let badFileRx = Rx.rx ".*[?*].*"
+let winFileNsPathRx = Rx.rx "[/\\][/\\][?][/\\].+"
let opendir d =
- if Rx.match_string badFileRx d then
+ (* Windows uses wildcards to retrieve the list of files in a directory.
+ It is not possible to list files in a directory when the path name
+ itself contains the wildcards "*" or "?". *)
+ let d' = if Rx.match_string winFileNsPathRx d then String.sub d 4 (String.length d - 4) else d in
+ if Rx.match_string badFileRx d' then
raise (Unix.Unix_error (Unix.ENOENT, "opendir", d));
- let (handle, entry_read) =
- try
- let (first_entry, handle) = findfirst (epath (fspathConcat d "*")) in
- (handle, ref (Dir_read first_entry))
- with End_of_file ->
- (0, ref Dir_empty)
- in
- { readdir =
- (fun () ->
- match !entry_read with
- Dir_empty -> raise End_of_file
- | Dir_read name -> entry_read := Dir_toread; path8 name
- | Dir_toread -> path8 (findnext handle));
- closedir =
- (fun () ->
- match !entry_read with
- Dir_empty -> ()
- | _ -> findclose handle) }
-
-let rec conv_flags fl =
- match fl with
- Open_rdonly :: rem -> Unix.O_RDONLY :: conv_flags rem
- | Open_wronly :: rem -> Unix.O_WRONLY :: conv_flags rem
- | Open_append :: rem -> Unix.O_APPEND :: conv_flags rem
- | Open_creat :: rem -> Unix.O_CREAT :: conv_flags rem
- | Open_trunc :: rem -> Unix.O_TRUNC :: conv_flags rem
- | Open_excl :: rem -> Unix.O_EXCL :: conv_flags rem
- | Open_binary :: rem -> conv_flags rem
- | Open_text :: rem -> conv_flags rem
- | Open_nonblock :: rem -> Unix.O_NONBLOCK :: conv_flags rem
- | [] -> []
-
-let open_in_gen flags perms f =
- try
- Unix.in_channel_of_descr (openfile f (conv_flags flags) perms)
- with e ->
- sys_error e
-let open_out_gen flags perms f =
- try
- Unix.out_channel_of_descr (openfile f (conv_flags flags) perms)
- with e ->
- sys_error e
-
-(****)
-
-let file_exists f =
- try
- ignore (stat f); true
- with
- Unix.Unix_error ((Unix.ENOENT | Unix.ENOTDIR), _, _) ->
- false
- | e ->
- sys_error e
-
-let open_in_bin f = open_in_gen [Open_rdonly; Open_binary] 0 f
-
-(****)
-
-external win_create_process :
- string -> string -> string ->
- Unix.file_descr -> Unix.file_descr -> Unix.file_descr -> int
- = "w_create_process" "w_create_process_native"
-
-let make_cmdline args =
- let maybe_quote f =
- if String.contains f ' ' || String.contains f '\"'
- then Filename.quote f
- else f in
- String.concat " " (List.map maybe_quote (Array.to_list args))
-
-let create_process prog args fd1 fd2 fd3 =
- win_create_process
- prog (utf16 prog) (utf16 (make_cmdline args)) fd1 fd2 fd3
+ System_generic.opendir d
(****)
-(* The following is by Xavier Leroy and Pascal Cuoq,
- projet Cristal, INRIA Rocquencourt.
- Taken from the Objective Caml win32unix library. *)
-
-type popen_process =
- Process of in_channel * out_channel
- | Process_in of in_channel
- | Process_out of out_channel
- | Process_full of in_channel * out_channel * in_channel
-
-let popen_processes = (Hashtbl.create 7 : (popen_process, int) Hashtbl.t)
-
-let open_proc cmd proc input output error =
- let shell =
- try getenv "COMSPEC"
- with Not_found -> raise(Unix.Unix_error(Unix.ENOEXEC, "open_proc", cmd)) in
- let pid =
- win_create_process
- shell (utf16 shell) (utf16 (shell ^ " /c " ^ cmd)) input output error in
- Hashtbl.add popen_processes proc pid
-
-let open_process_in cmd =
- let (in_read, in_write) = Unix.pipe() in
- Unix.set_close_on_exec in_read;
- let inchan = Unix.in_channel_of_descr in_read in
- open_proc cmd (Process_in inchan) Unix.stdin in_write Unix.stderr;
- Unix.close in_write;
- inchan
-
-let open_process_out cmd =
- let (out_read, out_write) = Unix.pipe() in
- Unix.set_close_on_exec out_write;
- let outchan = Unix.out_channel_of_descr out_write in
- open_proc cmd (Process_out outchan) out_read Unix.stdout Unix.stderr;
- Unix.close out_read;
- outchan
-
-let open_process_full cmd =
- let (in_read, in_write) = Unix.pipe() in
- let (out_read, out_write) = Unix.pipe() in
- let (err_read, err_write) = Unix.pipe() in
- Unix.set_close_on_exec in_read;
- Unix.set_close_on_exec out_write;
- Unix.set_close_on_exec err_read;
- let inchan = Unix.in_channel_of_descr in_read in
- let outchan = Unix.out_channel_of_descr out_write in
- let errchan = Unix.in_channel_of_descr err_read in
- open_proc cmd (Process_full(inchan, outchan, errchan))
- out_read in_write err_write;
- Unix.close out_read; Unix.close in_write; Unix.close err_write;
- (inchan, outchan, errchan)
-
-let find_proc_id fun_name proc =
- try
- let pid = Hashtbl.find popen_processes proc in
- Hashtbl.remove popen_processes proc;
- pid
- with Not_found ->
- raise(Unix.Unix_error(Unix.EBADF, fun_name, ""))
-
-let close_process_in inchan =
- let pid = find_proc_id "close_process_in" (Process_in inchan) in
- close_in inchan;
- snd(Unix.waitpid [] pid)
-
-let close_process_out outchan =
- let pid = find_proc_id "close_process_out" (Process_out outchan) in
- close_out outchan;
- snd(Unix.waitpid [] pid)
-
-let close_process_full (inchan, outchan, errchan) =
- let pid =
- find_proc_id "close_process_full"
- (Process_full(inchan, outchan, errchan)) in
- close_in inchan; close_out outchan; close_in errchan;
- snd(Unix.waitpid [] pid)
-
-(****)
-
-(* The new implementation of utimes does not have the limitation of
- the standard one *)
-let canSetTime f = true
-
-(* We provide some kind of inode numbers *)
-(* However, these inode numbers are not usable on FAT filesystems, as
- renaming a file "b" over a file "a" does not change the inode
- number of "a". *)
-let hasInodeNumbers () = true
-
-let hasSymlink = Unix.has_symlink
-
external hasCorrectCTime_impl : unit -> bool = "win_has_correct_ctime"
let hasCorrectCTime = hasCorrectCTime_impl ()
@@ -328,9 +162,8 @@ external setConsoleMode : int -> unit = "win_set_console_mode"
external getConsoleOutputCP : unit -> int = "win_get_console_output_cp"
external setConsoleOutputCP : int -> unit = "win_set_console_output_cp"
-type terminalStateFunctions =
- { defaultTerminal : unit -> unit; rawTerminal : unit -> unit;
- startReading : unit -> unit; stopReading : unit -> unit }
+external termVtCapable : Unix.file_descr -> bool = "win_vt_capable"
+(* [termVtCapable] is for _output_ file descriptors. *)
let terminalStateFunctions () =
(* First, allocate a console in case we don't already have one.
@@ -357,6 +190,8 @@ let terminalStateFunctions () =
let () = redirect (initConsole ()) in
let oldstate = getConsoleMode () in
let oldcp = getConsoleOutputCP () in
+ (* 0x200 = ENABLE_VIRTUAL_TERMINAL_INPUT *)
+ let vtin = if termVtCapable Unix.stdout then 0x200 else 0x0 in
(* Ctrl-C does not interrupt a call to ReadFile when
ENABLE_LINE_INPUT is not set, so we handle Ctr-C
as a character when reading from the console.
@@ -366,15 +201,8 @@ let terminalStateFunctions () =
{ defaultTerminal = (fun () -> setConsoleMode oldstate;
setConsoleOutputCP oldcp);
rawTerminal = (fun () -> setConsoleMode 0x19; setConsoleOutputCP 65001);
- startReading = (fun () -> setConsoleMode 0x18);
+ startReading = (fun () -> setConsoleMode (0x18 lor vtin));
stopReading = (fun () -> setConsoleMode 0x19) }
-(****)
-
-let fingerprint f =
- let ic = open_in_bin f in
- let d = Digest.channel ic (-1) in
- close_in ic;
- d
-
-end
+external has_stdout : info:string -> bool = "win_hasconsole_gui_stdout"
+external has_stderr : info:string -> bool = "win_hasconsole_gui_stderr"
diff --git a/src/system/system_win_stubs.c b/src/system/system_win_stubs.c
index a8c1d31..357d850 100644
--- a/src/system/system_win_stubs.c
+++ b/src/system/system_win_stubs.c
@@ -1,236 +1,28 @@
#define WINVER 0x0500
-#include <caml/mlvalues.h>
-#include <caml/alloc.h>
-#include <caml/memory.h>
-#include <caml/fail.h>
-
+#include <winsock2.h>
#include <windows.h>
#include <fcntl.h>
#include <sys/stat.h>
#include <stdio.h>
#include <stdint.h>
-#define NT_MAX_PATH 32768
-
-#define Nothing ((value) 0)
-
-struct filedescr {
- union {
- HANDLE handle;
- SOCKET socket;
- } fd;
- enum { KIND_HANDLE, KIND_SOCKET } kind;
- int crt_fd;
-};
-#define Handle_val(v) (((struct filedescr *) Data_custom_val(v))->fd.handle)
-
-value copy_wstring(LPCWSTR s)
-{
- int len;
- value res;
-
- len = 2 * wcslen(s) + 2; /* NULL character included */
- res = caml_alloc_string(len);
- memmove((char *)String_val(res), s, len);
- return res;
-}
-
-extern void win32_maperr (DWORD errcode);
-extern void uerror (char * cmdname, value arg);
-extern value win_alloc_handle (HANDLE h);
-extern value cst_to_constr (int n, int * tbl, int size, int deflt);
-
-static int open_access_flags[12] = {
- GENERIC_READ, GENERIC_WRITE, GENERIC_READ|GENERIC_WRITE,
- 0, 0, 0, 0, 0, 0, 0, 0, 0
-};
-
-static int open_create_flags[12] = {
- 0, 0, 0, 0, O_APPEND, O_CREAT, O_TRUNC, O_EXCL, 0, 0, 0, 0
-};
-
-/****/
-
-CAMLprim value win_rmdir(value path, value wpath)
-{
- CAMLparam2(path, wpath);
- if (!RemoveDirectoryW((LPWSTR)String_val(wpath))) {
- win32_maperr (GetLastError ());
- uerror("rmdir", path);
- }
- CAMLreturn (Val_unit);
-}
-
-CAMLprim value win_mkdir(value path, value wpath)
-{
- CAMLparam2(path, wpath);
- if (!CreateDirectoryW((LPWSTR)String_val(wpath), NULL)) {
- win32_maperr (GetLastError ());
- uerror("mkdir", path);
- }
- CAMLreturn (Val_unit);
-}
-
-CAMLprim value win_unlink(value path, value wpath)
-{
- CAMLparam2(path, wpath);
- if (!DeleteFileW((LPWSTR)String_val(wpath))) {
- win32_maperr (GetLastError ());
- uerror("unlink", path);
- }
- CAMLreturn (Val_unit);
-}
-
-CAMLprim value win_rename(value path1, value wpath1, value wpath2)
-{
- int err, t;
- CAMLparam3(path1, wpath1, wpath2);
-
- t = 10;
- retry:
- if (!MoveFileExW((LPWSTR)String_val(wpath1), (LPWSTR)String_val(wpath2),
- MOVEFILE_REPLACE_EXISTING)) {
- err = GetLastError ();
- if ((err == ERROR_SHARING_VIOLATION || err == ERROR_ACCESS_DENIED) &&
- t < 1000) {
- /* The renaming may fail due to an indexer or an anti-virus.
- We retry after a short time in the hope that this other
- program is done with the file. */
- Sleep (t);
- t *= 2;
- goto retry;
- }
- win32_maperr (err);
- uerror("rename", path1);
- }
- CAMLreturn (Val_unit);
-}
-
-CAMLprim value win_link(value path1, value wpath1, value wpath2)
-{
- CAMLparam3(path1, wpath1, wpath2);
-
- if (!CreateHardLinkW((LPWSTR)String_val(wpath2), (LPWSTR)String_val(wpath1),
- NULL)) {
- win32_maperr (GetLastError ());
- uerror("rename", path1);
- }
- CAMLreturn (Val_unit);
-}
-
-CAMLprim value win_chmod (value path, value wpath, value perm) {
- DWORD attr;
- CAMLparam3(path, wpath, perm);
-
- attr = GetFileAttributesW ((LPCWSTR)String_val (wpath));
- if (attr == INVALID_FILE_ATTRIBUTES) {
- win32_maperr (GetLastError ());
- uerror("chmod", path);
- }
- if (Int_val(perm) & _S_IWRITE)
- attr &= ~FILE_ATTRIBUTE_READONLY;
- else
- attr |= FILE_ATTRIBUTE_READONLY;
-
- if (!SetFileAttributesW ((LPCWSTR)String_val (wpath), attr)) {
- win32_maperr (GetLastError ());
- uerror("chmod", path);
- }
-
- CAMLreturn (Val_unit);
-}
-
-CAMLprim value win_utimes (value path, value wpath, value atime, value mtime) {
- HANDLE h;
- BOOL res;
- ULARGE_INTEGER iatime, imtime;
- FILETIME fatime, fmtime;
-
- CAMLparam4(path, wpath, atime, mtime);
-
- iatime.QuadPart = Double_val(atime);
- imtime.QuadPart = Double_val(mtime);
-
- /* http://www.filewatcher.com/p/Win32-UTCFileTime-1.44.tar.gz.93147/Win32-UTCFileTime-1.44/UTCFileTime.xs.html */
- /* http://savannah.nongnu.org/bugs/?22781#comment0 */
- if (iatime.QuadPart || imtime.QuadPart) {
- iatime.QuadPart += 11644473600ull;
- iatime.QuadPart *= 10000000ull;
- fatime.dwLowDateTime = iatime.LowPart;
- fatime.dwHighDateTime = iatime.HighPart;
- imtime.QuadPart += 11644473600ull;
- imtime.QuadPart *= 10000000ull;
- fmtime.dwLowDateTime = imtime.LowPart;
- fmtime.dwHighDateTime = imtime.HighPart;
- } else {
- GetSystemTimeAsFileTime (&fatime);
- fmtime = fatime;
- }
- h = CreateFileW ((LPWSTR) wpath, FILE_WRITE_ATTRIBUTES,
- FILE_SHARE_READ | FILE_SHARE_WRITE,
- NULL, OPEN_EXISTING, 0, NULL);
- if (h == INVALID_HANDLE_VALUE) {
- win32_maperr (GetLastError ());
- uerror("utimes", path);
- }
- res = SetFileTime (h, NULL, &fatime, &fmtime);
- if (res == 0) {
- win32_maperr (GetLastError ());
- (void)CloseHandle (h);
- uerror("utimes", path);
- }
- res = CloseHandle (h);
- if (res == 0) {
- win32_maperr (GetLastError ());
- uerror("utimes", path);
- }
- CAMLreturn (Val_unit);
-}
-
-CAMLprim value win_open (value path, value wpath, value flags, value perm) {
- int fileaccess, createflags, fileattrib, filecreate;
- SECURITY_ATTRIBUTES attr;
- HANDLE h;
-
- CAMLparam4 (path, wpath, flags, perm);
-
- fileaccess = convert_flag_list(flags, open_access_flags);
-
- createflags = convert_flag_list(flags, open_create_flags);
- if ((createflags & (O_CREAT | O_EXCL)) == (O_CREAT | O_EXCL))
- filecreate = CREATE_NEW;
- else if ((createflags & (O_CREAT | O_TRUNC)) == (O_CREAT | O_TRUNC))
- filecreate = CREATE_ALWAYS;
- else if (createflags & O_TRUNC)
- filecreate = TRUNCATE_EXISTING;
- else if (createflags & O_CREAT)
- filecreate = OPEN_ALWAYS;
- else
- filecreate = OPEN_EXISTING;
-
- if ((createflags & O_CREAT) && (Int_val(perm) & 0200) == 0)
- fileattrib = FILE_ATTRIBUTE_READONLY;
- else
- fileattrib = FILE_ATTRIBUTE_NORMAL;
-
- attr.nLength = sizeof(attr);
- attr.lpSecurityDescriptor = NULL;
- attr.bInheritHandle = TRUE;
-
- h = CreateFileW((LPCWSTR) String_val(wpath), fileaccess,
- FILE_SHARE_READ | FILE_SHARE_WRITE, &attr,
- filecreate, fileattrib, NULL);
-
- if (h == INVALID_HANDLE_VALUE) {
- win32_maperr (GetLastError ());
- uerror("open", path);
- }
-
- if (createflags & O_APPEND) SetFilePointer (h, 0, NULL, FILE_END);
+#include <caml/mlvalues.h>
+#include <caml/alloc.h>
+#include <caml/memory.h>
+#include <caml/fail.h>
+#include <caml/unixsupport.h>
+#include <caml/version.h>
+#if OCAML_VERSION < 41300
+#define CAML_INTERNALS /* was needed from OCaml 4.06 to 4.12 */
+#endif
+#include <caml/osdeps.h>
- CAMLreturn(win_alloc_handle(h));
-}
+#if OCAML_VERSION_MAJOR < 5
+#define caml_uerror uerror
+#define caml_win32_maperr win32_maperr
+#define caml_win32_alloc_handle win_alloc_handle
+#endif
/* Parts of code in the following section are originally copied from libuv.
@@ -382,6 +174,8 @@ typedef enum _FILE_INFORMATION_CLASS {
FileMaximumInformation
} FILE_INFORMATION_CLASS, *PFILE_INFORMATION_CLASS;
+#if !defined(OCAML_VERSION) || OCAML_VERSION < 40300 || OCAML_VERSION >= 41400
+
typedef struct _REPARSE_DATA_BUFFER {
ULONG ReparseTag;
USHORT ReparseDataLength;
@@ -412,6 +206,8 @@ typedef struct _REPARSE_DATA_BUFFER {
};
} REPARSE_DATA_BUFFER, *PREPARSE_DATA_BUFFER;
+#endif /* !OCAML_VERSION */
+
typedef NTSTATUS (NTAPI *sNtQueryInformationFile)
(HANDLE FileHandle,
PIO_STATUS_BLOCK IoStatusBlock,
@@ -470,7 +266,7 @@ void win_init()
/* END section originally copied from libuv win/winapi.c */
-CAMLprim value win_has_correct_ctime()
+CAMLprim value win_has_correct_ctime(value unit)
{
CAMLparam0();
@@ -480,18 +276,18 @@ CAMLprim value win_has_correct_ctime()
}
#define MAKEDWORDLONG(a,b) ((DWORDLONG)(((DWORD)(a))|(((DWORDLONG)((DWORD)(b)))<<32)))
-#define WINTIME_TO_TIME(t) (((ULONGLONG) t) / 10000000ull - 11644473600ull)
+#define WINTIME_TO_TIME(t) ((((ULONGLONG) t) - 116444736000000000ull) / 10000000ull)
#define FILETIME_TO_TIME(ft) WINTIME_TO_TIME((((ULONGLONG) ft.dwHighDateTime) << 32) + ft.dwLowDateTime)
#define FILETIME_NT_TO_TIME(ft) WINTIME_TO_TIME(ft.QuadPart)
-CAMLprim value win_stat(value path, value wpath, value lstat)
+CAMLprim value win_stat(value path, value lstat)
{
uintnat dev;
uintnat ino;
uintnat kind;
uintnat mode;
uintnat nlink;
- uint64_t size;
+ uint64_t size = 0;
double atime;
double mtime;
double ctime;
@@ -503,21 +299,24 @@ CAMLprim value win_stat(value path, value wpath, value lstat)
BY_HANDLE_FILE_INFORMATION info;
IO_STATUS_BLOCK io_status;
FILE_ALL_INFORMATION file_info;
- CAMLparam3(path,wpath, lstat);
+ CAMLparam2(path, lstat);
CAMLlocal1 (v);
char *fname = Bool_val(lstat) ? "lstat" : "stat";
win_init();
- h = CreateFileW ((LPCWSTR) String_val (wpath), FILE_READ_ATTRIBUTES,
+ wchar_t *wpath = caml_stat_strdup_to_utf16(String_val(path));
+
+ h = CreateFileW (wpath, FILE_READ_ATTRIBUTES,
FILE_SHARE_DELETE | FILE_SHARE_READ | FILE_SHARE_WRITE,
NULL, OPEN_EXISTING,
FILE_FLAG_BACKUP_SEMANTICS | FILE_ATTRIBUTE_READONLY |
(Bool_val(lstat) ? FILE_FLAG_OPEN_REPARSE_POINT : 0), NULL);
+ caml_stat_free(wpath);
if (h == INVALID_HANDLE_VALUE) {
- win32_maperr (GetLastError ());
- uerror(fname, path);
+ caml_win32_maperr(GetLastError());
+ caml_uerror(fname, path);
}
if (nt_api_available) {
@@ -526,17 +325,17 @@ CAMLprim value win_stat(value path, value wpath, value lstat)
/* Buffer overflow (a warning status code) is expected here. */
if (NT_ERROR(nt_status)) {
- win32_maperr(pRtlNtStatusToDosError(nt_status));
+ caml_win32_maperr(pRtlNtStatusToDosError(nt_status));
(void) CloseHandle(h);
- uerror(fname, path);
+ caml_uerror(fname, path);
}
}
res = GetFileInformationByHandle (h, &info);
if (res == 0) {
- win32_maperr (GetLastError ());
+ caml_win32_maperr(GetLastError());
(void) CloseHandle (h);
- uerror(fname, path);
+ caml_uerror(fname, path);
}
if (Bool_val(lstat) &&
@@ -557,12 +356,12 @@ CAMLprim value win_stat(value path, value wpath, value lstat)
res = CloseHandle (h);
if (res == 0) {
- win32_maperr (GetLastError ());
- uerror(fname, path);
+ caml_win32_maperr(GetLastError());
+ caml_uerror(fname, path);
}
if (Bool_val(lstat) && !syml) {
- CAMLreturn(win_stat(path, wpath, Val_false));
+ CAMLreturn(win_stat(path, Val_false));
}
dev = info.dwVolumeSerialNumber;
@@ -631,217 +430,43 @@ CAMLprim value win_stat(value path, value wpath, value lstat)
Store_field(v, 5, Val_int(0));
Store_field(v, 6, Val_int(0));
Store_field(v, 7, Val_int(0));
- Store_field(v, 8, copy_int64(size));
- Store_field(v, 9, copy_double(atime));
- Store_field(v, 10, copy_double(mtime));
- Store_field(v, 11, copy_double(ctime));
+ Store_field(v, 8, caml_copy_int64(size));
+ Store_field(v, 9, caml_copy_double(atime));
+ Store_field(v, 10, caml_copy_double(mtime));
+ Store_field(v, 11, caml_copy_double(ctime));
CAMLreturn (v);
}
-CAMLprim value win_chdir (value path, value wpath)
-{
- CAMLparam2(path,wpath);
- if (!SetCurrentDirectoryW ((LPWSTR)wpath)) {
- win32_maperr(GetLastError());
- uerror("chdir", path);
- }
- CAMLreturn (Val_unit);
-}
-
-CAMLprim value win_getcwd (value unit)
-{
- int res;
- wchar_t s[NT_MAX_PATH];
- CAMLparam0();
- CAMLlocal1 (path);
-
- res = GetCurrentDirectoryW (NT_MAX_PATH, s);
- if (res == 0) {
- win32_maperr(GetLastError());
- uerror("getcwd", Nothing);
- }
- /* Normalize the path */
- res = GetLongPathNameW (s, s, NT_MAX_PATH);
- if (res == 0) {
- win32_maperr(GetLastError());
- uerror("getcwd", Nothing);
- }
- /* Convert the drive letter to uppercase */
- if (s[0] >= L'a' && s[0] <= L'z') s[0] -= 32;
- path = copy_wstring(s);
- CAMLreturn (path);
-}
-
-CAMLprim value win_findfirstw(value name)
-{
- HANDLE h;
- WIN32_FIND_DATAW fileinfo;
-
- CAMLparam1(name);
- CAMLlocal3(v, valname, valh);
-
- h = FindFirstFileW((LPCWSTR) String_val(name),&fileinfo);
- if (h == INVALID_HANDLE_VALUE) {
- DWORD err = GetLastError();
- if ((err == ERROR_NO_MORE_FILES) || (err == ERROR_FILE_NOT_FOUND))
- raise_end_of_file();
- else {
- win32_maperr(err);
- uerror("opendir", Nothing);
- }
- }
- valname = copy_wstring(fileinfo.cFileName);
- valh = win_alloc_handle(h);
- v = alloc_small(2, 0);
- Field(v,0) = valname;
- Field(v,1) = valh;
- CAMLreturn (v);
-}
-
-CAMLprim value win_findnextw(value valh)
-{
- WIN32_FIND_DATAW fileinfo;
- BOOL retcode;
-
- CAMLparam1(valh);
-
- retcode = FindNextFileW(Handle_val(valh), &fileinfo);
- if (!retcode) {
- DWORD err = GetLastError();
- if (err == ERROR_NO_MORE_FILES)
- raise_end_of_file();
- else {
- win32_maperr(err);
- uerror("readdir", Nothing);
- }
- }
- CAMLreturn (copy_wstring(fileinfo.cFileName));
-}
-
-CAMLprim value win_findclosew(value valh)
-{
- CAMLparam1(valh);
-
- if (! FindClose(Handle_val(valh))) {
- win32_maperr(GetLastError());
- uerror("closedir", Nothing);
- }
- CAMLreturn (Val_unit);
-}
-
-CAMLprim value win_getenv(value var)
-{
- LPWSTR s;
- DWORD len;
- CAMLparam1(var);
- CAMLlocal1(res);
-
- s = stat_alloc (65536);
-
- len = GetEnvironmentVariableW((LPCWSTR) String_val(var), s, 65536);
- if (len == 0) { stat_free (s); raise_not_found(); }
-
- res = copy_wstring(s);
- stat_free (s);
- CAMLreturn (res);
-
-}
-
-CAMLprim value win_putenv(value var, value wvar, value v)
-{
- BOOL res;
- CAMLparam3(var, wvar, v);
-
- res = SetEnvironmentVariableW((LPCWSTR) String_val(wvar), (LPCWSTR) v);
- if (res == 0) {
- win32_maperr (GetLastError ());
- uerror("putenv", var);
- }
- CAMLreturn (Val_unit);
-}
+/****/
-CAMLprim value win_argv(value unit)
+static value win_hasconsole_gui_msg(DWORD h, const char *s)
{
- int n, i;
- LPWSTR * l;
-
- CAMLparam0();
- CAMLlocal2(v,res);
-
- l = CommandLineToArgvW (GetCommandLineW (), &n);
-
- if (l == NULL) {
- win32_maperr (GetLastError ());
- uerror("argv", Nothing);
- }
- res = caml_alloc (n, 0);
- for (i = 0; i < n; i++) {
- v = copy_wstring (l[i]);
- Store_field (res, i, v);
+ const char *u = "This is a GUI-only executable. Text console output "
+ "is not supported. To get text output, use the "
+ "executable intended for it (usually called unison.exe "
+ "or unison-text.exe) or redirect the output.";
+
+ if (!GetFileType((HANDLE) GetStdHandle(h))) {
+ MessageBoxA(NULL, strcmp(s, "") != 0 ? s : u, "Information", MB_OK);
+ return Val_false;
+ } else {
+ return Val_true;
}
- LocalFree (l);
- CAMLreturn (res);
}
-CAMLprim value w_create_process_native
-(value prog, value wprog, value wargs, value fd1, value fd2, value fd3)
+CAMLprim value win_hasconsole_gui_stdout(value s)
{
- int res, flags;
- PROCESS_INFORMATION pi;
- STARTUPINFOW si;
- wchar_t fullname [MAX_PATH];
- HANDLE h;
- CAMLparam5(wprog, wargs, fd1, fd2, fd3);
-
- res = SearchPathW (NULL, (LPCWSTR) String_val(wprog), L".exe",
- MAX_PATH, fullname, NULL);
- if (res == 0) {
- win32_maperr (GetLastError ());
- uerror("create_process", prog);
- }
-
- ZeroMemory(&si, sizeof(STARTUPINFO));
-
- si.cb = sizeof(STARTUPINFO);
- si.dwFlags = STARTF_USESTDHANDLES;
- si.hStdInput = Handle_val(fd1);
- si.hStdOutput = Handle_val(fd2);
- si.hStdError = Handle_val(fd3);
-
- flags = GetPriorityClass (GetCurrentProcess ());
- /*
- h = CreateFile ("CONOUT$", GENERIC_WRITE, FILE_SHARE_WRITE, NULL,
- OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, NULL);
- if (h != INVALID_HANDLE_VALUE)
- CloseHandle (h);
- else {
- flags |= CREATE_NEW_CONSOLE;
- // si.dwFlags |= STARTF_USESHOWWINDOW;
- // si.wShowWindow = SW_MINIMIZE;
- }
- */
-
- res = CreateProcessW (fullname, (LPWSTR) String_val(wargs),
- NULL, NULL, TRUE, flags,
- NULL, NULL, &si, &pi);
- if (res == 0) {
- win32_maperr (GetLastError ());
- uerror("create_process", prog);
- }
-
- CloseHandle (pi.hThread);
- CAMLreturn (Val_long (pi.hProcess));
+ CAMLparam1(s);
+ CAMLreturn(win_hasconsole_gui_msg(STD_OUTPUT_HANDLE, String_val(s)));
}
-CAMLprim value w_create_process(value * argv, int argn)
+CAMLprim value win_hasconsole_gui_stderr(value s)
{
- return w_create_process_native(argv[0], argv[1], argv[2],
- argv[3], argv[4], argv[5]);
+ CAMLparam1(s);
+ CAMLreturn(win_hasconsole_gui_msg(STD_ERROR_HANDLE, String_val(s)));
}
-/****/
-
CAMLprim value win_init_console(value unit)
{
CAMLparam0();
@@ -885,18 +510,18 @@ CAMLprim value win_init_console(value unit)
/* Return only handles that are not already redirected by user. */
if (!GetFileType(in_orig)) {
- tmp = caml_alloc_small(1, 0);
- Store_field(tmp, 0, win_alloc_handle(in));
+ tmp = caml_alloc(1, 0);
+ Store_field(tmp, 0, caml_win32_alloc_handle(in));
Store_field(ret, 0, tmp);
}
if (!GetFileType(out_orig)) {
- tmp = caml_alloc_small(1, 0);
- Store_field(tmp, 0, win_alloc_handle(out));
+ tmp = caml_alloc(1, 0);
+ Store_field(tmp, 0, caml_win32_alloc_handle(out));
Store_field(ret, 1, tmp);
}
if (!GetFileType(err_orig)) {
- tmp = caml_alloc_small(1, 0);
- Store_field(tmp, 0, win_alloc_handle(err));
+ tmp = caml_alloc(1, 0);
+ Store_field(tmp, 0, caml_win32_alloc_handle(err));
Store_field(ret, 2, tmp);
}
}
@@ -913,14 +538,15 @@ static void init_conin ()
FILE_SHARE_READ | FILE_SHARE_WRITE, NULL,
OPEN_EXISTING, 0, 0);
if (conin == INVALID_HANDLE_VALUE) {
- win32_maperr (GetLastError ());
- uerror("init_conin", Nothing);
+ caml_win32_maperr(GetLastError());
+ caml_uerror("init_conin", Nothing);
}
}
}
CAMLprim value win_get_console_mode (value unit)
{
+ CAMLparam0();
DWORD mode;
BOOL res;
@@ -928,37 +554,56 @@ CAMLprim value win_get_console_mode (value unit)
res = GetConsoleMode (conin, &mode);
if (res == 0) {
- win32_maperr (GetLastError ());
- uerror("get_console_mode", Nothing);
+ caml_win32_maperr(GetLastError());
+ caml_uerror("get_console_mode", Nothing);
}
- return (Val_int (mode));
+ CAMLreturn(Val_int(mode));
}
CAMLprim value win_set_console_mode (value mode)
{
+ CAMLparam1(mode);
BOOL res;
init_conin ();
res = SetConsoleMode (conin, Int_val(mode));
if (res == 0) {
- win32_maperr (GetLastError ());
- uerror("set_console_mode", Nothing);
+ caml_win32_maperr(GetLastError());
+ caml_uerror("set_console_mode", Nothing);
}
- return (Val_unit);
+ CAMLreturn(Val_unit);
}
CAMLprim value win_get_console_output_cp (value unit) {
- return (Val_int (GetConsoleOutputCP ()));
+ CAMLparam0();
+ CAMLreturn(Val_int(GetConsoleOutputCP()));
}
CAMLprim value win_set_console_output_cp (value cp) {
+ CAMLparam1(cp);
BOOL res;
res = SetConsoleOutputCP (Int_val (cp));
if (res == 0) {
- win32_maperr (GetLastError ());
- uerror("set_console_cp", Nothing);
+ caml_win32_maperr(GetLastError());
+ caml_uerror("set_console_cp", Nothing);
}
- return (Val_unit);
+ CAMLreturn(Val_unit);
+}
+
+CAMLprim value win_vt_capable(value fd)
+{
+ CAMLparam1(fd);
+ DWORD mode;
+
+ if (Handle_val(fd) == INVALID_HANDLE_VALUE) {
+ CAMLreturn(Val_int(0));
+ }
+
+ if (!GetConsoleMode(Handle_val(fd), &mode)) {
+ CAMLreturn(Val_int(0));
+ }
+
+ CAMLreturn(Val_int(mode & ENABLE_VIRTUAL_TERMINAL_PROCESSING));
}
diff --git a/src/system/win/system_impl.ml b/src/system/win/system_impl.ml
index f03bae0..333be5c 100644
--- a/src/system/win/system_impl.ml
+++ b/src/system/win/system_impl.ml
@@ -15,51 +15,4 @@
along with this program. If not, see <http://www.gnu.org/licenses/>.
*)
-module System = System_win.M (struct let useLongUNCPaths = false end)
-
-module Fs = struct
-
- let unicode = ref false
-
- let setUnicodeEncoding u = unicode := u
-
- let c1 f1 f2 v1 = if !unicode then f1 v1 else f2 v1
- let c2 f1 f2 v1 v2 = if !unicode then f1 v1 v2 else f2 v1 v2
- let c3 f1 f2 v1 v2 v3 = if !unicode then f1 v1 v2 v3 else f2 v1 v2 v3
-
- module G = System_generic
- module W = System_win.M (struct let useLongUNCPaths = true end)
-
- type fspath = string
-
- let fspathConcat v1 v2 = c2 W.fspathConcat G.fspathConcat v1 v2
- let fspathDirname v = c1 W.fspathDirname G.fspathDirname v
-
- type dir_handle = G.dir_handle
- = { readdir : unit -> string; closedir : unit -> unit }
-
- let symlink v1 v2 = c2 W.symlink G.symlink v1 v2
- let readlink v = c1 W.readlink G.readlink v
- let chown v1 v2 v3 = c3 W.chown G.chown v1 v2 v3
- let chmod v1 v2 = c2 W.chmod G.chmod v1 v2
- let utimes v1 v2 v3 = c3 W.utimes G.utimes v1 v2 v3
- let unlink v = c1 W.unlink G.unlink v
- let rmdir v = c1 W.rmdir G.rmdir v
- let mkdir v1 v2 = c2 W.mkdir G.mkdir v1 v2
- let rename v1 v2 = c2 W.rename G.rename v1 v2
- let stat v = c1 W.stat G.stat v
- let lstat v = c1 W.lstat G.lstat v
- let opendir v = c1 W.opendir G.opendir v
- let openfile v1 v2 v3 = c3 W.openfile G.openfile v1 v2 v3
- let open_in_gen v1 v2 v3 = c3 W.open_in_gen G.open_in_gen v1 v2 v3
- let open_out_gen v1 v2 v3 = c3 W.open_out_gen G.open_out_gen v1 v2 v3
- let getcwd v = c1 W.getcwd G.getcwd v
- let chdir v = c1 W.chdir G.chdir v
- let readlink v = c1 W.readlink G.readlink v
- let fingerprint v = c1 W.fingerprint G.fingerprint v
-
- let canSetTime v = c1 W.canSetTime G.canSetTime v
- let hasInodeNumbers v = c1 W.hasInodeNumbers G.hasInodeNumbers v
- let hasSymlink v = c1 W.hasSymlink G.hasSymlink v
- let hasCorrectCTime = if !unicode then W.hasCorrectCTime else G.hasCorrectCTime
-end
+include System_win
diff --git a/src/terminal.ml b/src/terminal.ml
index a960808..2618ca5 100644
--- a/src/terminal.ml
+++ b/src/terminal.ml
@@ -62,89 +62,6 @@ let authenticity s = Rx.match_string authenticityRx s
SSH password interaction.
*)
-(*
-let a1 = [|'p';'q';'r';'s';'t';'u';'v';'w';'x';'y';'z';'P';'Q';'R';'S';'T'|]
-let a2 = [|'0';'1';'2';'3';'4';'5';'6';'7';'8';'9';'a';'b';'c';'d';'e';'f'|]
-exception Break of (Unix.file_descr * string) option
-let ptyMasterOpen () =
- if not(Osx.isMacOSX or Osx.isLinux) then None else
- try
- (* Adapted from Stevens' Advanced Programming in Unix *)
- let x = "/dev/pty--" in
- for i = 0 to Array.length a1 do
- x.[8] <- a1.(i);
- for j = 0 to Array.length a2 do
- x.[9] <- a2.(j);
- let fdOpt =
- try Some(Unix.openfile x [Unix.O_RDWR] 0)
- with Unix.Unix_error _ -> None in
- match fdOpt with None -> ()
- | Some fdMaster ->
- x.[5] <- 't';
- raise (Break(Some(fdMaster,x)))
- done
- done;
- None
- with Break z -> z
-
-let ptySlaveOpen = function
- None -> None
- | Some(fdMaster,ttySlave) ->
- let slave =
- try Some (Unix.openfile ttySlave [Unix.O_RDWR] 0o600)
- with Unix.Unix_error _ -> None in
- (try Unix.close fdMaster with Unix.Unix_error(_,_,_) -> ());
- slave
-
-let printTermAttrs fd = (* for debugging *)
- let tio = Unix.tcgetattr fd in
- let boolPrint name x d =
- if x then Printf.printf "%s is ON (%s)\n" name d
- else Printf.printf "%s is OFF (%s)\n" name d in
- let intPrint name x d =
- Printf.printf "%s = %d (%s)\n" name x d in
- let charPrint name x d =
- Printf.printf "%s = '%c' (%s)\n" name x d in
- boolPrint "c_ignbrk" tio.Unix.c_ignbrk "Ignore the break condition.";
- boolPrint "c_brkint" tio.Unix.c_brkint "Signal interrupt on break condition.";
- boolPrint "c_ignpar" tio.Unix.c_ignpar "Ignore characters with parity errors.";
- boolPrint "c_parmrk" tio.Unix.c_parmrk "Mark parity errors.";
- boolPrint "c_inpck" tio.Unix.c_inpck "Enable parity check on input.";
- boolPrint "c_istrip" tio.Unix.c_istrip "Strip 8th bit on input characters.";
- boolPrint "c_inlcr" tio.Unix.c_inlcr "Map NL to CR on input.";
- boolPrint "c_igncr" tio.Unix.c_igncr "Ignore CR on input.";
- boolPrint "c_icrnl" tio.Unix.c_icrnl "Map CR to NL on input.";
- boolPrint "c_ixon" tio.Unix.c_ixon "Recognize XON/XOFF characters on input.";
- boolPrint "c_ixoff" tio.Unix.c_ixoff "Emit XON/XOFF chars to control input flow.";
- boolPrint "c_opost" tio.Unix.c_opost "Enable output processing.";
- intPrint "c_obaud" tio.Unix.c_obaud "Output baud rate (0 means close connection).";
- intPrint "c_ibaud" tio.Unix.c_ibaud "Input baud rate.";
- intPrint "c_csize" tio.Unix.c_csize "Number of bits per character (5-8).";
- intPrint "c_cstopb" tio.Unix.c_cstopb "Number of stop bits (1-2).";
- boolPrint "c_cread" tio.Unix.c_cread "Reception is enabled.";
- boolPrint "c_parenb" tio.Unix.c_parenb "Enable parity generation and detection.";
- boolPrint "c_parodd" tio.Unix.c_parodd "Specify odd parity instead of even.";
- boolPrint "c_hupcl" tio.Unix.c_hupcl "Hang up on last close.";
- boolPrint "c_clocal" tio.Unix.c_clocal "Ignore modem status lines.";
- boolPrint "c_isig" tio.Unix.c_isig "Generate signal on INTR, QUIT, SUSP.";
- boolPrint "c_icanon" tio.Unix.c_icanon "Enable canonical processing (line buffering and editing)";
- boolPrint "c_noflsh" tio.Unix.c_noflsh "Disable flush after INTR, QUIT, SUSP.";
- boolPrint "c_echo" tio.Unix.c_echo "Echo input characters.";
- boolPrint "c_echoe" tio.Unix.c_echoe "Echo ERASE (to erase previous character).";
- boolPrint "c_echok" tio.Unix.c_echok "Echo KILL (to erase the current line).";
- boolPrint "c_echonl" tio.Unix.c_echonl "Echo NL even if c_echo is not set.";
- charPrint "c_vintr" tio.Unix.c_vintr "Interrupt character (usually ctrl-C).";
- charPrint "c_vquit" tio.Unix.c_vquit "Quit character (usually ctrl-\\).";
- charPrint "c_verase" tio.Unix.c_verase "Erase character (usually DEL or ctrl-H).";
- charPrint "c_vkill" tio.Unix.c_vkill "Kill line character (usually ctrl-U).";
- charPrint "c_veof" tio.Unix.c_veof "End-of-file character (usually ctrl-D).";
- charPrint "c_veol" tio.Unix.c_veol "Alternate end-of-line char. (usually none).";
- intPrint "c_vmin" tio.Unix.c_vmin "Minimum number of characters to read before the read request is satisfied.";
- intPrint "c_vtime" tio.Unix.c_vtime "Maximum read wait (in 0.1s units).";
- charPrint "c_vstart" tio.Unix.c_vstart "Start character (usually ctrl-Q).";
- charPrint "c_vstop" tio.Unix.c_vstop "Stop character (usually ctrl-S)."
-*)
-
(* Implemented in file pty.c *)
type pty
external win_openpty : unit -> (Unix.file_descr * Unix.file_descr)
@@ -160,26 +77,57 @@ external c_openpty : unit -> Unix.file_descr * Unix.file_descr =
let openpty() = try Some (c_openpty ()) with Unix.Unix_error _ -> None
(* Utility functions copied from ocaml's unix.ml because they are not exported :-| *)
-let rec safe_dup fd =
- let new_fd = Unix.dup fd in
- if dumpFd new_fd >= 3 then
- new_fd
- else begin
- let res = safe_dup fd in
- Unix.close new_fd;
- res
- end
+(* Duplicate [fd] if needed to make sure it isn't one of the
+ standard descriptors (stdin, stdout, stderr).
+ Note that this function always leaves the standard descriptors open,
+ the caller must take care of closing them if needed.
+ The "cloexec" mode doesn't matter, because
+ the descriptor returned by [dup] will be closed before the [exec],
+ and because no other thread is running concurrently
+ (we are in the child process of a fork).
+ *)
+let rec file_descr_not_standard fd =
+ if dumpFd fd >= 3 then fd else file_descr_not_standard (Unix.dup fd)
+
let safe_close fd = try Unix.close fd with Unix.Unix_error _ -> ()
+
let perform_redirections new_stdin new_stdout new_stderr =
- let newnewstdin = safe_dup new_stdin in
- let newnewstdout = safe_dup new_stdout in
- let newnewstderr = safe_dup new_stderr in
+ let new_stdin = file_descr_not_standard new_stdin in
+ let new_stdout = file_descr_not_standard new_stdout in
+ let new_stderr = file_descr_not_standard new_stderr in
+ (* The three dup2 close the original stdin, stdout, stderr,
+ which are the descriptors possibly left open
+ by file_descr_not_standard *)
+ Unix.dup2 ~cloexec:false new_stdin Unix.stdin;
+ Unix.dup2 ~cloexec:false new_stdout Unix.stdout;
+ Unix.dup2 ~cloexec:false new_stderr Unix.stderr;
safe_close new_stdin;
safe_close new_stdout;
- safe_close new_stderr;
- Unix.dup2 newnewstdin Unix.stdin; Unix.close newnewstdin;
- Unix.dup2 newnewstdout Unix.stdout; Unix.close newnewstdout;
- Unix.dup2 newnewstderr Unix.stderr; Unix.close newnewstderr
+ safe_close new_stderr
+
+let rec safe_waitpid pid =
+ (* This function is intentionally synchronous so that it can be run during
+ cleanup code when Lwt threads might be stopped or otherwise be in an
+ unreliable state. *)
+ let kill_noerr si = try Unix.kill pid si with Unix.Unix_error _ -> () in
+ let t = Unix.gettimeofday () in
+ let rec aux st =
+ match Unix.waitpid [Unix.WNOHANG] pid with
+ | (0, _) ->
+ Unix.sleepf 0.002;
+ let dt = Unix.gettimeofday () -. t in
+ if dt >= 0.5 && st = 0 then begin
+ kill_noerr Sys.(if os_type = "Win32" then sigkill else sigterm);
+ aux 1
+ end else if dt >= 2.0 && st = 1 then begin
+ kill_noerr Sys.sigkill;
+ aux 2
+ end else
+ aux st
+ | (_, r) -> r
+ | exception Unix.Unix_error (EINTR, _, _) -> aux st
+ in
+ aux 0
let term_sessions = Hashtbl.create 3
@@ -208,8 +156,38 @@ let finally f g =
begin try g () with Sys_error _ | Unix.Unix_error _ -> () end;
raise e
+external win_alloc_console : unit -> Unix.file_descr option = "win_alloc_console"
+
let fallback_session cmd args new_stdin new_stdout new_stderr =
- (None, System.create_process cmd args new_stdin new_stdout new_stderr)
+ if Sys.os_type = "Win32" then begin
+ (* OCaml's [Unix.create_process] hides the Windows console window of
+ the child process unless the parent process already has a console.
+ This is unsuitable for running interactive child processes like
+ the ssh client. To make it possible to use the ssh client without pty,
+ we have to open a Windows console window before launching the child
+ process. Unfortunately, we can't know if the ssh client (or any other
+ remote shell client) requires user interaction via the Windows console
+ or not.
+
+ Ignore any errors because it is almost certain that the error indicates
+ that a console already exists (and we can't do anything about other
+ errors anyway).
+
+ If a new console was allocated and [Unix.stderr] is invalid (which
+ will happen in Windows for GUI without a console unless stderr is
+ redirected elsewhere; this is checked in the C stub) then also
+ redirect [Unix.stderr] to the new console. [new_stderr] is most likely
+ [Unix.stderr] and will therefore be associated with the new console. *)
+ try
+ match win_alloc_console () with
+ | None -> ()
+ | Some fd -> try Unix.dup2 fd Unix.stderr with Unix.Unix_error _ -> ()
+ with Unix.Unix_error _ -> ()
+ end;
+ let childPid =
+ System.create_process cmd args new_stdin new_stdout new_stderr in
+ Hashtbl.add term_sessions childPid (fun () -> ignore (safe_waitpid childPid));
+ (None, childPid)
let win_create_session cmd args new_stdin new_stdout new_stderr =
match win_openpty () with
@@ -227,7 +205,7 @@ let win_create_session cmd args new_stdin new_stdout new_stderr =
let fdIn = Lwt_unix.of_unix_file_descr masterIn
and fdOut = Lwt_unix.of_unix_file_descr masterOut in
let ret = Some (fdIn, fdOut) in
- Hashtbl.add term_sessions ret
+ Hashtbl.add term_sessions childPid
(fun () -> finally (fun () -> win_closepty pty)
(fun () -> finally (fun () -> Lwt_unix.close fdOut)
(fun () -> Lwt_unix.close fdIn)));
@@ -241,14 +219,19 @@ let unix_create_session cmd args new_stdin new_stdout new_stderr =
match openpty () with
None -> fallback_session cmd args new_stdin new_stdout new_stderr
| Some (masterFd, slaveFd) ->
-(*
- Printf.printf "openpty returns %d--%d\n" (dumpFd fdM) (dumpFd fdS); flush stdout;
- Printf.printf "new_stdin=%d, new_stdout=%d, new_stderr=%d\n"
- (dumpFd new_stdin) (dumpFd new_stdout) (dumpFd new_stderr) ; flush stdout;
-*)
+ Unix.set_close_on_exec masterFd;
+ Unix.set_close_on_exec slaveFd;
+ flush_all (); (* Clear buffers to avoid risk of double flushing by child.
+ Even this is not sufficient, strictly speaking, as there is a window
+ of opportunity to fill the buffer between flushing and calling fork. *)
begin match Unix.fork () with
0 ->
begin try
+ (* Child process stderr must redirected as early as possible to
+ make sure all error output is captured and visible in GUI. *)
+ Unix.dup2 ~cloexec:false slaveFd Unix.stderr;
+ (* new_stderr will be used by parent process only. *)
+ if new_stderr <> Unix.stderr then safe_close new_stderr;
Unix.close masterFd;
ignore (Unix.setsid ());
setControllingTerminal slaveFd;
@@ -256,11 +239,23 @@ let unix_create_session cmd args new_stdin new_stdout new_stderr =
let tio = Unix.tcgetattr slaveFd in
tio.Unix.c_echo <- false;
Unix.tcsetattr slaveFd Unix.TCSANOW tio;
+ (* Redirect ssh authentication errors to controlling terminal,
+ instead of new_stderr, so that they can be captured by GUI.
+ This will inevitably also redirect the remote stderr to GUI
+ as ssh's own error output is mixed with remote stderr output. *)
perform_redirections new_stdin new_stdout slaveFd;
Unix.execvp cmd args (* never returns *)
- with Unix.Unix_error _ ->
- Printf.eprintf "Some error in create_session child\n";
+ with Unix.Unix_error (e, s1, s2) ->
+ Printf.eprintf "Error in create_session child: [%s] (%s) %s\n"
+ s1 s2 (Unix.error_message e);
flush stderr;
+ (* FIXME: this should be Unix._exit (available from OCaml 4.12)
+ which doesn't flush buffers (or run other exit handlers).
+ When [_exit] is eventually used then to _completely_ avoid risk
+ of double flushing, [Unix.write Unix.stderr] should be used
+ above instead of [eprintf]. Using [_exit] and not using any
+ [Stdlib.out_channel] will avoid all buffering and exit handler
+ issues. *)
exit 127
end
| childPid ->
@@ -270,9 +265,10 @@ let unix_create_session cmd args new_stdin new_stdout new_stderr =
(* Unix.close slaveFd; *)
let fd = Lwt_unix.of_unix_file_descr masterFd in
let ret = Some (fd, fd) in
- Hashtbl.add term_sessions ret
+ Hashtbl.add term_sessions childPid
(fun () -> safe_close slaveFd;
- Lwt_unix.close fd);
+ finally (fun () -> Lwt_unix.close fd)
+ (fun () -> ignore (safe_waitpid childPid)));
(ret, childPid)
end
@@ -281,36 +277,124 @@ let create_session =
| "Win32" -> win_create_session
| _ -> unix_create_session
-let close_session = function
- | None -> ()
- | Some _ as fdopt ->
- try
- let cleanup = Hashtbl.find term_sessions fdopt in
- Hashtbl.remove term_sessions fdopt;
- cleanup ()
- with Not_found ->
- raise (Unix.Unix_error (Unix.EBADF, "Terminal.close_session", ""))
+let close_session pid =
+ try
+ let cleanup = Hashtbl.find term_sessions pid in
+ Hashtbl.remove term_sessions pid;
+ cleanup ()
+ with Not_found ->
+ raise (Unix.Unix_error (Unix.ESRCH, "Terminal.close_session", ""))
let (>>=) = Lwt.bind
-let escRemove = Str.regexp
- ("\\(\\(.\\|[\n\r]\\)+\027\\[[12]J\\)" (* Clear screen *)
- ^ "\\|\\(\027\\[[0-2]?J\\)" (* Clear screen *)
- ^ "\\|\\(\027\\[!p\\)" (* Soft reset *)
- ^ "\\|\\(\027\\][02];[^\007]*\007\\)" (* Set console window title *)
- ^ "\\|\\(\027\\[\\?25[hl]\\)" (* Show/hide cursor *)
- ^ "\\|\\(\027\\[[0-9;]*m\\)" (* Formatting *)
- ^ "\\|\\(\027\\[H\\)") (* Home *)
-
-let escSpace = Str.regexp "\027\\[\\([0-9]*\\)C"
+(* OpenSSH on Windows is known to produce at least the following escape
+ sequences. Examples of raw output with OCaml string escapes, starting from
+ beginning of line and ending at end of line, newline excluded:
+
+\027[2J\027[m\027[H\027]0;C:\\WINDOWS\\System32\\OpenSSH\\ssh.exe\007\027[?25h
+
+The authenticity of host 'example.com (127.0.0.1)' can't be established.\r\nECDSA key fingerprint is SHA256:CxGGHIVL7YDoSAtAzkIJNNaheGW7dDa7m7H+antMzDv. \r\nAre you sure you want to continue connecting (yes/no/[fingerprint])?\027[10X\027[1C
+
+ Most of these sequences are clearly useless for Unison and can be safely
+ ignored. The final sequence CSI 10 X CSI 1 C is a bit weird. In this
+ context, CSI 1 C can be interpreted as 1 space, although this is not
+ universal.
+
+ Some versions may have also emitted CSI ! p (VT220 soft reset) but this
+ no longer seems to be the case. *)
+
+type controlSt = No | Escape | EscapeSeq | CSI | OSC | StringSeq | OSCEsc | StringEsc
+
+(* A very primitive and minimal parser of ANSI X3.64/ECMA-48 control sequences.
+ It parses 7-bit control characters (C0) only. 8-bit control characters (C1)
+ are intentionally not parsed.
+ The vast majority of sequences are just ignored. *)
+let parseCtrlSeq s =
+ let s' = Buffer.create (String.length s) in
+ let add_char = Buffer.add_char s' in
+ let params = Buffer.create 32 in
+ let params_add_char = Buffer.add_char params in
+ let st = ref No in
+ let state x = st := x in
+ let parseEsc ch =
+ Buffer.clear params;
+ match ch with
+ | '\032'..'\047' -> state EscapeSeq
+ | '[' -> state CSI
+ | ']' -> state OSC
+ | 'X' | '^' | '_' -> state StringSeq
+ | _ -> state No
+ in
+ let parseCh ch =
+ match !st with
+ | No when ch = '\027' -> state Escape
+ | No -> add_char ch
+ | Escape -> parseEsc ch
+ | EscapeSeq ->
+ begin
+ match ch with
+ | '\024' | '\026' -> state No (* CAN, SUB *)
+ | '\000'..'\025' -> add_char ch (* Control charaters (roughly) *)
+ | '\027' -> state Escape
+ | '\048'..'\126' -> state No (* Final *)
+ | '\127'..'\255' -> state No (* Invalid *)
+ | _ -> ()
+ end
+ | CSI ->
+ begin
+ match ch with
+ | '\024' | '\026' -> state No (* CAN, SUB *)
+ | '\000'..'\025' -> add_char ch (* Control charaters (roughly) *)
+ | '\027' -> state Escape
+ | '\064'..'\126' -> (* Final *)
+ begin
+ state No;
+ match ch with
+ | 'C' -> (* cursor forward *)
+ let n =
+ try int_of_string (Buffer.contents params)
+ with Failure _ -> 1 in
+ for _ = 1 to n do add_char ' ' done
+ | _ -> ()
+ end
+ | '\127'..'\255' -> state No (* Invalid *)
+ | _ -> params_add_char ch
+ end
+ | OSC ->
+ begin
+ match ch with
+ | '\024' | '\026' -> state No (* CAN, SUB *)
+ | '\007' -> state No (* BEL *)
+ | '\000'..'\025' -> add_char ch (* Control charaters (roughly) *)
+ | '\027' -> state OSCEsc
+ | _ -> ()
+ end
+ | OSCEsc ->
+ begin
+ match ch with
+ | '\\' -> state No (* String terminator *)
+ | _ -> parseEsc ch
+ end
+ | StringSeq ->
+ begin
+ match ch with
+ | '\024' | '\026' -> state No (* CAN, SUB *)
+ | '\000'..'\025' -> add_char ch (* Control charaters (roughly) *)
+ | '\027' -> state StringEsc
+ | _ -> ()
+ end
+ | StringEsc ->
+ begin
+ match ch with
+ | '\\' -> state No (* String terminator *)
+ | _ -> parseEsc ch
+ end
+ in
+ String.iter parseCh s;
+ Buffer.contents s'
let processEscapes s =
- let whitesp s =
- try String.make (min 1 (int_of_string (Str.replace_matched "\\1" s))) ' '
- with Failure _ -> " "
- in
- Str.global_replace escRemove "" s
- |> Str.global_substitute escSpace whitesp
+ parseCtrlSeq s
(* Wait until there is input. If there is terminal input s,
return Some s. Otherwise, return None. *)
@@ -335,26 +419,80 @@ let rec termInput (fdTerm, _) fdInput =
(Lwt.choose
[readPrompt (); connectionEstablished ()])
+type termInteract = {
+ userInput : string -> (string -> unit) -> unit;
+ endInput : unit -> unit }
+
(* Read messages from the terminal and use the callback to get an answer *)
-let handlePasswordRequests (fdIn, fdOut) callback =
- let buf = Bytes.create 10000 in
- let rec loop () =
- Lwt_unix.read fdIn buf 0 10000 >>= (fun len ->
- if len = 0 then
- (* The remote end is dead *)
- Lwt.return ()
+let handlePasswordRequests (fdIn, fdOut) {userInput; endInput} isReady =
+ let scrollback = Buffer.create 32 in
+ let extract () =
+ let s = Buffer.contents scrollback in
+ let () = Buffer.clear scrollback in
+ s
+ in
+ let blen = 10000 in
+ let buf = Bytes.create blen in
+ let ended = ref false in
+ let closeInput () =
+ ended := true;
+ endInput ()
+ in
+ let terminalError loc e =
+ closeInput ();
+ Util.encodeException loc `Fatal e
+ in
+ let sendResponse s =
+ Lwt.catch
+ (fun () ->
+ if isReady () || !ended then Lwt.return 0
+ else Lwt_unix.write_substring fdOut (s ^ "\n") 0 (String.length s + 1))
+ (terminalError "writing to shell terminal")
+ in
+ let promptUser () =
+ let query = extract () in
+ if query = "\r\n" || query = "\n" || query = "\r" then ()
+ else
+ (* There is a tiny, almost non-existent risk of a broken escape sequence
+ at the very beginning or the very end of the buffer (this can happen
+ if bytes read from the pty end in the middle of a sequence and before
+ reading any further we charge ahead with processing what we've read).
+ Given that it's almost certainly ssh we're dealing with, this risk can
+ safely be ignored. *)
+ let querytext = processEscapes query in
+ if querytext = "" || String.trim querytext = "" then ()
else
- let query = Bytes.sub_string buf 0 len in
- if query = "\r\n" || query = "\n" || query = "\r" then
+ userInput querytext (fun s -> Lwt.ignore_result (sendResponse s))
+ in
+ let rec loop () =
+ (* When reading from a pty, the reading loop will not stop even when the
+ remote shell process dies. The reading will end (return 0 or an error)
+ when the pty is closed.
+ The only way to stop the reading loop without closing the pty is to
+ signal [isReady]. *)
+ Lwt.catch
+ (fun () -> Lwt_unix.read fdIn buf 0 blen)
+ (fun ex -> if isReady () || !ended then Lwt.return 0 else Lwt.fail ex)
+ >>= function
+ | 0 -> Lwt.return ()
+ | len ->
+ Buffer.add_string scrollback (Bytes.sub_string buf 0 len);
+ if isReady () then begin (* The shell connection has been established *)
+ closeInput ();
+ Lwt.return ()
+ end else begin
+ Lwt.ignore_result (Lwt_unix.sleep 0.05 >>= fun () -> (* Give time for connection checks *)
+ Lwt.return (if not !ended && not (isReady ()) then promptUser ()));
loop ()
- else begin
- let response = callback (processEscapes query) in
- Lwt_unix.write_substring fdOut
- (response ^ "\n") 0 (String.length response + 1)
- (* HACK: Sleep briefly to allow time for output to be
- generated and read in as a whole. *)
- >>= fun _ -> Lwt_unix.sleep 0.2 >>= (fun _ ->
- loop ())
- end)
+ end
+ in
+ let readTerm = Lwt.catch loop (terminalError "reading from shell terminal") in
+ let extractRemainingOutput clean =
+ closeInput ();
+ (* Give a final chance of reading the error output from the ssh process. *)
+ let timeout = Lwt_unix.sleep 0.3 in
+ Lwt.choose [readTerm; timeout] >>= fun () ->
+ if not clean then Lwt.return (extract ())
+ else Lwt.return (Util.trimWhitespace (processEscapes (extract ())))
in
- ignore (loop ())
+ (readTerm, extractRemainingOutput)
diff --git a/src/terminal.mli b/src/terminal.mli
index dfa83e3..369300c 100644
--- a/src/terminal.mli
+++ b/src/terminal.mli
@@ -7,8 +7,13 @@ val create_session :
Unix.file_descr -> Unix.file_descr -> Unix.file_descr ->
(Lwt_unix.file_descr * Lwt_unix.file_descr) option * int
-val close_session :
- (Lwt_unix.file_descr * Lwt_unix.file_descr) option -> unit
+val close_session : int -> unit
+
+(* [safe_waitpid] is intended for waiting on child processes that are
+ expected to terminate by themselves. If the child process has not
+ terminated after a short while then a SIGTERM is sent and if the
+ child process still doesn't terminate then a SIGKILL is sent. *)
+val safe_waitpid : int -> Unix.process_status
(* termInput fdTerm fdInput
Wait until there is input on at least one file descriptor.
@@ -17,8 +22,13 @@ val close_session :
val termInput :
(Lwt_unix.file_descr * Lwt_unix.file_descr) -> Lwt_unix.file_descr -> string option
+type termInteract = {
+ userInput : string -> (string -> unit) -> unit;
+ endInput : unit -> unit }
+
val handlePasswordRequests :
- (Lwt_unix.file_descr * Lwt_unix.file_descr) -> (string -> string) -> unit
+ (Lwt_unix.file_descr * Lwt_unix.file_descr) -> termInteract ->
+ (unit -> bool) -> unit Lwt.t * (bool -> string Lwt.t)
(* For recognizing messages from OpenSSH *)
val password : string -> bool
diff --git a/src/test.ml b/src/test.ml
index 784295e..c183101 100644
--- a/src/test.ml
+++ b/src/test.ml
@@ -104,6 +104,18 @@ type fs =
| Link of string
| Dir of (string * fs) list
+let mfs_rec fs = Umarshal.(sum3 string string (list (prod2 string fs id id))
+ (function
+ | File a -> I31 a
+ | Link a -> I32 a
+ | Dir a -> I33 a)
+ (function
+ | I31 a -> File a
+ | I32 a -> Link a
+ | I33 a -> Dir a))
+
+let mfs = Umarshal.rec1 mfs_rec
+
let rec equal fs1 fs2 =
match fs1,fs2 with
| File s1, File s2 -> s1=s2
@@ -157,7 +169,7 @@ let writefs p fs =
let checkRootEmpty : Common.root -> unit -> unit Lwt.t =
Remote.registerRootCmd
- "checkRootEmpty"
+ "checkRootEmpty" Umarshal.unit Umarshal.unit
(fun (fspath, ()) ->
if Os.exists fspath Path.empty then
raise (Util.Fatal (Printf.sprintf
@@ -167,26 +179,26 @@ let checkRootEmpty : Common.root -> unit -> unit Lwt.t =
let makeRootEmpty : Common.root -> unit -> unit Lwt.t =
Remote.registerRootCmd
- "makeRootEmpty"
+ "makeRootEmpty" Umarshal.unit Umarshal.unit
(fun (fspath, ()) ->
remove_file_or_dir fspath;
Lwt.return ())
let getfs : Common.root -> unit -> (fs option) Lwt.t =
Remote.registerRootCmd
- "getfs"
+ "getfs" Umarshal.unit Umarshal.(option mfs)
(fun (fspath, ()) ->
Lwt.return (readfs fspath))
let getbackup : Common.root -> unit -> (fs option) Lwt.t =
Remote.registerRootCmd
- "getbackup"
+ "getbackup" Umarshal.unit Umarshal.(option mfs)
(fun (fspath, ()) ->
Lwt.return (readfs (Stasher.backupDirectory ())))
let makeBackupEmpty : Common.root -> unit -> unit Lwt.t =
Remote.registerRootCmd
- "makeBackupEmpty"
+ "makeBackupEmpty" Umarshal.unit Umarshal.unit
(fun (fspath, ()) ->
let b = Stasher.backupDirectory () in
debug (fun () -> Util.msg "Removing %s\n" (Fspath.toDebugString b));
@@ -194,7 +206,7 @@ let makeBackupEmpty : Common.root -> unit -> unit Lwt.t =
let putfs : Common.root -> fs -> unit Lwt.t =
Remote.registerRootCmd
- "putfs"
+ "putfs" mfs Umarshal.unit
(fun (fspath, fs) ->
writefs fspath fs;
Lwt.return ())
@@ -223,12 +235,9 @@ let sync ?(verbose=false) () =
displayRis reconItemList
end;
minisleep 0.1;
- Lwt_unix.run (
- Lwt_util.iter
- (fun ri ->
- Transport.transportItem ri
- (Uutil.File.ofLine 0) (fun _ _ -> true))
- reconItemList);
+ Uicommon.transportItems (Array.of_list reconItemList) (fun _ -> true)
+ (fun _ ri ->
+ Transport.transportItem ri (Uutil.File.ofLine 0) (fun _ _ -> true));
Update.commitUpdates()
let currentTest = ref ""
@@ -244,13 +253,13 @@ let test() =
Prefs.set Trace.terse true;
Trace.sendLogMsgsToStderr := false;
- let origPrefs = Prefs.dump() in
+ let origPrefs = Prefs.dump 99 in
let runtest name prefs f =
Util.msg "%s...\n" name;
Util.convertUnixErrorsToFatal "Test.test" (fun() ->
currentTest := name;
- Prefs.load origPrefs;
+ Prefs.load origPrefs 99;
loadPrefs prefs;
debug (fun() -> Util.msg "Emptying backup directory\n");
Lwt_unix.run (Globals.allRootsIter (fun r -> makeBackupEmpty r ()));
@@ -326,6 +335,22 @@ let test() =
running fast enough that the whole thing happens within a second, then the
update will be missed! *)
+ (* Test that update propagation transport works *)
+ let maxth = [| "0"; "1"; "5"; "6"; "7" |] in
+ (* Number of threads: default (0); 1 (corner case);
+ one less, equal to, and one more than number of updates *)
+ for i = 1 to Array.length maxth do
+ runtest ("propagation 1." ^ string_of_int i) ["maxthreads = " ^ maxth.(i - 1)] (fun () ->
+ put R1 (Dir []); put R2 (Dir []); sync ();
+ let r1 = ["a", File "a"; "b", File "b"; "d1", Dir ["a", File "a1"; "b", File "b1"]]
+ and r2 = ["x", File "x"; "y", File "y"; "d2", Dir ["x", File "x2"; "y", File "y2"]] in
+ let expect = Dir (r1 @ r2) in
+ put R1 (Dir r1); put R2 (Dir r2); sync ();
+ check "1" R1 expect;
+ check "2" R2 expect
+ )
+ done;
+
(* Test that .git is treated atomically. *)
runtest "Atomicity of certain directories 1" ["atomic = Name .git";
"force = newer"] (fun() ->
@@ -399,7 +424,6 @@ let test() =
put R1 (Dir ["x", File "foo"]);
put R2 (Dir ["x", File "bar"]); sync();
(* Change contents without changing size and check that change is propagated *)
- Unix.sleep 2; (* in case time granularity is coarse on this FS *)
put R1 (Dir ["x", File "f00"]); sync();
check "3a" R1 (Dir ["x", File "f00"]);
@@ -443,7 +467,7 @@ let test() =
(* Create a file and a directory *)
put R1 (Dir ["foo", File "1"]); sync();
check "1" R1 (Dir [("foo", File "1")]);
- check "2" R1 (Dir [("foo", File "1")]);
+ check "2" R2 (Dir [("foo", File "1")]);
put R1 (Dir ["foo", File "2"]); sync();
check "3" R1 (Dir [("foo", File "2")]);
check "4" R2 (Dir [("foo", File "2"); (".bak.0.foo", File "1")]);
@@ -543,6 +567,77 @@ let test() =
*)
end;
+ if not bothRootsLocal then
+ begin
+ let localR, remoteR, localRaw =
+ match r1 with
+ | Common.Local, _ -> R1, R2, r1
+ | _ -> R2, R1, r2
+ in
+
+ (* Test RPC function "fingerprintSubfile" *)
+ runtest "RPC: transfer append" [] (fun () ->
+ let prefixLen = 1024 * 1024 + 1 in
+ let len = prefixLen + 31 in
+ let contents = String.make len '.' in
+ let fileName = "bigfile" in
+ let prefixPath = Path.fromString fileName in
+ let (workingDir, _) = Fspath.findWorkingDir (snd localRaw) prefixPath in
+ let prefixName = Path.toString (Os.tempPath ~fresh:false workingDir prefixPath) in
+ put remoteR (Dir [(fileName, File contents)]);
+ put localR (Dir [(prefixName, File (String.sub contents 0 prefixLen))]);
+ sync ();
+ check "1" localR (Dir [(fileName, File contents)]);
+ );
+
+ (* Test RPC function "updateProps" *)
+ runtest "RPC: update props" ["times = true"] (fun () ->
+ let state = [("a", File "x")] in
+ put remoteR (Dir state);
+ put localR (Dir []);
+ sync ();
+ (* Having to sleep here is an unfortunate side-effect of the current
+ Windows limitations-inspired time comparison algorithm which is
+ designed to work on FAT filesystems (2-second granularity). *)
+ Unix.sleep 2;
+ put remoteR (Dir state);
+ sync ();
+ check "1" localR (Dir state);
+ );
+
+ (* Test RPC function "replaceArchive" *)
+ runtest "RPC: replaceArchive" [] (fun () ->
+ put localR (Dir [("n", File "to delete")]);
+ put remoteR (Dir []);
+ sync ();
+ put remoteR (Dir []);
+ sync ();
+ check "1" localR (Dir []);
+ );
+
+ (* Test RPC functions "mkdir" and "setDirProp" *)
+ runtest "RPC: mkdir, setDirProp" [] (fun () ->
+ let state = [("subd", Dir [])] in
+ put localR (Dir state);
+ put remoteR (Dir []);
+ sync ();
+ check "1" remoteR (Dir state);
+ );
+
+ (* Test RPC function "setupTargetPaths" *)
+ runtest "RPC: merge" ["merge = Name ma -> echo x> NEW"; "backupcurr = Name ma"] (fun () ->
+ let result = match Sys.os_type with
+ | "Win32" -> ("ma", File "x\r\n")
+ | _ -> ("ma", File "x\n")
+ in
+ put localR (Dir [("ma", File "a")]);
+ put remoteR (Dir [("ma", File "b")]);
+ sync ();
+ check "1" localR (Dir [result]);
+ check "2" remoteR (Dir [result]);
+ );
+ end;
+
if !failures = 0 then
Util.msg "Success :-)\n"
else
diff --git a/src/transfer.ml b/src/transfer.ml
index 07fe4b7..0719f96 100644
--- a/src/transfer.ml
+++ b/src/transfer.ml
@@ -333,6 +333,13 @@ struct
(int32, Bigarray.int32_elt, Bigarray.c_layout) Bigarray.Array1.t;
strongChecksum : Bytearray.t }
+ let mrsync_block_info =
+ Umarshal.(prod5 int int int int32bigarray Bytearray.m
+ (fun {blockSize; blockCount; checksumSize; weakChecksum; strongChecksum} ->
+ blockSize, blockCount, checksumSize, weakChecksum, strongChecksum)
+ (fun (blockSize, blockCount, checksumSize, weakChecksum, strongChecksum) ->
+ {blockSize; blockCount; checksumSize; weakChecksum; strongChecksum}))
+
(*** PREPROCESS ***)
(* Worst case probability of a failure *)
diff --git a/src/transfer.mli b/src/transfer.mli
index 0feb7b4..1212882 100644
--- a/src/transfer.mli
+++ b/src/transfer.mli
@@ -77,6 +77,8 @@ module Rsync :
(* Built from the old file by the destination computer *)
type rsync_block_info
+ val mrsync_block_info : rsync_block_info Umarshal.t
+
(* Expected size of the [rsync_block_info] datastructure (in KiB). *)
val memoryFootprint : Uutil.Filesize.t -> Uutil.Filesize.t -> int
diff --git a/src/transport.ml b/src/transport.ml
index de827da..533c664 100644
--- a/src/transport.ml
+++ b/src/transport.ml
@@ -37,17 +37,50 @@ let fileSize uiFrom uiTo =
let maxthreads =
Prefs.createInt "maxthreads" 0
- "!maximum number of simultaneous file transfers"
+ ~category:(`Advanced `General)
+ "maximum number of simultaneous file transfers"
("This preference controls how much concurrency is allowed during \
the transport phase. Normally, it should be set reasonably high \
to maximize performance, but when Unison is used over a \
low-bandwidth link it may be helpful to set it lower (e.g. \
to 1) so that Unison doesn't soak up all the available bandwidth. \
The default is the special value 0, which mean 20 threads \
- when file content streaming is desactivated and 1000 threads \
+ when file content streaming is deactivated and 1000 threads \
when it is activated.")
-let actionReg = Lwt_util.make_region 50
+let maxThreads () =
+ let n = Prefs.read maxthreads in
+ if n > 0 then n else
+ if Prefs.read Remote.streamingActivated then 1000 else 20
+
+let run dispenseTask =
+ let runConcurrent limit dispenseTask =
+ let dispenseTask () = if Abort.isAll () then None else dispenseTask () in
+ let avail = ref limit in
+ let rec runTask thr =
+ Lwt.try_bind thr
+ (fun () -> nextTask (); Lwt.return ())
+ (fun _ -> nextTask (); assert false)
+ (* It is a programming error for an exception to reach this far. *)
+ |> ignore
+ and nextTask () =
+ match dispenseTask () with
+ | None -> incr avail
+ | Some thr -> runTask thr
+ in
+ let rec fillPool () =
+ match dispenseTask () with
+ | None -> ()
+ | Some thr -> decr avail; runTask thr; if !avail > 0 then fillPool ()
+ in
+ fillPool ()
+ in
+ (* When streaming, we can transfer many file simultaneously:
+ as the contents of only one file is transferred in one direction
+ at any time, little resource is consumed this way. *)
+ let limit = maxThreads () in
+ Lwt_util.resize_region !Files.copyReg limit;
+ runConcurrent limit dispenseTask
(* Logging for a thread: write a message before and a message after the
execution of the thread. *)
@@ -79,66 +112,55 @@ let logLwtNumbered (lwtDescription: string) (lwtShortDescription: string)
let doAction
fromRoot fromPath fromContents toRoot toPath toContents notDefault id =
- (* When streaming, we can transfer many file simultaneously:
- as the contents of only one file is transferred in one direction
- at any time, little resource is consumed this way. *)
- let limit =
- let n = Prefs.read maxthreads in
- if n > 0 then n else
- if Prefs.read Remote.streamingActivated then 1000 else 20
- in
- Lwt_util.resize_region actionReg limit;
- Lwt_util.resize_region Files.copyReg limit;
- Lwt_util.run_in_region actionReg 1 (fun () ->
- if not !Trace.sendLogMsgsToStderr then
- Trace.statusDetail (Path.toString toPath);
- Remote.Thread.unwindProtect (fun () ->
- match fromContents, toContents with
- {typ = `ABSENT}, {ui = uiTo} ->
- logLwtNumbered
- ("Deleting " ^ Path.toString toPath ^
- "\n from "^ root2string toRoot)
- ("Deleting " ^ Path.toString toPath)
- (fun () ->
- Files.delete fromRoot fromPath toRoot toPath uiTo notDefault)
- (* No need to transfer the whole directory/file if there were only
- property modifications on one side. (And actually, it would be
- incorrect to transfer a directory in this case.) *)
- | {status= `Unchanged | `PropsChanged; desc= fromProps; ui= uiFrom},
- {status= `Unchanged | `PropsChanged; desc= toProps; ui = uiTo} ->
- logLwtNumbered
- ("Copying properties for " ^ Path.toString toPath
- ^ "\n from " ^ root2string fromRoot ^ "\n to " ^
- root2string toRoot)
- ("Copying properties for " ^ Path.toString toPath)
- (fun () ->
- Files.setProp
- fromRoot fromPath toRoot toPath fromProps toProps uiFrom uiTo)
- | {typ = `FILE; ui = uiFrom}, {typ = `FILE; ui = uiTo} ->
- logLwtNumbered
- ("Updating file " ^ Path.toString toPath ^ "\n from " ^
- root2string fromRoot ^ "\n to " ^
- root2string toRoot)
- ("Updating file " ^ Path.toString toPath)
- (fun () ->
- Files.copy (`Update (fileSize uiFrom uiTo))
- fromRoot fromPath uiFrom [] toRoot toPath uiTo []
- notDefault id)
- | {ui = uiFrom; props = propsFrom}, {ui = uiTo; props = propsTo} ->
- logLwtNumbered
- ("Copying " ^ Path.toString toPath ^ "\n from " ^
- root2string fromRoot ^ "\n to " ^
- root2string toRoot)
- ("Copying " ^ Path.toString toPath)
- (fun () ->
- Files.copy `Copy
- fromRoot fromPath uiFrom propsFrom
- toRoot toPath uiTo propsTo
- notDefault id))
- (fun e -> Trace.log
- (Printf.sprintf
- "Failed: %s\n" (Util.printException e));
- return ()))
+ if not !Trace.sendLogMsgsToStderr then
+ Trace.statusDetail (Path.toString toPath);
+ Remote.Thread.unwindProtect (fun () ->
+ match fromContents, toContents with
+ {typ = `ABSENT}, {ui = uiTo} ->
+ logLwtNumbered
+ ("Deleting " ^ Path.toString toPath ^
+ "\n from "^ root2string toRoot)
+ ("Deleting " ^ Path.toString toPath)
+ (fun () ->
+ Files.delete fromRoot fromPath toRoot toPath uiTo notDefault)
+ (* No need to transfer the whole directory/file if there were only
+ property modifications on one side. (And actually, it would be
+ incorrect to transfer a directory in this case.) *)
+ | {status= `Unchanged | `PropsChanged; desc= fromProps; ui= uiFrom},
+ {status= `Unchanged | `PropsChanged; desc= toProps; ui = uiTo} ->
+ logLwtNumbered
+ ("Copying properties for " ^ Path.toString toPath
+ ^ "\n from " ^ root2string fromRoot ^ "\n to " ^
+ root2string toRoot)
+ ("Copying properties for " ^ Path.toString toPath)
+ (fun () ->
+ Files.setProp
+ fromRoot fromPath toRoot toPath fromProps toProps uiFrom uiTo)
+ | {typ = `FILE; ui = uiFrom}, {typ = `FILE; ui = uiTo} ->
+ logLwtNumbered
+ ("Updating file " ^ Path.toString toPath ^ "\n from " ^
+ root2string fromRoot ^ "\n to " ^
+ root2string toRoot)
+ ("Updating file " ^ Path.toString toPath)
+ (fun () ->
+ Files.copy (`Update (fileSize uiFrom uiTo))
+ fromRoot fromPath uiFrom [] toRoot toPath uiTo []
+ notDefault id)
+ | {ui = uiFrom; props = propsFrom}, {ui = uiTo; props = propsTo} ->
+ logLwtNumbered
+ ("Copying " ^ Path.toString toPath ^ "\n from " ^
+ root2string fromRoot ^ "\n to " ^
+ root2string toRoot)
+ ("Copying " ^ Path.toString toPath)
+ (fun () ->
+ Files.copy `Copy
+ fromRoot fromPath uiFrom propsFrom
+ toRoot toPath uiTo propsTo
+ notDefault id))
+ (fun e -> Trace.logonly
+ (Printf.sprintf
+ "Failed [%s]: %s\n" (Path.toString toPath) (Util.printException e));
+ return ())
let propagate root1 root2 reconItem id showMergeFn =
let path = reconItem.path1 in
diff --git a/src/transport.mli b/src/transport.mli
index 6f700f9..3707844 100644
--- a/src/transport.mli
+++ b/src/transport.mli
@@ -1,6 +1,17 @@
(* Unison file synchronizer: src/transport.mli *)
(* Copyright 1999-2020, Benjamin C. Pierce (see COPYING for details) *)
+(* Size of the pool of threads for executing transport actions. *)
+val maxThreads : unit -> int
+
+(* Run tasks concurrently in a pool of threads, acquiring tasks with
+ the supplied task dispenser function. The tasks received from
+ the task dispenser must not raise uncaught exceptions or return
+ with [Lwt.fail]. *)
+val run :
+ (unit -> (unit -> unit Lwt.t) option) (* Task dispenser *)
+ -> unit
+
(* Executes the actions implied by the reconItem list. *)
val transportItem :
Common.reconItem (* Updates that need to be performed *)
diff --git a/src/tree.ml b/src/tree.ml
index d09232b..8f4248f 100644
--- a/src/tree.ml
+++ b/src/tree.ml
@@ -20,6 +20,19 @@ type ('a, 'b) t =
Node of ('a * ('a, 'b) t) list * 'b option
| Leaf of 'b
+let m_rec ma mb m =
+ Umarshal.(sum2
+ (prod2 (list (prod2 ma m id id)) (option mb) id id)
+ mb
+ (function
+ | Node (a, b) -> I21 (a, b)
+ | Leaf a -> I22 a)
+ (function
+ | I21 (a, b) -> Node (a, b)
+ | I22 a -> Leaf a))
+
+let m ma mb = Umarshal.rec1 (m_rec ma mb)
+
type ('a, 'b) u =
{ anc: (('a, 'b) u * 'a) option;
node: 'b option;
diff --git a/src/tree.mli b/src/tree.mli
index 13d4041..a1688b9 100644
--- a/src/tree.mli
+++ b/src/tree.mli
@@ -7,6 +7,8 @@ type ('a, 'b) t =
Node of ('a * ('a, 'b) t) list * 'b option
| Leaf of 'b
+val m : 'a Umarshal.t -> 'b Umarshal.t -> ('a, 'b) t Umarshal.t
+
(* An "unfinished" tree *)
type ('a, 'b) u
diff --git a/src/ubase/META b/src/ubase/META
deleted file mode 100644
index 1ce33a7..0000000
--- a/src/ubase/META
+++ /dev/null
@@ -1,4 +0,0 @@
-requires = "unix"
-version = "0.1"
-archive(byte) = "ubase.cma"
-archive(native) = "ubase.cmxa"
diff --git a/src/ubase/Makefile b/src/ubase/Makefile
deleted file mode 100644
index c37a5ef..0000000
--- a/src/ubase/Makefile
+++ /dev/null
@@ -1,57 +0,0 @@
-NAME = ubase
-
-OBJECTS = \
- safelist.cmo uprintf.cmo util.cmo uarg.cmo prefs.cmo trace.cmo rx.cmo \
- myMap.cmo
-
-OCAMLC = ocamlfind ocamlc -g
-OCAMLOPT = ocamlfind ocamlopt
-OCAMLDEP = ocamldep
-
-XOBJECTS = $(OBJECTS:cmo=cmx)
-
-ARCHIVE = $(NAME).cma
-XARCHIVE = $(NAME).cmxa
-
-REQUIRES =
-PREDICATES =
-
-all: $(ARCHIVE)
-opt: $(XARCHIVE)
-
-$(ARCHIVE): $(OBJECTS)
- $(OCAMLC) -a -o $(ARCHIVE) -package "$(REQUIRES)" -linkpkg \
- -predicates "$(PREDICATES)" $(OBJECTS)
-$(XARCHIVE): $(XOBJECTS)
- $(OCAMLOPT) -a -o $(XARCHIVE) -package "$(REQUIRES)" -linkpkg \
- -predicates "$(PREDICATES)" $(XOBJECTS)
-
-.SUFFIXES: .cmo .cmi .cmx .ml .mli
-
-.ml.cmo:
- $(OCAMLC) -package "$(REQUIRES)" -predicates "$(PREDICATES)" \
- -c $<
-.mli.cmi:
- $(OCAMLC) -package "$(REQUIRES)" -predicates "$(PREDICATES)" \
- -c $<
-.ml.cmx:
- $(OCAMLOPT) -package "$(REQUIRES)" -predicates "$(PREDICATES)" \
- -c $<
-
-depend: *.ml *.mli
- $(OCAMLDEP) *.ml *.mli > depend
-include depend
-
-install: all
- { test ! -f $(XARCHIVE) || extra="$(XARCHIVE) "`basename $(XARCHIVE) .cmxa`.a; }; \
- ocamlfind install $(NAME) *.mli *.cmi $(ARCHIVE) META $$extra
-
-uninstall:
- ocamlfind remove $(NAME)
-
-clean::
- rm -f *.cmi *.cmo *.cmx *.cma *.cmxa *.a *.o *~ *.bak
-
-# Used by BCP to update Harmony's copy of these files from Unison's
-update:
- cp $(HOME)/current/unison/trunk/src/ubase/{*.ml,*.mli,Makefile} .
\ No newline at end of file
diff --git a/src/ubase/myMap.ml b/src/ubase/myMap.ml
index 8b21ac0..213c600 100644
--- a/src/ubase/myMap.ml
+++ b/src/ubase/myMap.ml
@@ -18,6 +18,7 @@ Some functions have been added to suite Unison needs.
module type OrderedType =
sig
type t
+ val m : t Umarshal.t
val compare: t -> t -> int
end
@@ -25,6 +26,7 @@ module type S =
sig
type key
type +'a t
+ val m : 'a Umarshal.t -> 'a t Umarshal.t
val empty: 'a t
val is_empty: 'a t -> bool
val add: key -> 'a -> 'a t -> 'a t
@@ -262,4 +264,8 @@ module Make(Ord: OrderedType) = struct
`Ok
| Node (l, v, _, r, _) ->
val_combine (validate_left l v) (validate_right v r)
+
+ let m m = Umarshal.(sum1 (list (prod2 Ord.m m id id))
+ (fun x -> fold (fun k v accu -> (k, v) :: accu) x [])
+ (fun x -> List.fold_left (fun accu (k, v) -> add k v accu) empty x))
end
diff --git a/src/ubase/myMap.mli b/src/ubase/myMap.mli
index 3fcd0f5..9b3f0f1 100644
--- a/src/ubase/myMap.mli
+++ b/src/ubase/myMap.mli
@@ -29,6 +29,7 @@ module type OrderedType =
sig
type t
(** The type of the map keys. *)
+ val m : t Umarshal.t
val compare : t -> t -> int
(** A total ordering function over the keys.
This is a two-argument function [f] such that
@@ -48,6 +49,8 @@ module type S =
type (+'a) t
(** The type of maps from type [key] to type ['a]. *)
+ val m : 'a Umarshal.t -> 'a t Umarshal.t
+
val empty: 'a t
(** The empty map. *)
diff --git a/src/ubase/prefs.ml b/src/ubase/prefs.ml
index 7b96384..bb840e1 100644
--- a/src/ubase/prefs.ml
+++ b/src/ubase/prefs.ml
@@ -80,27 +80,35 @@ let resetToDefaults () =
type dumpedPrefs = (string * bool * string) list
-let dumpers = ref ([] : (string * bool * (unit->string)) list)
-let loaders = ref (Util.StringMap.empty : (string->unit) Util.StringMap.t)
+let mdumpedPrefs = Umarshal.(list (prod3 string bool string id id))
-let adddumper name optional f =
- dumpers := (name,optional,f) :: !dumpers
+let dumpers = ref ([] : (string * bool * (unit->bool) * (int->string)) list)
+let loaders = ref (Util.StringMap.empty : (int->string->unit) Util.StringMap.t)
+let ignored = ref []
+
+let adddumper name optional send f =
+ dumpers := (name,optional,send,f) :: !dumpers
let addloader name f =
loaders := Util.StringMap.add name f !loaders
-let dump () = Safelist.map (fun (name, opt, f) -> (name, opt, f())) !dumpers
+let addignored name =
+ ignored := name :: !ignored
+
+let dump rpcVer =
+ Safelist.filter (fun (_, _, sf, _) -> sf ()) !dumpers
+ |> Safelist.map (fun (name, opt, _, f) -> (name, opt, f rpcVer))
-let load d =
+let load d rpcVer =
Safelist.iter
(fun (name, opt, dumpedval) ->
match
try Some (Util.StringMap.find name !loaders) with Not_found -> None
with
Some loaderfn ->
- loaderfn dumpedval
+ loaderfn rpcVer dumpedval
| None ->
- if not opt then
+ if not opt && not (Safelist.mem name !ignored) then
raise (Util.Fatal
("Preference "^name^" not found: \
inconsistent Unison versions??")))
@@ -131,101 +139,192 @@ let aliasMap = ref (Util.StringMap.empty : string Util.StringMap.t)
let canonicalName nm =
try Util.StringMap.find nm !aliasMap with Not_found -> nm
+type topic = [
+ | `General
+ | `Sync
+ | `Syncprocess
+ | `Syncprocess_CLI
+ | `CLI
+ | `GUI
+ | `Remote
+ | `Archive ]
+
+type group = [
+ | `Basic of topic
+ | `Advanced of topic
+ | `Expert
+ | `Internal of
+ [ `Pseudo | `Devel | `Other ] ]
+
+let isInternal = function
+ | `Internal _ -> true
+ | _ -> false
+
+let topic = function
+ | `General -> "General"
+ | `Sync -> "What to sync"
+ | `Syncprocess -> "How to sync"
+ | `Syncprocess_CLI -> "How to sync (text interface (CLI) only)"
+ | `CLI -> "Text interface (CLI)"
+ | `GUI -> "Graphical interface (GUI)"
+ | `Remote -> "Remote connections"
+ | `Archive -> "Archive management"
+
type typ =
[`BOOL | `INT | `STRING | `STRING_LIST | `BOOLDEF | `CUSTOM | `UNKNOWN]
-(* prefType : prefName -> type *)
-let prefType = ref (Util.StringMap.empty : typ Util.StringMap.t)
-
-let typ nm = try Util.StringMap.find nm !prefType with Not_found -> `UNKNOWN
-
-(* prefs: prefName -> (doc, pspec, fulldoc) *)
+type apref =
+ {
+ category : group;
+ doc : string;
+ pspec : Uarg.spec;
+ fulldoc : string;
+ typ : typ;
+ cli_only : bool;
+ deprec : bool;
+ }
+
+(* prefs: prefName -> apref *)
let prefs =
- ref (Util.StringMap.empty : (string * Uarg.spec * string) Util.StringMap.t)
+ ref (Util.StringMap.empty : apref Util.StringMap.t)
+
+let typ nm =
+ try let {typ; _} = Util.StringMap.find nm !prefs in typ with
+ | Not_found -> `UNKNOWN
let documentation nm =
try
- let (doc, _, fulldoc) = Util.StringMap.find nm !prefs in
- if doc <> "" && doc.[0] = '*' then raise Not_found;
- let basic = doc = "" || doc.[0] <> '!' in
+ let {category; doc; fulldoc; deprec; _} = Util.StringMap.find nm !prefs in
+ if isInternal category then raise Not_found;
let doc =
- if not basic then
- String.sub doc 1 (String.length doc - 1)
- else
- doc
+ if not deprec then doc
+ else "(Deprecated) " ^ doc
in
- (doc, fulldoc, basic)
+ let fulldoc =
+ if not deprec then fulldoc
+ else "{\\em (Deprecated)} " ^ fulldoc
+ in
+ (doc, fulldoc)
with Not_found ->
- ("", "", false)
+ ("", "")
-let list () =
+let category nm =
+ try
+ let {category; _} = Util.StringMap.find nm !prefs in
+ Some category
+ with Not_found ->
+ None
+
+let list include_cli_only =
List.sort String.compare
- (Util.StringMap.fold (fun nm _ l -> nm :: l) !prefType [])
+ (Util.StringMap.fold
+ (fun nm {category; cli_only; _} l ->
+ if (not cli_only || include_cli_only) && not (isInternal category) then
+ nm :: l
+ else l)
+ !prefs [])
(* aliased pref has *-prefixed doc and empty fulldoc *)
let alias pref newname =
(* pref must have been registered, so name pref is not empty, and will be *)
(* found in the map, no need for catching exception *)
- let (_,pspec,_) = Util.StringMap.find (Safelist.hd (name pref)) !prefs in
- prefs := Util.StringMap.add newname ("*", pspec, "") !prefs;
+ let pref' = Util.StringMap.find (Safelist.hd (name pref)) !prefs in
+ let pref' = {pref' with category = `Internal `Other; doc = "*"; fulldoc = ""} in
+ prefs := Util.StringMap.add newname pref' !prefs;
+ let () =
+ try
+ let loader = Util.StringMap.find (Safelist.hd (name pref)) !loaders in
+ addloader newname loader
+ with Not_found -> ()
+ in
aliasMap := Util.StringMap.add newname (Safelist.hd (name pref)) !aliasMap;
pref.names <- newname :: pref.names
-let registerPref name typ pspec doc fulldoc =
+let combine_pspec f = function
+ | Uarg.Bool f' -> Uarg.Bool (fun x -> f' x; f ())
+ | Uarg.String f' -> Uarg.String (fun x -> f' x; f ())
+ | Uarg.Int f' -> Uarg.Int (fun x -> f' x; f ())
+ | _ -> assert false
+
+let deprecatedPref name p =
+ combine_pspec @@ fun () ->
+ Util.warn ("Preference \"" ^ name ^ "\" is deprecated!\n"
+ ^ "It may be removed in the next release, so you should\n"
+ ^ "stop using this preference on the command line and\n"
+ ^ "in the profiles."
+ ^ (if read p <> readDefault p then "" else
+ "\nYou will not lose out on anything; you have currently\n"
+ ^ "set this preference to its default value."))
+
+let registerPref name typ cell pspec category cli_only deprec doc fulldoc =
if Util.StringMap.mem name !prefs then
raise (Util.Fatal ("Preference " ^ name ^ " registered twice"));
- prefs := Util.StringMap.add name (doc, pspec, fulldoc) !prefs;
- (* Ignore internal preferences *)
- if doc = "" || doc.[0] <> '*' then
- prefType := Util.StringMap.add name typ !prefType
-
-let createPrefInternal name typ local default doc fulldoc printer parsefn =
+ let pspec =
+ if not deprec then pspec
+ else deprecatedPref name cell pspec in
+ let pref = {category; doc; pspec; fulldoc; typ; cli_only; deprec} in
+ prefs := Util.StringMap.add name pref !prefs
+
+let createPrefInternal name typ category cli_only local send default deprecated doc fulldoc printer parsefn m =
+ let m = Umarshal.(prod2 m (list string) id id) in
let newCell = rawPref default name in
- registerPref name typ (parsefn newCell) doc fulldoc;
+ registerPref name typ newCell (parsefn newCell) category cli_only deprecated doc fulldoc;
+ let (local, send) =
+ if not cli_only then (local, send)
+ else (true, Some (fun () -> false))
+ in
adddumper name local
- (fun () -> Marshal.to_string (newCell.value, newCell.names) []);
+ (fun () -> match send with None -> true | Some f -> f ())
+ (function
+ | 0 -> Marshal.to_string (newCell.value, newCell.names) []
+ | _ -> Umarshal.to_string m (newCell.value, newCell.names));
addprinter name (fun () -> printer newCell.value);
addresetter
(fun () ->
newCell.setInProfile <- false; newCell.value <- newCell.defaultValue);
addloader name
- (fun s ->
- let (value, names) = Marshal.from_string s 0 in
+ (fun rpcVer s ->
+ if not cli_only then (* Better for compatibility to not fail if cli_only *)
+ let (value, names) =
+ match rpcVer with
+ | 0 -> Marshal.from_string s 0
+ | _ -> Umarshal.from_string m s 0
+ in
newCell.value <- value);
newCell
-let create name ?(local=false) default doc fulldoc intern printer =
- createPrefInternal name `CUSTOM local default doc fulldoc printer
+let create name ~category ?(cli_only=false) ?(local=false) ?send default ?(deprecated=false) doc fulldoc intern printer m =
+ createPrefInternal name `CUSTOM category cli_only local send default deprecated doc fulldoc printer
(fun cell -> Uarg.String (fun s -> set cell (intern (read cell) s)))
+ m
-let createBool name ?(local=false) default doc fulldoc =
+let createBool name ~category ?(cli_only=false) ?(local=false) ?send default ?(deprecated=false) doc fulldoc =
let doc = if default then doc ^ " (default true)" else doc in
- createPrefInternal name `BOOL local default doc fulldoc
+ createPrefInternal name `BOOL category cli_only local send default deprecated doc fulldoc
(fun v -> [if v then "true" else "false"])
(fun cell -> Uarg.Bool (fun b -> set cell b))
+ Umarshal.bool
-let createInt name ?(local=false) default doc fulldoc =
- createPrefInternal name `INT local default doc fulldoc
+let createInt name ~category ?(cli_only=false) ?(local=false) ?send default ?(deprecated=false) doc fulldoc =
+ createPrefInternal name `INT category cli_only local send default deprecated doc fulldoc
(fun v -> [string_of_int v])
(fun cell -> Uarg.Int (fun i -> set cell i))
+ Umarshal.int
-let createString name ?(local=false) default doc fulldoc =
- createPrefInternal name `STRING local default doc fulldoc
+let createString name ~category ?(cli_only=false) ?(local=false) ?send default ?(deprecated=false) doc fulldoc =
+ createPrefInternal name `STRING category cli_only local send default deprecated doc fulldoc
(fun v -> [v])
(fun cell -> Uarg.String (fun s -> set cell s))
+ Umarshal.string
-let createFspath name ?(local=false) default doc fulldoc =
- createPrefInternal name `STRING local default doc fulldoc
- (fun v -> [System.fspathToString v])
- (fun cell -> Uarg.String (fun s -> set cell (System.fspathFromString s)))
-
-let createStringList name ?(local=false) doc fulldoc =
- createPrefInternal name `STRING_LIST local [] doc fulldoc
+let createStringList name ~category ?(cli_only=false) ?(local=false) ?send ?(deprecated=false) doc fulldoc =
+ createPrefInternal name `STRING_LIST category cli_only local send [] deprecated doc fulldoc
(fun v -> v)
(fun cell -> Uarg.String (fun s -> set cell (s:: read cell)))
+ Umarshal.(list string)
-let createBoolWithDefault name ?(local=false) doc fulldoc =
- createPrefInternal name `BOOLDEF local `Default doc fulldoc
+let createBoolWithDefault name ~category ?(cli_only=false) ?(local=false) ?send ?(deprecated=false) doc fulldoc =
+ createPrefInternal name `BOOLDEF category cli_only local send `Default deprecated doc fulldoc
(fun v -> [match v with
`True -> "true"
| `False -> "false"
@@ -240,6 +339,18 @@ let createBoolWithDefault name ?(local=false) doc fulldoc =
| _ -> `False
in
set cell v))
+ Umarshal.(sum3 unit unit unit
+ (function
+ | `True -> I31 ()
+ | `False -> I32 ()
+ | `Default -> I33 ())
+ (function
+ | I31 () -> `True
+ | I32 () -> `False
+ | I33 () -> `Default))
+
+let markRemoved name =
+ addignored name
(*****************************************************************************)
(* Preferences file parsing *)
@@ -261,12 +372,18 @@ let string2int name string =
(* Takes a filename and returns a list of "parsed lines" containing
(filename, lineno, varname, value)
in the same order as in the file. *)
-let rec readAFile ?(fail=true) ?(add_ext=true) filename
- : (string * int * string * string) list =
+let rec readAFile ?(fail=true) ?(add_ext=true) filename =
+ let path = profilePathname ~add_ext:add_ext filename in
+ let locname =
+ if add_ext then
+ Printf.sprintf "Profile \"%s\" (file \"%s\")" filename path
+ else
+ Printf.sprintf "File \"%s\"" path
+ in
let bom = "\xef\xbb\xbf" in (* BOM: UTF-8 byte-order mark *)
- let rec loop chan lines =
+ let rec loop chan lineNum lines =
match (try Some(input_line chan) with End_of_file -> None) with
- None -> close_in chan; parseLines filename lines
+ None -> close_in chan; parseLines lines
| Some(theLine) ->
let theLine =
(* A lot of Windows tools start a UTF-8 encoded file by a
@@ -276,40 +393,51 @@ let rec readAFile ?(fail=true) ?(add_ext=true) filename
else
theLine
in
- loop chan (theLine::lines)
+ loop chan (lineNum + 1) (((locname, lineNum), theLine) :: lines)
in
let chan =
try
- let path = profilePathname ~add_ext:add_ext filename in
profileFiles := (path, System.stat path) :: !profileFiles;
Some (System.open_in_bin path)
with Unix.Unix_error _ | Sys_error _ -> None
in
match chan, fail with
- None, true ->
- raise(Util.Fatal(Printf.sprintf "Preference file %s not found" filename))
+ | None, true when add_ext ->
+ raise (Util.Fatal (Printf.sprintf
+ "Profile %s not found (looking for file %s)" filename path))
+ | None, true ->
+ raise (Util.Fatal (Printf.sprintf
+ "Preference file %s not found" path))
| None, false -> []
- | Some chan, _ -> loop chan []
+ | Some chan, _ ->
+ try loop chan 1 [] with e -> close_in_noerr chan; raise e
(* Takes a list of strings in reverse order and yields a list of "parsed lines"
in correct order *)
-and parseLines filename lines =
- let rec loop lines lineNum res =
+and parseLines lines =
+ let rec loop lines res =
match lines with
[] -> res
- | theLine :: rest ->
+ | (((locname, lineNum) as loc), theLine) :: rest ->
let theLine = Util.removeTrailingCR theLine in
let l = Util.trimWhitespace theLine in
let includes ~fail ~add_ext =
match Util.splitIntoWords theLine ' ' with
[_;f] ->
- let sublines = readAFile f ~fail:fail ~add_ext:add_ext in
- loop rest (lineNum+1) (Safelist.append sublines res)
+ let sublines =
+ try
+ readAFile f ~fail:fail ~add_ext:add_ext
+ with Util.Fatal err ->
+ raise (Util.Fatal (Printf.sprintf
+ "Included from %s, line %d:\n%s"
+ (String.uncapitalize_ascii locname) lineNum err))
+ in
+ loop rest (Safelist.append sublines res)
| _ -> raise (Util.Fatal(Printf.sprintf
- "File \"%s\", line %d:\nGarbled 'include' directive: %s"
- filename lineNum theLine)) in
+ "%s, line %d:\nGarbled 'include' directive: %s"
+ locname lineNum theLine)) in
if l = "" || l.[0]='#' then
- loop rest (lineNum+1) res
+ loop rest res
else if Util.startswith theLine "include " then
includes ~fail:true ~add_ext:true
else if Util.startswith theLine "source " then
@@ -322,19 +450,24 @@ and parseLines filename lines =
match Util.splitAtChar theLine '=' with
i, Some j -> let (varName, theResult) = (fun f (i,j) -> (f i,f j))
Util.trimWhitespace (i,j) in
- loop rest (lineNum+1) ((filename, lineNum, varName, theResult)::res)
+ loop rest ((loc, varName, theResult) :: res)
| _ -> (* theLine does not contain '=' *)
raise (Util.Fatal(Printf.sprintf
- "File \"%s\", line %d:\nGarbled line (no '='):\n%s"
- filename lineNum theLine)) in
- loop lines 1 []
+ "%s, line %d:\nGarbled line (no '='): %s"
+ locname lineNum theLine)) in
+ loop lines []
let processLines lines =
Safelist.iter
- (fun (fileName, lineNum, varName,theResult) ->
+ (fun ((locName, lineNum), varName, theResult) ->
try
- let _, theFunction, _ = Util.StringMap.find varName !prefs in
- match theFunction with
+ let pref = Util.StringMap.find varName !prefs in
+ if pref.category = `Internal `Pseudo then raise Not_found;
+ if pref.cli_only then
+ raise (IllegalValue ("\"" ^ varName
+ ^ "\" is a command line-only option; "
+ ^ "it must not be present in a profile."));
+ match pref.pspec with
Uarg.Bool boolFunction ->
boolFunction (string2bool varName theResult)
| Uarg.Int intFunction ->
@@ -343,11 +476,11 @@ let processLines lines =
stringFunction theResult
| _ -> assert false
with Not_found ->
- raise (Util.Fatal ("File \""^ fileName ^ "\", line " ^
+ raise (Util.Fatal (locName ^ ", line " ^
string_of_int lineNum ^ ": `" ^
varName ^ "' is not a valid option"))
| IllegalValue str ->
- raise(Util.Fatal("File \""^ fileName ^ "\", line " ^
+ raise (Util.Fatal (locName ^ ", line " ^
string_of_int lineNum ^ ": " ^ str)))
lines
@@ -357,19 +490,36 @@ let loadTheFile () =
| Some(n) -> processLines(readAFile n)
let loadStrings l =
- processLines (parseLines "<internal>" l)
+ let rec loop n out = function
+ | [] -> processLines (parseLines out)
+ | h :: t -> loop (n + 1) ((("<internal preferences>", n), h) :: out) t
+ in
+ loop 1 [] l
(*****************************************************************************)
(* Command-line parsing *)
(*****************************************************************************)
-let opts = ref
- [("source",
- Uarg.String (fun s -> processLines @@ readAFile ~add_ext:false s),
- "include a file's preferences");
- ("include",
- Uarg.String (fun s -> processLines @@ readAFile s),
- "include a profile file's preferences")]
+let _ = create "source" ()
+ ~category:(`Advanced `General)
+ ~cli_only:true
+ "include a file's preferences"
+ "Include preferences from a file. \\texttt{source \\ARG{name}} reads the \
+ file \\showtt{name} in the \\texttt{.unison} directory and includes its \
+ contents as if it was part of a profile or given directly on command line."
+ (fun _ s -> processLines (readAFile ~add_ext:false s))
+ (fun v -> []) Umarshal.unit
+
+let _ = create "include" ()
+ ~category:(`Advanced `General)
+ ~cli_only:true
+ "include a profile's preferences"
+ "Include preferences from a profile. \\texttt{include \\ARG{name}} reads \
+ the profile \\showtt{name} (or file \\showtt{name} in the \\texttt{.unison} \
+ directory if profile \\showtt{name} does not exist) and includes its \
+ contents as if it was part of a profile or given directly on command line."
+ (fun _ s -> processLines (readAFile s))
+ (fun v -> []) Umarshal.unit
let prefArg = function
Uarg.Bool(_) -> ""
@@ -377,49 +527,83 @@ let prefArg = function
| Uarg.String(_) -> "xxx"
| _ -> assert false
-(* [argspecs hook] returns a list of specs for [Uarg.parse] *)
+(* Prepare a list of specs for [Uarg.parse] *)
let argspecs hook =
- let f (name, pspec, doc) l =
- ("-" ^ name, hook name pspec, "") :: l in
- Safelist.fold_right f !opts @@
- Util.StringMap.fold (fun name (doc, pspec, _) -> f (name, pspec, doc)) !prefs
- []
-
-let oneLineDocs u =
- let formatOne name pspec doc p =
- (* if [p] format a one line message documenting a preference *)
- if not p then "" else
- let doc = if doc.[0] = '!'
- then String.sub doc 1 ((String.length doc) - 1)
- else doc in
+ Util.StringMap.fold
+ (fun name pref l ->
+ if pref.category <> `Internal `Pseudo then
+ ("-" ^ name, hook name pref.pspec, "") :: l
+ else l)
+ !prefs []
+
+let title = function
+ | `Advanced `Sync -> "Fine-tune sync"
+ | `Advanced `General -> "Other"
+ | `Basic t | `Advanced t -> topic t
+ | `Expert -> ""
+ | `Internal _ -> assert false
+let topic_title = title
+
+let topicsInOrder = [ `Sync; `Syncprocess; `Syncprocess_CLI; `CLI; `GUI; `Remote; `Archive ]
+
+let oneLineDocs ?(hpre="") ?(hpost="") u =
+ let buf = Buffer.create 1024 in
+ let out = Buffer.add_string buf in
+ let fmt = Format.formatter_of_buffer buf in
+ let () = Format.pp_set_margin fmt 81 in (* cols + 1 *)
+
+ let formatPref name {pspec; doc; deprec; _ } =
let arg = prefArg pspec in
- let arg = if arg = "" then "" else " " ^ arg in
- let spaces =
- String.make (max 1 (18 - String.length (name ^ arg))) ' ' in
- " -" ^ name ^ arg ^ spaces ^ doc ^ "\n" in
- let formatAll p =
- (* format a message documenting non hidden preferences matching [p] *)
- String.concat "" @@
- Safelist.rev @@
- (fun f i l -> Util.StringMap.fold f l i)
- (fun name (doc, pspec, _) l ->
- (formatOne name pspec doc
- (String.length doc > 0 && doc.[0] <> '*' && p doc)) :: l)
- [] @@
- !prefs
+ let s = if arg = "" then name else name ^ " " ^ arg in
+ let l = max 1 (19 - String.length s) in
+ Format.pp_print_string fmt (" -" ^ s);
+ Format.pp_open_box fmt l;
+ Format.pp_print_break fmt l (1 - l);
+ if deprec then begin
+ Format.pp_print_string fmt "(deprecated)";
+ Format.pp_print_space fmt ()
+ end;
+ Format.pp_print_text fmt doc;
+ Format.pp_close_box fmt ();
+ Format.pp_print_newline fmt ()
+ in
+ let formatTopic t =
+ let m = Util.StringMap.filter (fun _ pref -> pref.category = t) !prefs in
+ if Util.StringMap.cardinal m > 0 then begin
+ let h = title t in
+ if h <> "" then begin
+ out "\n"; out hpre; out " ";
+ out h;
+ out ":"; out hpost; out "\n"
+ end;
+ Util.StringMap.iter formatPref m
+ end
+ in
+ let formatTopics g =
+ Safelist.iter (fun t -> formatTopic (g t))
in
- u ^ "\n"
- ^ "Basic options: \n"
- ^ formatAll (fun doc -> doc.[0] <> '!')
- ^ "\nAdvanced options: \n"
- ^ formatAll (fun doc -> doc.[0] = '!')
- ^ Safelist.fold_right
- (fun (name, pspec, doc) msg -> msg ^ formatOne name pspec doc true)
- !opts "\nSpecial command line options: \n"
+
+ out u; if u <> "" then out "\n";
+
+ out (hpre ^ "Basic options:" ^ hpost ^ "\n");
+ formatTopics (fun t -> `Basic t) (`General :: topicsInOrder);
+
+ out ("\n" ^ hpre ^ "Advanced options:" ^ hpost ^ "\n");
+ formatTopics (fun t -> `Advanced t) (topicsInOrder @ [`General]);
+
+ out ("\n" ^ hpre ^ "Expert options:" ^ hpost ^ "\n");
+ formatTopic (`Expert);
+
+ Buffer.contents buf
let printUsage usage = Uarg.usage (argspecs (fun _ s -> s))
(oneLineDocs usage)
+let printUsageForMan () =
+ print_string ".Bd -literal\n";
+ print_string (oneLineDocs ~hpre:".Sy \"" ~hpost:"\"" "");
+ print_string ".Ed\n"
+
let processCmdLine usage hook =
Uarg.current := 0;
let argspecs = argspecs hook in
@@ -430,7 +614,7 @@ let processCmdLine usage hook =
in
let anonfun =
try
- let (_, p, _) = Util.StringMap.find "rest" !prefs in
+ let {pspec = p; _} = Util.StringMap.find "rest" !prefs in
match hook "rest" p with
Uarg.String stringFunction -> stringFunction
| _ -> defaultanonfun
@@ -469,28 +653,111 @@ let scanCmdLine usage =
let listVisiblePrefs () =
let l =
Util.StringMap.fold
- (fun name (_, pspec, fulldoc) l ->
- if String.length fulldoc > 0 then begin
- (name, pspec, fulldoc) :: l
+ (fun name ({category; _} as pref) l ->
+ if not (isInternal category) then begin
+ (name, pref) :: l
end else l) !prefs [] in
- Safelist.stable_sort (fun (name1,_,_) (name2,_,_) -> compare name1 name2) l
+ Safelist.stable_sort (fun (name1, _) (name2, _) -> compare name1 name2) l
-let printFullDocs () =
+let printFullTeXDocs () =
Printf.eprintf "\\begin{description}\n";
Safelist.iter
- (fun (name, pspec, fulldoc) ->
- Printf.eprintf "\\item [{%s \\tt %s}]\n%s\n\n"
- name (prefArg pspec) fulldoc)
+ (fun (name, {pspec; fulldoc; deprec; _}) ->
+ Printf.eprintf "\\item [{%s \\tt %s}]\n%s%s\n\n"
+ name (prefArg pspec) (if deprec then "{\\em (Deprecated)} " else "") fulldoc)
(listVisiblePrefs());
Printf.eprintf "\\end{description}\n"
+let printFullManDocs () =
+ (* The output mangling code is taken from uigtk2.ml with some modifications.
+ Performance is not critical here, it is only run during the build,
+ never by users. *)
+ let (>>>) x f = f x in
+ let emptylineRe = Str.regexp "\n\n+" in
+ let newlineRe = Str.regexp "\n *" in
+ let nodotRe = Str.regexp "^\\([^.\n]+\\)" in
+ let macroRe = Str.regexp "\\(\\.[ \n]*\\)\\([A-Z]\\)" in
+ let styleRe = Str.regexp "\\([^ ]?\\){\\\\\\([a-z]+\\) \\([^{}]*\\)}\\(\\([^ }][^ ]*\\)?\\)" in
+ let verbRe = Str.regexp "\\([^ ]?\\)\\\\verb|\\([^|]*\\)|\\(\\([^ }][^ ]*\\)?\\)" in
+ let argRe = Str.regexp "\\([^ ]?\\)\\\\ARG{\\([^{}]*\\)}\\([^ }]*\\)" in
+ let textttRe = Str.regexp "\\([^ ]?\\)\\\\texttt{\\([^{}]*\\)}\\(\\([^ }][^ ]*\\)?\\)" in
+ let showttRe = Str.regexp "\\([^ ]?\\)\\\\showtt{\\([^{}]*\\)}\\([^ }]*\\)" in
+ let emphRe = Str.regexp "\\([^ ]?\\)\\\\emph{\\([^{}]*\\)}\\([^ }]*\\)" in
+ let sectionRe = Str.regexp "\\\\sectionref{\\([^{}]*\\)}{\\([^{}]*\\)}" in
+ let emdash = Str.regexp_string "---" in
+ let parRe = Str.regexp "\\\\par *" in
+ let underRe = Str.regexp "\\\\_ *" in
+ let dollarRe = Str.regexp "\\\\\\$ *" in
+ let dquotRe = Str.regexp "\"" in
+ let nn1Re = Str.regexp "\\(\\( -NN-\\)+ -NN-\\|\\( -NN-\\)* -NS-\\)\\." in
+ let nn2Re = Str.regexp "\\( -NN-\\)+" in
+ let substMacro m s =
+ (match Str.matched_group 1 s with "" -> " -NN-." | s -> s ^ " -NS-.") ^
+ m ^
+ (Str.matched_group 2 s) ^
+ (match Str.matched_group 3 s with "" -> "" | s -> " Ns " ^ s) ^
+ " -NN-"
+ in
+ let tex2man doc =
+ doc >>>
+ Str.global_replace macroRe "\\1\\&\\2" >>>
+ Str.global_substitute styleRe
+ (fun s ->
+ try
+ let tag =
+ match Str.matched_group 2 s with
+ "em" -> ".Em"
+ | "tt" -> ".Sy"
+ | _ -> raise Exit
+ in
+ Printf.sprintf "%s%s %s%s -NN-"
+ (match Str.matched_group 1 s with "" -> " -NN-" | s -> s ^ " -NS-")
+ tag
+ (Str.matched_group 3 s)
+ (match Str.matched_group 4 s with "" -> "" | s -> " Ns " ^ s)
+ with Exit ->
+ Str.matched_group 0 s) >>>
+ Str.global_substitute verbRe (substMacro "Ic ") >>>
+ Str.global_substitute argRe (substMacro "Ar ") >>>
+ Str.global_substitute textttRe (substMacro "Sy ") >>>
+ Str.global_substitute showttRe (substMacro "Dq ") >>>
+ Str.global_substitute emphRe (substMacro "Em ") >>>
+ Str.global_replace sectionRe "Section\n.Dq \\2\n in the manual" >>>
+ Str.global_replace emdash "\xe2\x80\x94" >>>
+ Str.global_replace parRe "\n" >>>
+ Str.global_replace underRe "_" >>>
+ Str.global_replace dollarRe "$" >>>
+ Str.global_replace dquotRe "\\&\"" >>>
+ Str.global_replace nn1Re " Ns " >>>
+ Str.global_replace nn2Re "\n" >>>
+ Str.global_replace newlineRe "\n" >>>
+ Str.global_replace emptylineRe "\n" >>>
+ Str.global_replace nodotRe ".No \\1" >>>
+ Util.trimWhitespace
+ in
+ Printf.printf ".Bl -tag\n";
+ Safelist.iter
+ (fun (name, {pspec; fulldoc; deprec; _}) ->
+ Printf.printf ".It Ic %s%s\n%s%s\n"
+ name
+ (match prefArg pspec with "" -> "" | s -> " Ar " ^ s)
+ (if deprec then ".Em ( Deprecated )\n" else "")
+ (tex2man fulldoc)
+ )
+ (listVisiblePrefs());
+ Printf.printf ".El\n"
+
+let printFullDocs = function
+ | `TeX -> printFullTeXDocs ()
+ | `man -> printFullManDocs ()
(*****************************************************************************)
(* Adding stuff to the prefs file *)
(*****************************************************************************)
let addprefsto = createString "addprefsto" ""
- "!file to add new prefs to"
+ ~category:(`Advanced `General)
+ "file to add new prefs to"
"By default, new preferences added by Unison (e.g., new \\verb|ignore| \
clauses) will be appended to whatever preference file Unison was told \
to load at the beginning of the run. Setting the preference \
@@ -506,7 +773,7 @@ let addLine l =
debug (fun() ->
Util.msg "Adding '%s' to %s\n" l (System.fspathToDebugString filename));
let resultmsg =
- l ^ "' added to profile " ^ System.fspathToPrintString filename in
+ l ^ "' added to profile " ^ filename in
let ochan =
System.open_out_gen [Open_wronly; Open_creat; Open_append] 0o600 filename
in
diff --git a/src/ubase/prefs.mli b/src/ubase/prefs.mli
index 0aab224..c6759eb 100644
--- a/src/ubase/prefs.mli
+++ b/src/ubase/prefs.mli
@@ -9,52 +9,88 @@ val name : 'a t -> string list
val overrideDefault : 'a t -> 'a -> unit
val readDefault : 'a t -> 'a
+type topic = [
+ | `General
+ | `Sync
+ | `Syncprocess
+ | `Syncprocess_CLI
+ | `CLI
+ | `GUI
+ | `Remote
+ | `Archive ]
+
+type group = [
+ | `Basic of topic
+ | `Advanced of topic
+ | `Expert
+ | `Internal of (* Preferences that are not listed *)
+ [ `Pseudo (* Pseudo-preferences for internal propagation *)
+ | `Devel (* Developer-only or build-related preferences *)
+ | `Other ] (* Other non-listed preferences *)
+ ]
+
+(* Note about command line-only preferences. These preferences are never *)
+(* sent to a server (ignoring [local] and [send] arguments). Should a client *)
+(* send such a preference anyway then the server silently ignores it. *)
+
(* Convenient functions for registering simple kinds of preferences. Note *)
(* that createStringPref creates a preference that can only be set once, *)
(* while createStringListPref creates a reference to a list of strings that *)
(* accumulates a list of values. *)
val createBool :
string (* preference name *)
+ -> category:group
+ -> ?cli_only:bool (* only a command line option, not in a profile *)
-> ?local:bool (* whether it is local to the client *)
+ -> ?send:(unit->bool) (* whether preference should be sent to server *)
-> bool (* initial value *)
+ -> ?deprecated:bool (* preference is deprecated (default false) *)
-> string (* documentation string *)
-> string (* full (tex) documentation string *)
-> bool t (* -> new preference value *)
val createInt :
string (* preference name *)
+ -> category:group
+ -> ?cli_only:bool (* only a command line option, not in a profile *)
-> ?local:bool (* whether it is local to the client *)
+ -> ?send:(unit->bool) (* whether preference should be sent to server *)
-> int (* initial value *)
+ -> ?deprecated:bool (* preference is deprecated (default false) *)
-> string (* documentation string *)
-> string (* full (tex) documentation string *)
-> int t (* -> new preference value *)
val createString :
string (* preference name *)
+ -> category:group
+ -> ?cli_only:bool (* only a command line option, not in a profile *)
-> ?local:bool (* whether it is local to the client *)
+ -> ?send:(unit->bool) (* whether preference should be sent to server *)
-> string (* initial value *)
+ -> ?deprecated:bool (* preference is deprecated (default false) *)
-> string (* documentation string *)
-> string (* full (tex) documentation string *)
-> string t (* -> new preference value *)
-val createFspath :
- string (* preference name *)
- -> ?local:bool (* whether it is local to the client *)
- -> System.fspath (* initial value *)
- -> string (* documentation string *)
- -> string (* full (tex) documentation string *)
- -> System.fspath t (* -> new preference value *)
-
val createStringList :
string (* preference name *)
+ -> category:group
+ -> ?cli_only:bool (* only a command line option, not in a profile *)
-> ?local:bool (* whether it is local to the client *)
+ -> ?send:(unit->bool) (* whether preference should be sent to server *)
+ -> ?deprecated:bool (* preference is deprecated (default false) *)
-> string (* documentation string *)
-> string (* full (tex) documentation string *)
-> string list t (* -> new preference value *)
val createBoolWithDefault :
string (* preference name *)
+ -> category:group
+ -> ?cli_only:bool (* only a command line option, not in a profile *)
-> ?local:bool (* whether it is local to the client *)
+ -> ?send:(unit->bool) (* whether preference should be sent to server *)
+ -> ?deprecated:bool (* preference is deprecated (default false) *)
-> string (* documentation string *)
-> string (* full (tex) documentation string *)
-> [`True|`False|`Default] t
@@ -66,13 +102,18 @@ exception IllegalValue of string
(* IllegalValue if it is passed a string it cannot deal with. *)
val create :
string (* preference name *)
+ -> category:group
+ -> ?cli_only:bool (* only a command line option, not in a profile *)
-> ?local:bool (* whether it is local to the client *)
+ -> ?send:(unit->bool) (* whether the pref should be sent to server *)
-> 'a (* initial value *)
+ -> ?deprecated:bool (* preference is deprecated (default false) *)
-> string (* documentation string *)
-> string (* full (tex) documentation string *)
-> ('a->string->'a) (* interning function for preference values
(1st arg is old value of preference) *)
-> ('a -> string list) (* printing function for preference values *)
+ -> 'a Umarshal.t
-> 'a t (* -> new preference value *)
(* Create an alternate name for a preference (the new name will not appear *)
@@ -81,6 +122,12 @@ val alias : 'a t (* existing preference *)
-> string (* new name *)
-> unit
+(* Mark a preference name as intentionally removed. A removed preference *)
+(* does not exist (can't be specified on command line or in a profile) but *)
+(* will be silently ignored when sent by a remote host (to not break *)
+(* compatibility with old clients). *)
+val markRemoved : string -> unit
+
(* Reset all preferences to their initial values *)
val resetToDefaults : unit -> unit
@@ -99,6 +146,7 @@ val parseCmdLine :
val scanCmdLine : string -> (string list) Util.StringMap.t
val printUsage : string -> unit
+val printUsageForMan : unit -> unit
(* ---------------------------------------------------------------------- *)
@@ -106,7 +154,7 @@ val printUsage : string -> unit
val profileName : string option ref
(* Calculate the full pathname of a preference file *)
-val profilePathname : ?add_ext:bool -> string -> System.fspath
+val profilePathname : ?add_ext:bool -> string -> string
(* Check whether the profile file is unchanged *)
val profileUnchanged : unit -> bool
@@ -120,9 +168,9 @@ val add : string -> string -> string
val addComment : string -> unit
(* Scan a given preferences file and return a list of tuples of the form *)
-(* (fileName, lineno, name, value), without changing any of the preferences *)
+(* ((locName, lineno), name, value), without changing any of the preferences *)
val readAFile : ?fail:bool -> ?add_ext:bool -> string
- -> (string * int * string * string) list
+ -> ((string * int) * string * string) list
(* Parse the preferences file, raising Fatal if there are any problems *)
val loadTheFile : unit -> unit
@@ -134,13 +182,15 @@ val loadStrings : string list -> unit
type dumpedPrefs
+val mdumpedPrefs : dumpedPrefs Umarshal.t
+
(* Dump current values of all preferences into a value that can be
marshalled and sent over the network or stored in a file for fast
retrieval *)
-val dump : unit -> dumpedPrefs
+val dump : int -> dumpedPrefs
(* Load new values of all preferences from a string created by dump *)
-val load : dumpedPrefs -> unit
+val load : dumpedPrefs -> int -> unit
(* ------------------------------------------------------------------------- *)
@@ -149,10 +199,12 @@ type typ =
val canonicalName : string -> string
val typ : string -> typ
-val documentation : string -> string * string * bool
-val list : unit -> string list
+val documentation : string -> string * string
+val category : string -> group option
+val list : bool -> string list
+val topic_title : group -> string
(* ------------------------------------------------------------------------- *)
-val printFullDocs : unit -> unit
+val printFullDocs : [`TeX | `man] -> unit
val dumpPrefsToStderr : unit -> unit
diff --git a/src/ubase/proplist.ml b/src/ubase/proplist.ml
index 8c0d6c4..ed3777b 100644
--- a/src/ubase/proplist.ml
+++ b/src/ubase/proplist.ml
@@ -18,13 +18,13 @@
type 'a key = string
type t = Obj.t Util.StringMap.t
-let names = ref Util.StringSet.empty
+let names = ref Util.StringMap.empty
-let register nm =
- if (Util.StringSet.mem nm !names) then
+let register nm m =
+ if (Util.StringMap.mem nm !names) then
raise (Util.Fatal
(Format.sprintf "Property lists: %s already registered!" nm));
- names := Util.StringSet.add nm !names;
+ names := Util.StringMap.add nm (Obj.repr m) !names;
nm
let empty = Util.StringMap.empty
@@ -34,3 +34,20 @@ let mem = Util.StringMap.mem
let find (k : 'a key) m : 'a = Obj.obj (Util.StringMap.find k m)
let add (k : 'a key) (v : 'a) m = Util.StringMap.add k (Obj.repr v) m
+
+let find_m (k : 'a key) : 'a Umarshal.t =
+ try Obj.obj (Util.StringMap.find k !names) with
+ | Not_found -> raise (Util.Fatal (Format.sprintf "Property lists: %s not yet registered!" k))
+
+module S = struct
+ type key = string
+ type value = Obj.t
+ type map = t
+ let cardinal = Util.StringMap.cardinal
+ let empty = Util.StringMap.empty
+ let add = Util.StringMap.add
+ let iter = Util.StringMap.iter
+ let find_m = find_m
+end
+
+include Umarshal.Proplist (S)
diff --git a/src/ubase/proplist.mli b/src/ubase/proplist.mli
index 6ee1bb4..9186dde 100644
--- a/src/ubase/proplist.mli
+++ b/src/ubase/proplist.mli
@@ -4,7 +4,9 @@
type 'a key
type t
-val register : string -> 'a key
+val m : t Umarshal.t
+
+val register : string -> 'a Umarshal.t -> 'a key
val empty : t
val mem : 'a key -> t -> bool
diff --git a/src/ubase/trace.ml b/src/ubase/trace.ml
index 9b00d49..32511f0 100644
--- a/src/ubase/trace.ml
+++ b/src/ubase/trace.ml
@@ -30,7 +30,8 @@ let redirect x = (traceprinter := x)
let debugmods =
Prefs.createStringList "debug"
- "!debug module xxx ('all' -> everything, 'verbose' -> more)"
+ ~category:`Expert
+ "debug module xxx ('all' -> everything, 'verbose' -> more)"
("This preference is used to make Unison print various sorts of "
^ "information about what it is doing internally on the standard "
^ "error stream. It can be used many times, each time with the name "
@@ -46,8 +47,9 @@ let debugmods =
^ "what bytes are being sent across the network).")
let debugtimes =
- Prefs.createBool "debugtimes"
- false "*annotate debugging messages with timestamps" ""
+ Prefs.createBool "debugtimes" false
+ ~category:(`Internal `Devel)
+ "*annotate debugging messages with timestamps" ""
let runningasserver = ref false
@@ -107,14 +109,16 @@ let _ = Util.debugPrinter := Some(debug)
let logging =
Prefs.createBool "log" true
- "!record actions in logfile"
+ ~category:(`Advanced `General)
+ "record actions in logfile"
"When this flag is set, Unison will log all changes to the filesystems
on a file."
let logfile =
- Prefs.createFspath "logfile"
- (System.fspathFromString "unison.log")
- "!logfile name"
+ Prefs.createString "logfile"
+ "unison.log"
+ ~category:(`Advanced `General)
+ "logfile name"
"By default, logging messages will be appended to the file
\\verb|unison.log| in your .unison directory. Set this preference if
you prefer another file. It can be a path relative to your .unison directory.
@@ -142,7 +146,7 @@ let rec getLogch() =
Util.convertUnixErrorsToFatal "getLogch" (fun() ->
match !logch with
None ->
- let prefstr = System.fspathToString (Prefs.read logfile) in
+ let prefstr = Prefs.read logfile in
let file = Util.fileMaybeRelToUnisonDir prefstr in
let ch =
System.open_out_gen [Open_wronly; Open_creat; Open_append] 0o600 file in
@@ -185,13 +189,31 @@ let writeLog s stripColor =
(* Formatting and displaying messages *)
let terse =
- Prefs.createBool "terse" false "suppress status messages"
+ Prefs.createBool "terse" false
+ ~category:(`Basic `Syncprocess_CLI)
+ "suppress status messages"
("When this preference is set to {\\tt true}, the user "
^ "interface will not print status messages.")
type msgtype = Msg | StatusMajor | StatusMinor | Log | LogColor
type msg = msgtype * string
+let mmsgtype = Umarshal.(sum5 unit unit unit unit unit
+ (function
+ | Msg -> I51 ()
+ | StatusMajor -> I52 ()
+ | StatusMinor -> I53 ()
+ | Log -> I54 ()
+ | LogColor -> I55 ())
+ (function
+ | I51 () -> Msg
+ | I52 () -> StatusMajor
+ | I53 () -> StatusMinor
+ | I54 () -> Log
+ | I55 () -> LogColor))
+
+let mmsg = Umarshal.(prod2 mmsgtype string id id)
+
let defaultMessageDisplayer s =
if not (Prefs.read terse) then begin
let show() = if s<>"" then Util.msg "%s\n" s in
@@ -261,6 +283,7 @@ let logverbose s =
let printTimers =
Prefs.createBool "timers" false
+ ~category:(`Internal `Devel)
"*print timing information" ""
type timer = string * float
diff --git a/src/ubase/trace.mli b/src/ubase/trace.mli
index bb30a01..ce20cd7 100644
--- a/src/ubase/trace.mli
+++ b/src/ubase/trace.mli
@@ -48,6 +48,8 @@ val statusFormatter : (string -> string -> string) ref
types of the following) *)
type msg
+val mmsg : msg Umarshal.t
+
(* The internal routine used for formatting a message to be displayed
locally. It calls !messageDisplayer to do the actual work. *)
val displayMessageLocally : msg -> unit
diff --git a/src/ubase/uarg.ml b/src/ubase/uarg.ml
index 4a10795..03ee688 100644
--- a/src/ubase/uarg.ml
+++ b/src/ubase/uarg.ml
@@ -43,6 +43,13 @@ let usage speclist errmsg =
let current = ref 0;;
+let eprintf fmt =
+ Printf.ksprintf (fun s ->
+ if System.has_stderr ~info:s then Printf.eprintf "%s" s else exit 2) fmt
+
+let verify_stdout () =
+ if not (System.has_stdout ~info:"") then exit 37
+
let parse speclist anonfun errmsg =
let argv = System.argv () in
let initpos = !current in
@@ -50,7 +57,7 @@ let parse speclist anonfun errmsg =
let progname =
if initpos < Array.length argv then argv.(initpos) else "(?)" in
begin match error with
- | Unknown s when s = "-help" -> ()
+ | Unknown s when s = "-help" -> verify_stdout ()
| Unknown s ->
eprintf "%s: unknown option `%s'.\n" progname s
| Missing s ->
diff --git a/src/ubase/umarshal.ml b/src/ubase/umarshal.ml
new file mode 100644
index 0000000..5c5f061
--- /dev/null
+++ b/src/ubase/umarshal.ml
@@ -0,0 +1,641 @@
+(* Unison file synchronizer: src/ubase/umarshal.ml *)
+(* Copyright 2020, Stéphane Glondu
+
+ This program is free software: you can redistribute it and/or modify
+ it under the terms of the GNU General Public License as published by
+ the Free Software Foundation, either version 3 of the License, or
+ (at your option) any later version.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with this program. If not, see <http://www.gnu.org/licenses/>.
+*)
+
+exception Error of string
+
+type 'a t = {
+ read : (bytes -> int -> int -> unit) -> 'a;
+ write : (bytes -> int -> int -> unit) -> 'a -> unit;
+}
+
+external id : 'a -> 'a = "%identity"
+
+let header_size = 8
+
+let max_int_int64 = Int64.of_int max_int
+let min_int_int64 = Int64.of_int min_int
+
+let data_size header offset =
+ if offset + header_size <= Bytes.length header then
+ let n = Bytes.get_int64_be header offset in
+ if n < 0L then
+ raise (Error "data_size: negative size")
+ else if n <= max_int_int64 then
+ Int64.to_int n
+ else
+ raise (Error "data_size: payload too large")
+ else
+ raise (Error "data_size: header too short")
+
+let to_string m x =
+ let buffer = Buffer.create 1024 in
+ m.write (Buffer.add_subbytes buffer) x;
+ let header = Bytes.create header_size in
+ Bytes.set_int64_be header 0 (Int64.of_int (Buffer.length buffer));
+ Bytes.to_string header ^ Buffer.contents buffer
+
+let from_bytes m buffer offset =
+ let length = Bytes.length buffer in
+ let offset = ref (offset + header_size) in
+ m.read (fun buffer' offset' n ->
+ let i = !offset in
+ if i + n <= length then (
+ offset := i + n;
+ Bytes.blit buffer i buffer' offset' n
+ ) else (
+ raise (Error "from_bytes: end of input")
+ )
+ )
+
+let from_string m buffer offset =
+ from_bytes m (Bytes.of_string buffer) offset
+
+let from_channel m ic =
+ let header = Bytes.create header_size in
+ really_input ic header 0 header_size;
+ m.read (really_input ic)
+
+let to_channel m oc x =
+ let header = Bytes.create header_size in
+ let header_pos = pos_out oc in
+ output oc header 0 header_size;
+ m.write (output oc) x;
+ let end_pos = pos_out oc in
+ let data_size = end_pos - header_pos - header_size in
+ Bytes.set_int64_be header 0 (Int64.of_int data_size);
+ seek_out oc header_pos;
+ output oc header 0 header_size;
+ seek_out oc end_pos
+
+let rec1 a =
+ let rec fa =
+ {
+ read = (fun recv -> (a fa).read recv);
+ write = (fun send x -> (a fa).write send x);
+ }
+ in
+ fa
+
+let rec2 a b =
+ let rec fa =
+ {
+ read = (fun recv -> (a fb).read recv);
+ write = (fun send x -> (a fb).write send x);
+ }
+ and fb =
+ {
+ read = (fun recv -> (b fa).read recv);
+ write = (fun send x -> (b fa).write send x);
+ }
+ in
+ (fb, fa)
+
+let unit =
+ {
+ read = (fun _ -> ());
+ write = (fun _ () -> ());
+ }
+
+let char =
+ {
+ read =
+ (fun recv ->
+ let buffer = Bytes.create 1 in
+ recv buffer 0 1;
+ Bytes.unsafe_get buffer 0
+ );
+ write =
+ (fun send x ->
+ let res = Bytes.create 1 in
+ Bytes.unsafe_set res 0 x;
+ send res 0 1
+ );
+ }
+
+let bool =
+ {
+ read =
+ (fun recv ->
+ match char.read recv with
+ | '\000' -> false
+ | '\001' -> true
+ | _ -> raise (Error "bool: invalid value")
+ );
+ write =
+ (fun send x ->
+ char.write send (if x then '\001' else '\000')
+ );
+ }
+
+let int32 =
+ {
+ read =
+ (fun recv ->
+ let buffer = Bytes.create 4 in
+ recv buffer 0 4;
+ Bytes.get_int32_be buffer 0
+ );
+ write =
+ (fun send x ->
+ let res = Bytes.create 4 in
+ Bytes.set_int32_be res 0 x;
+ send res 0 4
+ );
+ }
+
+let int64 =
+ {
+ read =
+ (fun recv ->
+ let realize n get of_int =
+ let buffer = Bytes.create n in
+ recv buffer 0 n;
+ of_int (get buffer 0)
+ in
+ match int_of_char (char.read recv) with
+ | 0 -> 0L
+ | 1 -> realize 1 Bytes.get_int8 Int64.of_int
+ | 2 -> realize 2 Bytes.get_int16_be Int64.of_int
+ | 4 -> realize 4 Bytes.get_int32_be Int64.of_int32
+ | 8 -> realize 8 Bytes.get_int64_be id
+ | n -> raise (Error (Printf.sprintf "int64.read: unexpected size (%d)" n))
+ );
+ write =
+ (fun send x ->
+ let realize n set to_int =
+ let buffer = Bytes.create (1 + n) in
+ Bytes.unsafe_set buffer 0 (char_of_int n);
+ set buffer 1 (to_int x);
+ send buffer 0 (1 + n)
+ in
+ if x = 0L then
+ char.write send '\000'
+ else if -0x80L <= x && x < 0x80L then
+ realize 1 Bytes.set_int8 Int64.to_int
+ else if -0x8000L <= x && x < 0x8000L then
+ realize 2 Bytes.set_int16_be Int64.to_int
+ else if -0x8000_0000L <= x && x < 0x8000_0000L then
+ realize 4 Bytes.set_int32_be Int64.to_int32
+ else
+ realize 8 Bytes.set_int64_be id
+ );
+ }
+
+let int =
+ {
+ read =
+ (fun recv ->
+ let r = int64.read recv in
+ if r < min_int_int64 || r > max_int_int64 then
+ raise (Error "int.read: too large")
+ else
+ Int64.to_int r
+ );
+ write =
+ (fun send x ->
+ int64.write send (Int64.of_int x)
+ );
+ }
+
+let string =
+ {
+ read =
+ (fun recv ->
+ let length = int.read recv in
+ let buffer = Bytes.create length in
+ recv buffer 0 length;
+ Bytes.to_string buffer
+ );
+ write =
+ (fun send x ->
+ let length = String.length x in
+ int.write send length;
+ send (Bytes.of_string x) 0 length
+ );
+ }
+
+type bytearray =
+ (char, Bigarray.int8_unsigned_elt, Bigarray.c_layout) Bigarray.Array1.t
+
+external unsafe_blit_from_bytes : bytes -> int -> bytearray -> int -> int -> unit
+ = "ml_blit_bytes_to_bigarray" [@@noalloc]
+
+external unsafe_blit_to_bytes : bytearray -> int -> bytes -> int -> int -> unit
+ = "ml_blit_bigarray_to_bytes" [@@noalloc]
+
+let bytearray =
+ {
+ read =
+ (fun recv ->
+ let length = int.read recv in
+ let res = Bigarray.(Array1.create char c_layout length) in
+ let rec loop offset length =
+ if length > 0 then (
+ let sub_length = min length Sys.max_string_length in
+ let buffer = Bytes.create sub_length in
+ recv buffer 0 sub_length;
+ unsafe_blit_from_bytes buffer 0 res offset sub_length;
+ loop (offset + sub_length) (length - sub_length)
+ )
+ in
+ loop 0 length;
+ res
+ );
+ write =
+ (fun send x ->
+ let length = Bigarray.Array1.dim x in
+ int.write send length;
+ let buffer = Bytes.create (min length Sys.max_string_length) in
+ let rec loop offset length =
+ if length > 0 then (
+ let sub_length = min length Sys.max_string_length in
+ unsafe_blit_to_bytes x offset buffer 0 sub_length;
+ send buffer 0 sub_length;
+ loop (offset + sub_length) (length - sub_length)
+ )
+ in
+ loop 0 length
+ );
+ }
+
+let marshal_to_bytearray m x =
+ let data_size = ref 0 in
+ m.write (fun _ _ length -> data_size := !data_size + length) x;
+ let header = Bytes.create header_size in
+ Bytes.set_int64_be header 0 (Int64.of_int !data_size);
+ let total_size = header_size + !data_size in
+ let result = Bigarray.(Array1.create char c_layout total_size) in
+ unsafe_blit_from_bytes header 0 result 0 header_size;
+ let offset = ref header_size in
+ m.write (fun buffer offset' length ->
+ let i = !offset in
+ if i + length <= total_size then (
+ unsafe_blit_from_bytes buffer offset' result i length;
+ offset := i + length
+ ) else (
+ raise (Error "marshal_to_bytearray: length inconsistency")
+ )
+ ) x;
+ if !offset <> total_size then
+ raise (Error "marshal_to_bytearray: universe inconsistency");
+ result
+
+let unmarshal_from_bytearray m x offset =
+ let length = Bigarray.Array1.dim x in
+ let offset = ref (offset + header_size) in
+ m.read (fun buffer' offset' n ->
+ let i = !offset in
+ if i + n <= length then (
+ offset := i + n;
+ unsafe_blit_to_bytes x i buffer' offset' n
+ ) else (
+ raise (Error "unmarshal_from_bytearray: end of input")
+ )
+ )
+
+type int32bigarray =
+ (int32, Bigarray.int32_elt, Bigarray.c_layout) Bigarray.Array1.t
+
+let int32bigarray =
+ {
+ read =
+ (fun recv ->
+ let length = int.read recv in
+ let res = Bigarray.(Array1.create int32 c_layout length) in
+ for i = 0 to length - 1 do
+ res.{i} <- int32.read recv
+ done;
+ res
+ );
+ write =
+ (fun send x ->
+ let length = Bigarray.Array1.dim x in
+ int.write send length;
+ for i = 0 to length - 1 do
+ int32.write send x.{i}
+ done
+ );
+ }
+
+let float =
+ {
+ read =
+ (fun recv ->
+ Int64.float_of_bits (int64.read recv)
+ );
+ write =
+ (fun send x ->
+ int64.write send (Int64.bits_of_float x)
+ );
+ }
+
+let list m =
+ {
+ read =
+ (fun recv ->
+ let length = int.read recv in
+ let result = ref [] in
+ for _ = 1 to length do
+ result := m.read recv :: !result
+ done;
+ List.rev !result
+ );
+ write =
+ (fun send x ->
+ int.write send (List.length x);
+ List.iter (fun x -> m.write send x) x
+ );
+ }
+
+let prod2 ma mb f g =
+ {
+ read =
+ (fun recv ->
+ let a = ma.read recv in
+ let b = mb.read recv in
+ g (a, b)
+ );
+ write =
+ (fun send x ->
+ let a, b = f x in
+ ma.write send a;
+ mb.write send b
+ );
+ }
+
+let prod3 ma mb mc f g =
+ {
+ read =
+ (fun recv ->
+ let a = ma.read recv in
+ let b = mb.read recv in
+ let c = mc.read recv in
+ g (a, b, c)
+ );
+ write =
+ (fun send x ->
+ let a, b, c = f x in
+ ma.write send a;
+ mb.write send b;
+ mc.write send c
+ );
+ }
+
+let prod4 ma mb mc md f g =
+ {
+ read =
+ (fun recv ->
+ let a = ma.read recv in
+ let b = mb.read recv in
+ let c = mc.read recv in
+ let d = md.read recv in
+ g (a, b, c, d)
+ );
+ write =
+ (fun send x ->
+ let a, b, c, d = f x in
+ ma.write send a;
+ mb.write send b;
+ mc.write send c;
+ md.write send d
+ );
+ }
+
+let prod5 ma mb mc md me f g =
+ {
+ read =
+ (fun recv ->
+ let a = ma.read recv in
+ let b = mb.read recv in
+ let c = mc.read recv in
+ let d = md.read recv in
+ let e = me.read recv in
+ g (a, b, c, d, e)
+ );
+ write =
+ (fun send x ->
+ let a, b, c, d, e = f x in
+ ma.write send a;
+ mb.write send b;
+ mc.write send c;
+ md.write send d;
+ me.write send e
+ );
+ }
+
+let prod6 ma mb mc md me mf f g =
+ {
+ read =
+ (fun recv ->
+ let a = ma.read recv in
+ let b = mb.read recv in
+ let c = mc.read recv in
+ let d = md.read recv in
+ let e = me.read recv in
+ let f = mf.read recv in
+ g (a, b, c, d, e, f)
+ );
+ write =
+ (fun send x ->
+ let a, b, c, d, e, f = f x in
+ ma.write send a;
+ mb.write send b;
+ mc.write send c;
+ md.write send d;
+ me.write send e;
+ mf.write send f
+ );
+ }
+
+let sum1 ma f g =
+ {
+ read = (fun recv -> g (ma.read recv));
+ write = (fun send x -> ma.write send (f x));
+ }
+
+type ('a, 'b) sum2 = I21 of 'a | I22 of 'b
+
+let sum2 ma mb f g =
+ {
+ read =
+ (fun recv ->
+ g (match char.read recv with
+ | '\000' -> I21 (ma.read recv)
+ | '\001' -> I22 (mb.read recv)
+ | _ -> raise (Error "sum2: invalid tag"))
+ );
+ write =
+ (fun send x ->
+ match f x with
+ | I21 a -> char.write send '\000'; ma.write send a
+ | I22 a -> char.write send '\001'; mb.write send a
+ );
+ }
+
+let option m =
+ sum2 unit m
+ (function
+ | None -> I21 ()
+ | Some a -> I22 a)
+ (function
+ | I21 () -> None
+ | I22 a -> Some a)
+
+type ('a, 'b, 'c) sum3 = I31 of 'a | I32 of 'b | I33 of 'c
+
+let sum3 ma mb mc f g =
+ {
+ read =
+ (fun recv ->
+ g (match char.read recv with
+ | '\000' -> I31 (ma.read recv)
+ | '\001' -> I32 (mb.read recv)
+ | '\002' -> I33 (mc.read recv)
+ | _ -> raise (Error "sum3: invalid tag"))
+ );
+ write =
+ (fun send x ->
+ match f x with
+ | I31 a -> char.write send '\000'; ma.write send a
+ | I32 a -> char.write send '\001'; mb.write send a
+ | I33 a -> char.write send '\002'; mc.write send a
+ );
+ }
+
+type ('a, 'b, 'c, 'd) sum4 = I41 of 'a | I42 of 'b | I43 of 'c | I44 of 'd
+
+let sum4 ma mb mc md f g =
+ {
+ read =
+ (fun recv ->
+ g (match char.read recv with
+ | '\000' -> I41 (ma.read recv)
+ | '\001' -> I42 (mb.read recv)
+ | '\002' -> I43 (mc.read recv)
+ | '\003' -> I44 (md.read recv)
+ | _ -> raise (Error "sum4: invalid tag"))
+ );
+ write =
+ (fun send x ->
+ match f x with
+ | I41 a -> char.write send '\000'; ma.write send a
+ | I42 a -> char.write send '\001'; mb.write send a
+ | I43 a -> char.write send '\002'; mc.write send a
+ | I44 a -> char.write send '\003'; md.write send a
+ );
+ }
+
+type ('a, 'b, 'c, 'd, 'e) sum5 = I51 of 'a | I52 of 'b | I53 of 'c | I54 of 'd | I55 of 'e
+
+let sum5 ma mb mc md me f g =
+ {
+ read =
+ (fun recv ->
+ g (match char.read recv with
+ | '\000' -> I51 (ma.read recv)
+ | '\001' -> I52 (mb.read recv)
+ | '\002' -> I53 (mc.read recv)
+ | '\003' -> I54 (md.read recv)
+ | '\004' -> I55 (me.read recv)
+ | _ -> raise (Error "sum5: invalid tag"))
+ );
+ write =
+ (fun send x ->
+ match f x with
+ | I51 a -> char.write send '\000'; ma.write send a
+ | I52 a -> char.write send '\001'; mb.write send a
+ | I53 a -> char.write send '\002'; mc.write send a
+ | I54 a -> char.write send '\003'; md.write send a
+ | I55 a -> char.write send '\004'; me.write send a
+ );
+ }
+
+type ('a, 'b, 'c, 'd, 'e, 'f) sum6 = I61 of 'a | I62 of 'b | I63 of 'c | I64 of 'd | I65 of 'e | I66 of 'f
+
+let sum6 ma mb mc md me mf f g =
+ {
+ read =
+ (fun recv ->
+ g (match char.read recv with
+ | '\000' -> I61 (ma.read recv)
+ | '\001' -> I62 (mb.read recv)
+ | '\002' -> I63 (mc.read recv)
+ | '\003' -> I64 (md.read recv)
+ | '\004' -> I65 (me.read recv)
+ | '\005' -> I66 (mf.read recv)
+ | _ -> raise (Error "sum6: invalid tag"))
+ );
+ write =
+ (fun send x ->
+ match f x with
+ | I61 a -> char.write send '\000'; ma.write send a
+ | I62 a -> char.write send '\001'; mb.write send a
+ | I63 a -> char.write send '\002'; mc.write send a
+ | I64 a -> char.write send '\003'; md.write send a
+ | I65 a -> char.write send '\004'; me.write send a
+ | I66 a -> char.write send '\005'; mf.write send a
+ );
+ }
+
+let cond c d m =
+ {
+ read =
+ (fun recv ->
+ if c () then m.read recv else d
+ );
+ write =
+ (fun send x ->
+ if c () then m.write send x else ()
+ );
+ }
+
+module type PROPLIST_S = sig
+ type key = string
+ type value = Obj.t
+ type map
+ val cardinal : map -> int
+ val empty : map
+ val add : key -> value -> map -> map
+ val iter : (key -> value -> unit) -> map -> unit
+ val find_m : key -> value t
+end
+
+module Proplist (S : PROPLIST_S) = struct
+ let m =
+ {
+ read =
+ (fun recv ->
+ let length = int.read recv in
+ let res = ref S.empty in
+ for _ = 1 to length do
+ let key = string.read recv in
+ let value = (S.find_m key).read recv in
+ res := S.add key value !res
+ done;
+ !res
+ );
+ write =
+ (fun send x ->
+ let length = S.cardinal x in
+ int.write send length;
+ S.iter (fun key value ->
+ string.write send key;
+ (S.find_m key).write send value
+ ) x
+ );
+ }
+end
diff --git a/src/ubase/umarshal.mli b/src/ubase/umarshal.mli
new file mode 100644
index 0000000..4cb5c80
--- /dev/null
+++ b/src/ubase/umarshal.mli
@@ -0,0 +1,118 @@
+(* Unison file synchronizer: src/ubase/umarshal.mli *)
+(* Copyright 2020, Stéphane Glondu (see COPYING for details) *)
+
+(* The purpose and characteristics of the Umarshal module are not unlike
+ those of Stdlib's Marshal module, with two main differences
+
+ - it is not intended to encode and decode arbitrary data structures.
+ - it is intended to be compatible and stable across all machines and
+ OCaml versions.
+
+ This module provides basic infrastructure for marshaling along with some
+ combinators to build marshaling functions for various data structures.
+
+ The encoding format used by Umarshal is not following any standard, it
+ is a minimal binary format with no overhead designed to encode a limited
+ set of data types in a platform-neutral way. The format does not carry
+ any schema or other type information. *)
+
+exception Error of string
+
+(* Type ['a t] defines un-/marshaling functions for a data structure with
+ type ['a].
+
+ The combinators in this module are used to build [Umarshal.t] values.
+ Combinators are provided for basic types, such as ints, floats and
+ strings, for basic structures such as products (tuples) and sums
+ (variants), and for recursive structures. Other types (such as records)
+ will need to be converted to tuples. All sum and product combinators
+ receive conversion functions for this purpose.
+
+ By convention, a [Umarshal.t] value for a type in another module will be
+ named by the name of the type prefixed with "m", or just "m" in case the
+ type is named "t".
+
+ For example (in other modules):
+ [mtyp : typ Umarshal.t]
+ [m : t Umarshal.t]
+*)
+type 'a t
+
+external id : 'a -> 'a = "%identity"
+
+val header_size : int
+val data_size : bytes -> int -> int
+
+val to_string : 'a t -> 'a -> string
+val from_bytes : 'a t -> bytes -> int -> 'a
+val from_string : 'a t -> string -> int -> 'a
+
+val from_channel : 'a t -> in_channel -> 'a
+val to_channel : 'a t -> out_channel -> 'a -> unit
+
+val rec1 : ('a t -> 'a t) -> 'a t
+val rec2 : ('a t -> 'b t) -> ('b t -> 'a t) -> 'a t * 'b t
+
+val unit : unit t
+val bool : bool t
+val int : int t
+val int64 : int64 t
+val float : float t
+
+val string : string t
+
+type bytearray =
+ (char, Bigarray.int8_unsigned_elt, Bigarray.c_layout) Bigarray.Array1.t
+
+val bytearray : bytearray t
+
+val marshal_to_bytearray : 'a t -> 'a -> bytearray
+val unmarshal_from_bytearray : 'a t -> bytearray -> int -> 'a
+
+type int32bigarray =
+ (int32, Bigarray.int32_elt, Bigarray.c_layout) Bigarray.Array1.t
+
+val int32bigarray : int32bigarray t
+
+val option : 'a t -> 'a option t
+val list : 'a t -> 'a list t
+
+val prod2 : 'a t -> 'b t -> ('r -> 'a * 'b) -> ('a * 'b -> 'r) -> 'r t
+val prod3 : 'a t -> 'b t -> 'c t -> ('r -> 'a * 'b * 'c) -> ('a * 'b * 'c-> 'r) -> 'r t
+val prod4 : 'a t -> 'b t -> 'c t -> 'd t -> ('r -> 'a * 'b * 'c * 'd) -> ('a * 'b * 'c * 'd -> 'r) -> 'r t
+val prod5 : 'a t -> 'b t -> 'c t -> 'd t -> 'e t -> ('r -> 'a * 'b * 'c * 'd * 'e) -> ('a * 'b * 'c * 'd * 'e -> 'r) -> 'r t
+val prod6 : 'a t -> 'b t -> 'c t -> 'd t -> 'e t -> 'f t -> ('r -> 'a * 'b * 'c * 'd * 'e * 'f) -> ('a * 'b * 'c * 'd * 'e * 'f -> 'r) -> 'r t
+
+val sum1 : 'a t -> ('r -> 'a) -> ('a -> 'r) -> 'r t
+
+type ('a, 'b) sum2 = I21 of 'a | I22 of 'b
+val sum2 : 'a t -> 'b t -> ('r -> ('a, 'b) sum2) -> (('a, 'b) sum2 -> 'r) -> 'r t
+
+type ('a, 'b, 'c) sum3 = I31 of 'a | I32 of 'b | I33 of 'c
+val sum3 : 'a t -> 'b t -> 'c t -> ('r -> ('a, 'b, 'c) sum3) -> (('a, 'b, 'c) sum3 -> 'r) -> 'r t
+
+type ('a, 'b, 'c, 'd) sum4 = I41 of 'a | I42 of 'b | I43 of 'c | I44 of 'd
+val sum4 : 'a t -> 'b t -> 'c t -> 'd t -> ('r -> ('a, 'b, 'c, 'd) sum4) -> (('a, 'b, 'c, 'd) sum4 -> 'r) -> 'r t
+
+type ('a, 'b, 'c, 'd, 'e) sum5 = I51 of 'a | I52 of 'b | I53 of 'c | I54 of 'd | I55 of 'e
+val sum5 : 'a t -> 'b t -> 'c t -> 'd t -> 'e t -> ('r -> ('a, 'b, 'c, 'd, 'e) sum5) -> (('a, 'b, 'c, 'd, 'e) sum5 -> 'r) -> 'r t
+
+type ('a, 'b, 'c, 'd, 'e, 'f) sum6 = I61 of 'a | I62 of 'b | I63 of 'c | I64 of 'd | I65 of 'e | I66 of 'f
+val sum6 : 'a t -> 'b t -> 'c t -> 'd t -> 'e t -> 'f t -> ('r -> ('a, 'b, 'c, 'd, 'e, 'f) sum6) -> (('a, 'b, 'c, 'd, 'e, 'f) sum6 -> 'r) -> 'r t
+
+val cond : (unit -> bool) -> 'a -> 'a t -> 'a t
+
+module type PROPLIST_S = sig
+ type key = string
+ type value = Obj.t
+ type map
+ val cardinal : map -> int
+ val empty : map
+ val add : key -> value -> map -> map
+ val iter : (key -> value -> unit) -> map -> unit
+ val find_m : key -> value t
+end
+
+module Proplist (S : PROPLIST_S) : sig
+ val m : S.map t
+end
diff --git a/src/ubase/util.ml b/src/ubase/util.ml
index 0223734..c5bbfde 100644
--- a/src/ubase/util.ml
+++ b/src/ubase/util.ml
@@ -57,19 +57,23 @@ let stringSetFromList l =
(* Debugging / error messages *)
(*****************************************************************************)
-let infos = ref ""
+type infos = { s : string; clr : string }
+let infos = ref { s = ""; clr = "" }
let clear_infos () =
- if !infos <> "" then begin
+ if !infos.clr <> "" then begin
+ print_string !infos.clr;
+ flush stdout
+ end else if !infos.s <> "" then begin
print_string "\r";
- print_string (String.make (String.length !infos) ' ');
+ print_string (String.make (String.length !infos.s) ' ');
print_string "\r";
flush stdout
end
let show_infos () =
- if !infos <> "" then begin print_string !infos; flush stdout end
-let set_infos s =
- if s <> !infos then begin clear_infos (); infos := s; show_infos () end
+ if !infos.s <> "" then begin print_string !infos.s; flush stdout end
+let set_infos ?(clr = "") s =
+ if s <> !infos.s then begin clear_infos (); infos := {s; clr}; show_infos () end
let msg f =
clear_infos ();
@@ -136,7 +140,7 @@ let encodeException m kind e =
Unix.Unix_error(err,fnname,param) ->
let s = "Error in " ^ m ^ ":\n"
^ (Unix.error_message err)
- ^ " [" ^ fnname ^ "(" ^ param ^ ")]%s" ^
+ ^ " [" ^ fnname ^ "(" ^ param ^ ")]" ^
(match err with
Unix.EUNKNOWNERR n -> Format.sprintf " (code %d)" n
| _ -> "")
@@ -272,6 +276,19 @@ let process_status_to_string = function
| Unix.WSIGNALED i -> Printf.sprintf "Killed by signal %d" i
| Unix.WSTOPPED i -> Printf.sprintf "Stopped by signal %d" i
+
+let blockSignals sigs f =
+ let (prevMask, ok) =
+ try (Unix.sigprocmask SIG_BLOCK sigs, true)
+ with Invalid_argument _ -> ([], false) in
+ let restoreMask () =
+ if ok then Unix.sigprocmask SIG_SETMASK prevMask |> ignore in
+ try let r = f () in restoreMask (); r
+ with e ->
+ let origbt = Printexc.get_raw_backtrace () in
+ restoreMask ();
+ Printexc.raise_with_backtrace e origbt
+
(*****************************************************************************)
(* OS TYPE *)
(*****************************************************************************)
@@ -328,6 +345,23 @@ let percentageOfTotal current total =
let percent2string p = Printf.sprintf "%3d%%" (truncate (max 0. (min 100. p)))
+let gib = 1073741824.
+let mib = 1048576.
+let kib = 1024.
+let bytes2string v =
+ if v > 1_048_051_711L then
+ Printf.sprintf "%.2f GiB" (Int64.to_float v /. gib)
+ else if v > 104_805_171L then
+ Printf.sprintf "%.0f MiB" (Int64.to_float v /. mib)
+ else if v > 1_023_487L then
+ Printf.sprintf "%.1f MiB" (Int64.to_float v /. mib)
+ else if v > 102_348L then
+ Printf.sprintf "%.0f KiB" (Int64.to_float v /. kib)
+ else if v > 999L then
+ Printf.sprintf "%.1f KiB" (Int64.to_float v /. kib)
+ else
+ Printf.sprintf "%Ld B" v
+
let extractValueFromOption = function
None -> raise (Fatal "extractValueFromOption failed")
| Some(v) -> v
@@ -461,7 +495,7 @@ let padto n s = s ^ (String.make (max 0 (n - String.length s)) ' ')
(* Building pathnames in the user's home dir *)
(*****************************************************************************)
-let homeDirStr =
+let homeDir () =
(if (osType = `Unix) || isCygwin then
safeGetenv "HOME"
else if osType = `Win32 then
@@ -482,10 +516,7 @@ let homeDirStr =
else
assert false (* osType can't be anything else *))
-let homeDir () =
- System.fspathFromString homeDirStr
-
-let fileInHomeDir n = System.fspathConcat (homeDir ()) n
+let fileInHomeDir n = Filename.concat (homeDir ()) n
(*****************************************************************************)
(* .unison dir *)
@@ -497,7 +528,7 @@ let isMacOSX = isMacOSXPred ()
let unisonDir =
try
- System.fspathFromString (System.getenv "UNISON")
+ System.getenv "UNISON"
with Not_found ->
let genericName =
fileInHomeDir (Printf.sprintf ".%s" ProjectInfo.myName) in
@@ -506,11 +537,9 @@ let unisonDir =
else
genericName
-let unisonDirStr = System.fspathToString unisonDir
-
-let fileInUnisonDir str = System.fspathConcat unisonDir str
+let fileInUnisonDir str = Filename.concat unisonDir str
let fileMaybeRelToUnisonDir n =
if Filename.is_relative n
then fileInUnisonDir n
- else System.fspathFromString n
+ else n
diff --git a/src/ubase/util.mli b/src/ubase/util.mli
index ed636c2..dae2b70 100644
--- a/src/ubase/util.mli
+++ b/src/ubase/util.mli
@@ -33,6 +33,11 @@ val printException : exn -> string
val process_status_to_string : Unix.process_status -> string
+(* [blockSignals sigs f] blocks signals [sigs] (if supported by OS),
+ executes [f ()] and restores the original signal mask before returning
+ the result of executing [f ()] (value or exception). *)
+val blockSignals : int list -> (unit -> 'a) -> 'a
+
(* ---------------------------------------------------------------------- *)
(* Strings *)
@@ -83,6 +88,7 @@ val percentageOfTotal :
int (* percentage of total *)
val monthname : int -> string
val percent2string : float -> string
+val bytes2string : int64 -> string
(* Just like the versions in the Unix module, but raising Transient
instead of Unix_error *)
@@ -100,14 +106,13 @@ val debug : string -> (unit->unit) -> unit
val warnPrinter : (string -> unit) option ref
val warn : string -> unit
-(* Gives the fspath of the archive directory on the machine, depending on *)
+(* Gives the path of the archive directory on the machine, depending on *)
(* which OS we use *)
-val unisonDir : System.fspath
+val unisonDir : string
-(* build a fspath representing an archive child path whose name is given *)
-val fileInUnisonDir : string -> System.fspath
-val fileMaybeRelToUnisonDir : string -> System.fspath
-val unisonDirStr : string
+(* build a path representing an archive child path whose name is given *)
+val fileInUnisonDir : string -> string
+val fileMaybeRelToUnisonDir : string -> string
(* Printing and formatting functions *)
@@ -125,5 +130,6 @@ val format_to_string : (unit -> unit) -> string
flush the stream after each one *)
val msg : ('a, out_channel, unit) format -> 'a
-(* Set the info line *)
-val set_infos : string -> unit
+(* Set the info line.
+ [~clr] is an alternative clear sequence to clear this info only. *)
+val set_infos : ?clr:string -> string -> unit
diff --git a/src/uicommon.ml b/src/uicommon.ml
index 04bb134..94fbc66 100644
--- a/src/uicommon.ml
+++ b/src/uicommon.ml
@@ -26,6 +26,15 @@ type interface =
Text
| Graphic
+let minterface =
+ Umarshal.(sum2 unit unit
+ (function
+ | Text -> I21 ()
+ | Graphic -> I22 ())
+ (function
+ | I21 () -> Text
+ | I22 () -> Graphic))
+
module type UI =
sig
val start : interface -> unit
@@ -38,7 +47,9 @@ end
**********************************************************************)
let auto =
- Prefs.createBool "auto" false "automatically accept default (nonconflicting) actions"
+ Prefs.createBool "auto" false
+ ~category:(`Basic `Syncprocess_CLI)
+ "automatically accept default (nonconflicting) actions"
("When set to {\\tt true}, this flag causes the user "
^ "interface to skip asking for confirmations on "
^ "non-conflicting changes. (More precisely, when the user interface "
@@ -50,17 +61,20 @@ let auto =
gets sent to the server at startup *)
let mainWindowHeight =
Prefs.createInt "height" 15
- "!height (in lines) of main window in graphical interface"
+ ~category:(`Advanced `GUI)
+ "height (in lines) of main window in graphical interface"
("Used to set the height (in lines) of the main window in the graphical "
^ "user interface.")
let expert =
Prefs.createBool "expert" false
+ ~category:(`Internal `Devel)
"*Enable some developers-only functionality in the UI" ""
let profileLabel =
Prefs.createString "label" ""
- "!provide a descriptive string label for this profile"
+ ~category:(`Advanced `General)
+ "provide a descriptive string label for this profile"
("Used in a profile to provide a descriptive string documenting its "
^ "settings. (This is useful for users that switch between several "
^ "profiles, especially using the `fast switch' feature of the "
@@ -68,7 +82,8 @@ let profileLabel =
let profileKey =
Prefs.createString "key" ""
- "!define a keyboard shortcut for this profile (in some UIs)"
+ ~category:(`Advanced `General)
+ "define a keyboard shortcut for this profile (in some UIs)"
("Used in a profile to define a numeric key (0-9) that can be used in "
^ "the user interface to switch immediately to this profile.")
(* This preference is not actually referred to in the code anywhere, since
@@ -78,7 +93,8 @@ let profileKey =
let contactquietly =
Prefs.createBool "contactquietly" false
- "!suppress the 'contacting server' message during startup"
+ ~category:(`Advanced `General)
+ "suppress the 'contacting server' message during startup"
("If this flag is set, Unison will skip displaying the "
^ "`Contacting server' message (which some users find annoying) "
^ "during startup.")
@@ -87,19 +103,52 @@ let contactingServerMsg () =
Printf.sprintf "Unison %s: Contacting server..." Uutil.myVersion
let repeat =
- Prefs.createString "repeat" ""
- "!synchronize repeatedly (text interface only)"
+ let parseRepeat s =
+ let parseTime ts =
+ try int_of_string ts with Failure _ ->
+ raise (Prefs.IllegalValue ("Value of 'repeat' preference ("
+ ^ s ^ ") should be either a number, 'watch' or 'watch+<number>'"))
+ in
+ let nonBlankLower x =
+ match String.trim x with "" -> None | s -> Some (String.lowercase_ascii s)
+ in
+ try
+ match Safelist.filterMap nonBlankLower (String.split_on_char '+' s) with
+ | [] -> `NoRepeat
+ | ["watch"] -> `Watch
+ | ["watch"; i] | [i; "watch"] -> `WatchAndInterval (parseTime i)
+ | _ -> `Interval (parseTime s)
+ with
+ | Prefs.IllegalValue _ as e -> `Invalid (s, e)
+ in
+ let externRepeat = function
+ | `NoRepeat | `Invalid _ -> ""
+ | `Watch -> "watch"
+ | `WatchAndInterval i -> "watch+" ^ (string_of_int i)
+ | `Interval i -> string_of_int i
+ in
+ Prefs.create "repeat" `NoRepeat
+ ~category:(`Advanced `Syncprocess_CLI)
+ "synchronize repeatedly (text interface only)"
("Setting this preference causes the text-mode interface to synchronize "
^ "repeatedly, rather than doing it just once and stopping. If the "
^ "argument is a number, Unison will pause for that many seconds before "
^ "beginning again. When the argument is \\verb|watch|, Unison relies on "
^ "an external file monitoring process to synchronize whenever a change "
- ^ "happens.")
-let repeatWatcher () = Prefs.read repeat = "watch"
+ ^ "happens. You can combine the two with a \\verb|+| character to use "
+ ^ "file monitoring and also do a full scan every specificed number of "
+ ^ "seconds. For example, \\verb|watch+3600| will react to changes "
+ ^ "immediately and additionally do a full scan every hour.")
+ (fun _ -> parseRepeat)
+ (fun r -> [externRepeat r])
+ Umarshal.(sum1 string externRepeat parseRepeat)
+let repeatWatcher () =
+ match Prefs.read repeat with `Watch | `WatchAndInterval _ -> true | _ -> false
let retry =
Prefs.createInt "retry" 0
- "!re-try failed synchronizations N times (text ui only)"
+ ~category:(`Advanced `Syncprocess_CLI)
+ "re-try failed synchronizations N times (text ui only)"
("Setting this preference causes the text-mode interface to try again "
^ "to synchronize "
^ "updated paths where synchronization fails. Each such path will be "
@@ -108,7 +157,8 @@ let retry =
let confirmmerge =
Prefs.createBool "confirmmerge" false
- "!ask for confirmation before committing results of a merge"
+ ~category:(`Advanced `Syncprocess)
+ "ask for confirmation before committing results of a merge"
("Setting this preference causes both the text and graphical interfaces"
^ " to ask the user if the results of a merge command may be committed "
^ " to the replica or not. Since the merge command works on temporary files,"
@@ -119,7 +169,9 @@ let confirmmerge =
let runTestsPrefName = "selftest"
let runtests =
Prefs.createBool runTestsPrefName false
- "!run internal tests and exit"
+ ~category:`Expert
+ ~cli_only:true
+ "run internal tests and exit"
("Run internal tests and exit. This option is mostly for developers and must be used "
^ "carefully: in particular, "
^ "it will delete the contents of both roots, so that it can install its own files "
@@ -146,6 +198,7 @@ let choose s1 s2 = if !Update.foundArchives then s1 else s2
let showprev =
Prefs.createBool "showprev" false
+ ~category:(`Internal `Devel)
"*Show previous properties, if they differ from current"
""
@@ -413,6 +466,282 @@ let addIgnorePattern theRegExp =
example, we do a "rescan") *)
Lwt_unix.run (Globals.propagatePrefs ())
+(**********************************************************************
+ Statistics for update progress
+ **********************************************************************)
+
+(* This seemingly very complex code for calculating the progress rate
+ and ETA has partly to do with Unison currently not tracking progress
+ very accurately. Several potentially very time-consuming operations
+ are not tracked at all: hashing files before and after the copy, for
+ example. The entire amount of work may not even be known in advance
+ when continuing partial transfers after the previous sync has been
+ interrupted. This makes it very difficult to provide meaningful rate
+ and ETA information. The code below is the current best approximation.
+ The way to simplify this code here is to first and foremost improve
+ progress tracking and reporting. *)
+
+module Stats = struct
+
+let calcETA rem rate =
+ if Float.is_nan rate || Float.is_nan rem || rem < 0. then "" else
+ let t = truncate (rem /. rate +. 0.5) in
+ (* Estimating the remaining time is not accurate. Reduce the display
+ precision (and reduce more when longer time remaining). *)
+ let h, (m, sec) =
+ if t >= 3420 then
+ let u = t + 180 in u / 3600, (((u mod 3600) / 300) * 5, 0)
+ else
+ 0,
+ if t >= 2640 then ((t + 180) / 300) * 5, 0
+ else if t >= 1800 then ((t + 119) / 120) * 2, 0
+ else if t >= 120 then let u = t + 15 in u / 60, ((u mod 60) / 30) * 30
+ else t / 60, t mod 60
+ in
+ Printf.sprintf "%02d:%02d:%02d" h m sec
+
+let movAvg curr prev ?(c = 1.) deltaTime avgPeriod =
+ if Float.is_nan prev then curr else
+ let a = c *. Float.min (1. -. exp (-. deltaTime /. avgPeriod)) 1. in
+ (* Simplified from a *. curr +. (1. -. a) *. prev *)
+ prev +. a *. (curr -. prev)
+
+type t = (* abstract in mli *)
+ { mutable t0 : float;
+ mutable t : float;
+ totalToComplete : int64;
+ mutable completed : int64;
+ mutable curRate : float;
+ mutable avgRateS : float;
+ mutable avgRateDoubleSGauss : float;
+ }
+
+let gaussC = 2. *. (0.025 ** 2.)
+let avgPeriodS = 4.0
+let avgPeriodD = 3.5
+let calcPeriod = 0.25
+
+let init totalToTransfer =
+ let t0 = 0. in
+ { t0; t = t0; totalToComplete = Uutil.Filesize.toInt64 totalToTransfer;
+ completed = 0L;
+ curRate = Float.nan; avgRateS = Float.nan; avgRateDoubleSGauss = Float.nan;
+ }
+
+let calcAvgRate' sta totTime deltaCompleted deltaTime =
+ let curRate = (Int64.to_float deltaCompleted) /. deltaTime in
+ (* We want to ignore small fluctuations but react faster to large
+ changes (like switching from cache to disk or from disk to network
+ of from receiving to sending or with wildly variable network speed). *)
+ let avgRateS = movAvg curRate sta.avgRateS deltaTime
+ (Float.min_num totTime avgPeriodS) in
+ let cpr = (avgRateS -. sta.avgRateDoubleSGauss) /. sta.avgRateDoubleSGauss in
+ let c = 1. -. exp (-.(cpr ** 2.) /. gaussC) in
+ let avgRateDoubleSGauss = movAvg avgRateS sta.avgRateDoubleSGauss ~c deltaTime
+ (Float.min_num totTime avgPeriodD) in
+ sta.curRate <- curRate;
+ sta.avgRateS <- avgRateS;
+ sta.avgRateDoubleSGauss <- avgRateDoubleSGauss
+
+let update sta t1 totalCompleted =
+ let deltaTime = t1 -. sta.t in
+ let totalCompleted = Uutil.Filesize.toInt64 totalCompleted in
+ if sta.completed = 0L then begin
+ (* Skip the very first rate calculation because it will be skewed
+ due to (possibly significant) time losses during transport start. *)
+ sta.completed <- totalCompleted;
+ sta.t0 <- t1;
+ sta.t <- t1
+ end else if deltaTime >= calcPeriod then begin
+ let deltaCompleted = Int64.sub totalCompleted sta.completed in
+ sta.completed <- totalCompleted;
+ sta.t <- t1;
+ calcAvgRate' sta (t1 -. sta.t0) deltaCompleted deltaTime
+ end
+
+let curRate sta = sta.curRate
+let avgRate1 sta = sta.avgRateS
+let avgRate2 sta = sta.avgRateDoubleSGauss
+let eta sta ?(rate = sta.avgRateDoubleSGauss) default =
+ let rem = Int64.(to_float (sub sta.totalToComplete sta.completed)) in
+ let eta = calcETA rem rate in
+ if eta = "" then default else eta
+
+end
+
+(**********************************************************************
+ Update propagation
+ **********************************************************************)
+
+(* (For context: the threads in question are all cooperating Lwt threads.
+ These are not OS threads or parallel running domains. There is no
+ preemption and only a single thread is executing at any time.)
+
+ Many (thousands) transport threads can run concurrently and
+ independently of each other. All threads run to completion as long as
+ there are no errors or only [Util.Transient] exceptions are raised.
+
+ The threads are _not_ guaranteed to run to completion when an exception
+ other than [Util.Transient] is raised in any of the threads. This means
+ that the threads may not even be able to complete their own cleanup
+ code and may leak resources. There must be separate resource cleanup code
+ that can be run after the threads have been stopped either forcefully or
+ by running to completion.
+
+ When an uncaught exception other than [Util.Transient] is raised in any
+ of the threads, the following happens:
+
+ - the thread raising the exception is aborted (all exception handlers
+ are run normally, so this thread is expected to run all its cleanup
+ code);
+
+ - any threads still waiting to be started are immediately cancelled
+ (they will not have run any meaningful code and don't require any
+ cleanup);
+
+ - any threads that have already run to completion are not impacted
+ in any way;
+
+ - any (sleeping) threads running concurrently with the raising thread
+ are stopped, which may have a different meaning depending on where
+ in the execution each thread was when it was stopped:
+
+ - some threads will not be able to continue at all (they are
+ never woken up);
+ - some threads may be woken up and may be able to continue
+ running for a short while but may get an error the next time
+ when accessing some resource (and may be able to run the error
+ handler);
+ - some threads may receive an exception and be able to continue
+ running for a short while.
+
+ - any exceptions raised in/by threads that are stopped, are ignored;
+
+ - the original exception from the first raising thread is reraised.
+
+ The code run in these thread must _not_ assume that:
+ - it will be run to completion;
+ - it can run some or all of its cleanup handlers;
+ - it will have had a chance to run a certain amount of its code;
+ - it will even know that it was stopped.
+ Depending on where and how a thread was stopped, it may be collected by
+ GC without any additional code ever being run in that thread.
+
+
+ There is a limit regulating how many threads can be run concurrently in
+ the [Transport] module. An attempt is made to not start threads that will
+ not be able to run due to this limit. This delayed starting is done for
+ two reasons. First, to make the cleanup in case of an uncaught exception
+ easier: if the thread was never run then there is nothing to clean up.
+ Second, even though the threads themselves are extremely lightweight,
+ they still consume some resources and this will add up when the number
+ of threads grows to hundreds of thousands and millions.
+
+ Not starting up all threads at once and allowing finished threads to
+ be collected by GC as soon as possible can potentially reduce the memory
+ requirement by gigabytes. (This is a reference to the old implementation
+ that started all threads in one go and kept them all around until all
+ were completed. This approach could result in running out of memory when
+ syncing large number of updates.) *)
+
+let transportStart () = Transport.logStart ()
+
+let transportFinish () = Transport.logFinish ()
+
+let transportItems items pRiThisRound makeAction =
+ let waiter = Lwt.wait () in
+ let outstanding = ref 0 in
+ let starting () = incr outstanding in
+ let completed () =
+ decr outstanding;
+ if !outstanding = 0 then begin
+ try Lwt.wakeup waiter () with Invalid_argument _ -> ()
+ end
+ in
+ let failed e =
+ try Lwt.wakeup_exn waiter e with Invalid_argument _ -> ()
+ in
+ let waitAllCompleted () =
+ if !outstanding = 0 then Lwt.return () else waiter
+ in
+
+ let im = Array.length items in
+ let idx = ref 0 in
+ let stopDispense () = idx := im in
+ let makeAction' i item =
+ Lwt.try_bind
+ (fun () -> starting (); makeAction i item)
+ (fun () -> completed (); Lwt.return ())
+ (fun ex -> stopDispense (); failed ex; Lwt.return ())
+ in
+ let dispenseDone =
+ let c = ref 0 in (* Make sure [completed] is never called more than once *)
+ fun () ->
+ if (incr c; !c = 1) then completed ();
+ None
+ in
+ let rec dispenseAction () =
+ let i = !idx in
+ if i < im then begin
+ let item = items.(i) in
+ incr idx;
+ if pRiThisRound item then
+ Some (fun () -> makeAction' i item)
+ else
+ dispenseAction ()
+ end else
+ dispenseDone ()
+ in
+
+ let doTransportFailCleanup () =
+ (* Don't start any new threads. *)
+ begin try stopDispense () with _ -> () end;
+ (* Stop all transfers. *)
+ begin try Abort.all () with _ -> () end;
+ (* Since we don't know what state the RPC protocol is in, we need
+ to close the remote connection to prevent hangs on select(2)
+ the next time [Lwt_unix.run] is called.
+
+ This will immediately trigger [on_close] handlers (which will
+ do some resource cleanup). *)
+ begin try
+ match Globals.rootsInCanonicalOrder () with
+ | [_; otherRoot] -> Remote.clientCloseRootConnection otherRoot
+ | _ -> assert false
+ with _ -> () end;
+ (* Threads that were still in the middle of execution are just
+ discarded and eventually collected by GC. Resources are cleaned
+ up and reclaimed by [Remote.at_conn_close] handlers.
+
+ Not all threads are stuck or purged and will continue the next
+ time [Lwt_unix.run] is called. Try to finish these threads now.
+ This must be done in a loop since each failing thread may raise
+ an uncaught exception which will end [Lwt_unix.run]. We don't
+ know how many threads can finish this way, so we don't know when
+ to stop looping. The limit of concurrent threads is used as an
+ approximation (which is probably much more than needed). *)
+ let rec loop_yield n () =
+ if n = 0 then Lwt.return () else Lwt_unix.yield () >>= loop_yield (n - 1)
+ in
+ for _ = 1 to Transport.maxThreads () do
+ try
+ Lwt_unix.run (loop_yield 10 ())
+ with _ -> ()
+ done
+ in
+
+ starting (); (* Count the dispense loop as one of the tasks to complete *)
+ try
+ Transport.run dispenseAction;
+ Lwt_unix.run (waitAllCompleted ())
+ with e -> begin
+ (* Cleanup procedure must never raise exceptions. Just in case,
+ don't shadow the original exception. *)
+ let origbt = Printexc.get_raw_backtrace () in
+ let () = doTransportFailCleanup () in
+ Printexc.raise_with_backtrace e origbt
+ end
+
(**********************************************************************
Profile and command-line parsing
**********************************************************************)
@@ -442,6 +771,8 @@ let debug = Trace.debug "startup"
let architecture =
Remote.registerRootCmd
"architecture"
+ Umarshal.unit
+ Umarshal.(prod3 bool bool bool id id)
(fun (_,()) -> return (Util.osType = `Win32, Osx.isMacOSX, Util.isCygwin))
(* During startup the client determines the case sensitivity of each root.
@@ -475,6 +806,7 @@ let validateAndFixupPrefs () =
Prefs.set Globals.someHostIsRunningWindows someHostIsRunningWindows;
Prefs.set Globals.allHostsAreRunningWindows allHostsAreRunningWindows;
if repeatWatcher () then Prefs.set Fswatch.useWatcher true;
+ Features.validateEnabled ();
return ())
(* ---- *)
@@ -492,29 +824,41 @@ let provideProfileKey filename k profile info =
| Some(otherProfile,_) ->
raise (Util.Fatal
("Error scanning profile "^
- System.fspathToPrintString filename ^":\n"
+ filename ^":\n"
^ "shortcut key "^k^" is already bound to profile "
^ otherProfile))
else
raise (Util.Fatal
- ("Error scanning profile "^ System.fspathToPrintString filename ^":\n"
+ ("Error scanning profile "^ filename ^":\n"
^ "Value of 'key' preference must be a single digit (0-9), "
^ "not " ^ k))
with Failure _ -> raise (Util.Fatal
- ("Error scanning profile "^ System.fspathToPrintString filename ^":\n"
+ ("Error scanning profile "^ filename ^":\n"
^ "Value of 'key' preference must be a single digit (0-9), "
^ "not " ^ k))
let profilesAndRoots = ref []
let scanProfiles () =
+ Os.createUnisonDir ();
Array.iteri (fun i _ -> profileKeymap.(i) <- None) profileKeymap;
profilesAndRoots :=
- (Safelist.map
+ (Safelist.filterMap
(fun f ->
let f = Filename.chop_suffix f ".prf" in
let filename = Prefs.profilePathname f in
- let fileContents = Safelist.map (fun (_, _, n, v) -> (n, v)) (Prefs.readAFile f) in
+ let prefs =
+ try Some (Prefs.readAFile f) with
+ | Util.Fatal s -> begin
+ Util.warn ("Error when reading list of profiles.\n"
+ ^ "Skipping file with error: "
+ ^ filename
+ ^ "\n\n" ^ s);
+ None end in
+ match prefs with
+ | None -> None
+ | Some prefs ->
+ let fileContents = Safelist.map (fun (_, n, v) -> (n, v)) prefs in
let roots =
Safelist.map snd
(Safelist.filter (fun (n, _) -> n = "root") fileContents) in
@@ -530,7 +874,7 @@ let scanProfiles () =
let k = Safelist.assoc "key" fileContents in
provideProfileKey filename k f info
with Not_found -> ());
- (f, info))
+ Some (f, info))
(Safelist.filter (fun name -> not ( Util.startswith name ".#"
|| Util.startswith name Os.tempFilePrefix))
(Files.ls Util.unisonDir "*.prf")))
@@ -547,8 +891,7 @@ let initRoots displayWaitMessage termInteract =
and install them in Globals. *)
Lwt_unix.run (Globals.installRoots termInteract);
- (* Expand any "wildcard" paths [with final component *] *)
- Globals.expandWildcardPaths();
+ Files.processCommitLogs ();
Update.storeRootsName ();
@@ -576,6 +919,9 @@ let initRoots displayWaitMessage termInteract =
(Globals.rootsInCanonicalOrder());
Printf.eprintf "\n");
+ (* Expand any "wildcard" paths [with final component *] *)
+ Globals.expandWildcardPaths ();
+
Lwt_unix.run
(validateAndFixupPrefs () >>=
Globals.propagatePrefs);
@@ -586,39 +932,30 @@ let initRoots displayWaitMessage termInteract =
on this side, that's why it's here. *)
Stasher.initBackups ()
-let promptForRoots getFirstRoot getSecondRoot =
- (* Ask the user for the roots *)
- let r1 = match getFirstRoot() with None -> exit 0 | Some r -> r in
- let r2 = match getSecondRoot() with None -> exit 0 | Some r -> r in
- (* Remember them for this run, ordering them so that the first
- will come out on the left in the UI *)
- Globals.setRawRoots [r1; r2];
- (* Save them in the current profile *)
- ignore (Prefs.add "root" r1);
- ignore (Prefs.add "root" r2)
-
(* ---- *)
let makeTempDir pattern =
let path = Filename.temp_file pattern "" in
- let fspath = System.fspathFromString path in
- System.unlink fspath; (* Remove file created by [temp_file]... *)
- System.mkdir fspath 0o755; (* ... and create a dir instead. *)
+ System.unlink path; (* Remove file created by [temp_file]... *)
+ System.mkdir path 0o755; (* ... and create a dir instead. *)
path ^ Filename.dir_sep
-(* The first time we load preferences, we also read the command line
- arguments; if we re-load prefs (because the user selected a new profile)
- we ignore the command line *)
-let firstTime = ref(true)
+let initComplete = ref false
(* Roots given on the command line *)
let cmdLineRawRoots = ref []
+let clearClRoots () = cmdLineRawRoots := []
+
(* BCP: WARNING: Some of the code from here is duplicated in uimacbridge...! *)
-let initPrefs ~profileName ~displayWaitMessage ~getFirstRoot ~getSecondRoot
- ?(prepDebug = fun () -> ()) ~termInteract () =
- (* Restore prefs to their default values, if necessary *)
- if not !firstTime then Prefs.resetToDefaults();
+let initPrefs ~profileName ~promptForRoots ?(prepDebug = fun () -> ()) () =
+ initComplete := false;
+ (* Restore prefs to their default values *)
+ Prefs.resetToDefaults ();
+ (* Clear out any roots left from a previous profile. They can't remain
+ hanging around if [initPrefs] for the new profile receives an exception
+ before fully completing. *)
+ Globals.uninstallRoots ();
Globals.setRawRoots !cmdLineRawRoots;
(* Tell the preferences module the name of the profile *)
@@ -656,6 +993,9 @@ let initPrefs ~profileName ~displayWaitMessage ~getFirstRoot ~getSecondRoot
Prefs.parseCmdLine usageMsg;
end;
+ (* Turn on GC messages, if the '-debug gc' flag was provided *)
+ Gc.set {(Gc.get ()) with Gc.verbose = if Trace.enabled "gc" then 0x3F else 0};
+
(* Install dummy roots and backup directory if we are running self-tests *)
if Prefs.read runtests then begin
let tmpdir = makeTempDir "unisontest" in
@@ -679,16 +1019,39 @@ let initPrefs ~profileName ~displayWaitMessage ~getFirstRoot ~getSecondRoot
(* If no roots are given either on the command line or in the profile,
ask the user *)
if Globals.rawRoots() = [] then begin
- promptForRoots getFirstRoot getSecondRoot;
+ (* Ask the user for the roots *)
+ match promptForRoots () with
+ | None -> raise (Util.Fatal "no roots given on command line or in profile")
+ | Some (r1, r2) ->
+ begin
+ (* Remember them for this run, ordering them so that the first
+ will come out on the left in the UI *)
+ Globals.setRawRoots [r1; r2];
+ (* Save them in the current profile *)
+ ignore (Prefs.add "root" r1);
+ ignore (Prefs.add "root" r2)
+ end
end;
+ Trace.logonly "Roots:\n";
+ Globals.rawRoots () |> Safelist.iter
+ (fun s -> Trace.logonly " "; Trace.logonly s; Trace.logonly "\n");
+ Trace.logonly "\n";
+
+ (* Parse the roots to validate them *)
+ let parsedRoots =
+ try Globals.parsedClRawRoots () with
+ | Invalid_argument s | Util.Fatal s | Prefs.IllegalValue s ->
+ raise (Util.Fatal ("There's a problem with one of the roots:\n" ^ s))
+ in
+
(* Check to be sure that there is at most one remote root *)
let numRemote =
Safelist.fold_left
- (fun n r -> match Clroot.parseRoot r with
+ (fun n (r : Clroot.clroot) -> match r with
ConnectLocal _ -> n | ConnectByShell _ | ConnectBySocket _ -> n+1)
0
- (Globals.rawRoots ()) in
+ parsedRoots in
if numRemote > 1 then
raise(Util.Fatal "cannot synchronize more than one remote root");
@@ -700,16 +1063,15 @@ let initPrefs ~profileName ~displayWaitMessage ~getFirstRoot ~getSecondRoot
(* If no paths were specified, then synchronize the whole replicas *)
if Prefs.read Globals.paths = [] then Prefs.set Globals.paths [Path.empty];
- initRoots displayWaitMessage termInteract;
-
- firstTime := false
+ initComplete := true
-let refreshConnection ~displayWaitMessage ~termInteract =
- assert (Safelist.length (Globals.rootsList ()) > 1);
+let connectRoots ?termInteract ~displayWaitMessage () =
+ let numRoots = Safelist.length (Globals.rawRoots ()) in
+ if !initComplete && numRoots > 1 then
let numConn = ref 0 in
Lwt_unix.run (Globals.allRootsIter
(fun r -> if Remote.isRootConnected r then incr numConn; Lwt.return ()));
- if !numConn < 2 then initRoots displayWaitMessage termInteract
+ if !numConn < numRoots then initRoots displayWaitMessage termInteract
(**********************************************************************
Common startup sequence
@@ -717,10 +1079,13 @@ let refreshConnection ~displayWaitMessage ~termInteract =
let anonymousArgs =
Prefs.createStringList "rest"
+ ~category:(`Internal `Other)
"*roots or profile name" ""
let testServer =
Prefs.createBool "testserver" false
+ ~category:(`Advanced `Remote)
+ ~cli_only:true
"exit immediately after the connection to the server"
("Setting this flag on the command line causes Unison to attempt to "
^ "connect to the remote server and, if successful, print a message "
@@ -732,105 +1097,61 @@ let _ = Prefs.alias testServer "testServer"
(* ---- *)
-let uiInit
- ?(prepDebug = fun () -> ())
- ~(reportError : string -> unit)
- ~(tryAgainOrQuit : string -> bool)
- ~(displayWaitMessage : unit -> unit)
- ~(getProfile : unit -> string option)
- ~(getFirstRoot : unit -> string option)
- ~(getSecondRoot : unit -> string option)
- ~(termInteract : (string -> string -> string) option)
- () =
-
+let uiInitClRootsAndProfile ?(prepDebug = fun () -> ()) () =
(* Make sure we have a directory for archives and profiles *)
Os.createUnisonDir();
- (* Extract any command line profile or roots *)
- let clprofile = ref None in
+ let args = Prefs.scanCmdLine usageMsg in
begin
- let args = Prefs.scanCmdLine usageMsg in
- begin
- try if Util.StringMap.find "debug" args <> [] then prepDebug ()
- with Not_found -> ()
- end;
+ try if Util.StringMap.find "debug" args <> [] then prepDebug ()
+ with Not_found -> ()
+ end;
+ (* Extract any command line profile or roots *)
+ match begin
try
match Util.StringMap.find "rest" args with
- [] -> ()
- | [profile] -> clprofile := Some profile
- | [root2;root1] -> cmdLineRawRoots := [root1;root2]
+ | [] -> Ok None
+ | [profile] -> Ok (Some profile)
+ | [root2;root1] -> Ok (cmdLineRawRoots := [root1;root2]; None)
| [root2;root1;profile] ->
- cmdLineRawRoots := [root1;root2];
- clprofile := Some profile
+ Ok (cmdLineRawRoots := [root1;root2]; Some profile)
| _ ->
- (reportError(Printf.sprintf
- "%s was invoked incorrectly (too many roots)" Uutil.myName);
- exit 1)
- with Not_found -> ()
- end;
-
- (* Print header for debugging output *)
- debug (fun() ->
- Printf.eprintf "%s, version %s\n\n" Uutil.myName Uutil.myVersion);
- debug (fun() -> Util.msg "initializing UI");
-
- debug (fun () ->
- (match !clprofile with
- None -> Util.msg "No profile given on command line"
- | Some s -> Printf.eprintf "Profile '%s' given on command line" s);
- (match !cmdLineRawRoots with
- [] -> Util.msg "No roots given on command line"
- | [root1;root2] ->
- Printf.eprintf "Roots '%s' and '%s' given on command line"
- root1 root2
- | _ -> assert false));
-
- let profileName =
- begin match !clprofile with
- None ->
- let clroots_given = !cmdLineRawRoots <> [] in
- let n =
- if not(clroots_given) then begin
- (* Ask the user to choose a profile or create a new one. *)
- clprofile := getProfile();
- match !clprofile with
- None -> exit 0 (* None means the user wants to quit *)
- | Some x -> x
- end else begin
- (* Roots given on command line.
- The profile should be the default. *)
- clprofile := Some "default";
- "default"
- end in
- n
- | Some n ->
- let f = Prefs.profilePathname n in
- if not(System.file_exists f)
- then (reportError (Printf.sprintf "Profile %s does not exist"
- (System.fspathToPrintString f));
- exit 1);
- n
- end in
-
- (* Load the profile and command-line arguments *)
- initPrefs
- ~profileName ~displayWaitMessage ~getFirstRoot ~getSecondRoot
- ~prepDebug ~termInteract ();
-
- (* Turn on GC messages, if the '-debug gc' flag was provided *)
- if Trace.enabled "gc" then Gc.set {(Gc.get ()) with Gc.verbose = 0x3F};
-
- if Prefs.read testServer then exit 0;
-
- (* BCPFIX: Should/can this be done earlier?? *)
- Files.processCommitLogs();
-
- (* Run unit tests if requested *)
- if Prefs.read runtests then begin
- (!testFunction)();
- exit 0
- end
+ Error (Printf.sprintf
+ "%s was invoked incorrectly (too many roots)" Uutil.myName)
+ with Not_found -> Ok None
+ end with
+ | Error _ as e -> e
+ | Ok clprofile ->
+ debug (fun () ->
+ (* Print header for debugging output *)
+ Printf.eprintf "%s, version %s\n\n" Uutil.myName Uutil.myVersion;
+ Util.msg "initializing UI";
+
+ (match clprofile with
+ | None -> Util.msg "No profile given on command line"
+ | Some s -> Printf.eprintf "Profile '%s' given on command line" s);
+ (match !cmdLineRawRoots with
+ | [] -> Util.msg "No roots given on command line"
+ | [root1;root2] ->
+ Printf.eprintf "Roots '%s' and '%s' given on command line"
+ root1 root2
+ | _ -> assert false));
+
+ match clprofile with
+ | None when !cmdLineRawRoots = [] ->
+ (* Ask the user to choose a profile or create a new one. *)
+ Ok None
+ | None ->
+ (* Roots given on command line. The profile should be the default. *)
+ Ok (Some "default")
+ | Some n ->
+ let f = Prefs.profilePathname n in
+ if not (System.file_exists f)
+ then Error (Printf.sprintf
+ "Profile '%s' does not exist (looking for file %s)"
+ n f)
+ else Ok (Some n)
(* Exit codes *)
let perfectExit = 0 (* when everything's okay *)
diff --git a/src/uicommon.mli b/src/uicommon.mli
index 7c178db..de5affd 100644
--- a/src/uicommon.mli
+++ b/src/uicommon.mli
@@ -6,6 +6,8 @@ type interface =
Text
| Graphic
+val minterface : interface Umarshal.t
+
(* The interface of a concrete UI implementation *)
module type UI =
sig
@@ -32,7 +34,8 @@ val contactingServerMsg : unit -> string
val profileLabel : string Prefs.t
(* User preference: Synchronize repeatedly *)
-val repeat : string Prefs.t
+val repeat : [ `NoRepeat | `Interval of int | `Watch
+ | `WatchAndInterval of int | `Invalid of string * exn ] Prefs.t
(* User preference: Try failing paths N times *)
val retry : int Prefs.t
@@ -42,6 +45,10 @@ val confirmmerge : bool Prefs.t
val runTestsPrefName : string
+val runtests : bool Prefs.t
+
+val testServer : bool Prefs.t
+
(* Format the information about current contents of a path in one replica (the second argument
is used as a separator) *)
val details2string : Common.reconItem -> string -> string
@@ -87,35 +94,27 @@ val usageMsg : string
val shortUsageMsg : string
-val uiInit :
+val uiInitClRootsAndProfile :
?prepDebug:(unit -> unit) ->
- reportError:(string -> unit) ->
- tryAgainOrQuit:(string -> bool) ->
- displayWaitMessage:(unit -> unit) ->
- getProfile:(unit -> string option) ->
- getFirstRoot:(unit -> string option) ->
- getSecondRoot:(unit -> string option) ->
- termInteract:(string -> string -> string) option ->
unit ->
- unit
+ (string option, string) result
val initPrefs :
profileName:string ->
- displayWaitMessage:(unit->unit) ->
- getFirstRoot:(unit->string option) ->
- getSecondRoot:(unit->string option) ->
+ promptForRoots:(unit -> (string * string) option) ->
?prepDebug:(unit -> unit) ->
- termInteract:(string -> string -> string) option ->
unit ->
unit
+val clearClRoots : unit -> unit
+
(* Make sure remote connections (if any) corresponding to active roots
- are still established and re-establish them if necessary.
- [refreshConnection] is like [initPrefs] but without reloading the profile
- and re-initializing the prefs. *)
-val refreshConnection :
+ are established and (re-)establish them if necessary.
+ [initPrefs] must be called before [connectRoots]. *)
+val connectRoots :
+ ?termInteract:(string -> Terminal.termInteract) ->
displayWaitMessage:(unit -> unit) ->
- termInteract:(string -> string -> string) option ->
+ unit ->
unit
val validateAndFixupPrefs : unit -> unit Lwt.t
@@ -139,3 +138,26 @@ val profileKeymap : (string * profileInfo) option array
val profilesAndRoots : (string * profileInfo) list ref
val scanProfiles : unit -> unit
+
+(* Update propagation *)
+val transportStart : unit -> unit
+val transportFinish : unit -> unit
+
+val transportItems : 'a array -> ('a -> bool) -> (int -> 'a -> unit Lwt.t) -> unit
+
+(* Statistics of update propagation *)
+module Stats : sig
+ type t
+ val init :
+ Uutil.Filesize.t (* Total size to complete 100% *)
+ -> t
+ val update :
+ t
+ -> float (* Current absolute time *)
+ -> Uutil.Filesize.t (* Current completed size (not delta) *)
+ -> unit
+ val curRate : t -> float (* Current progress rate, very volatile *)
+ val avgRate1 : t -> float (* Moving average of the rate above, more stable *)
+ val avgRate2 : t -> float (* Double moving average, very stable *)
+ val eta : t -> ?rate:float -> string -> string (* Defaults to rate2 *)
+end
diff --git a/src/uigtk2.ml b/src/uigtk3.ml
similarity index 80%
rename from src/uigtk2.ml
rename to src/uigtk3.ml
index f8d73a2..c0092fe 100644
--- a/src/uigtk2.ml
+++ b/src/uigtk3.ml
@@ -1,4 +1,4 @@
-(* Unison file synchronizer: src/uigtk2.ml *)
+(* Unison file synchronizer: src/uigtk3.ml *)
(* Copyright 1999-2020, Benjamin C. Pierce
This program is free software: you can redistribute it and/or modify
@@ -60,13 +60,7 @@ must enter the host to connect to, a user name (if different from
your user name on this machine), and the directory on the remote machine
(relative to your home directory on that machine).
-2) To synchronize using RSH, there must be an RSH client installed on
-this machine and an RSH server installed on the remote machine. You
-must enter the host to connect to, a user name (if different from
-your user name on this machine), and the directory on the remote machine
-(relative to your home directory on that machine).
-
-3) To synchronize using %s's socket protocol, there must be a %s
+2) To synchronize using %s's socket protocol, there must be a %s
server running on the remote machine, listening to the port that you
specify here. (Use \"%s -socket xxx\" on the remote machine to
start the %s server.) You must enter the host, port, and the directory
@@ -92,23 +86,16 @@ let icon =
(Gpointer.region_of_bytes Pixmaps.icon_data)
*)
let icon =
- let p = GdkPixbuf.create ~width:48 ~height:48 ~has_alpha:true () in
- let pxs = GdkPixbuf.get_pixels p in
- (* This little hack is here to support compiling with lablgtk versions both
- < 2.18.6 and >= 2.18.6 *)
- String.iteri (fun i c -> Gpointer.set_byte pxs ~pos:i (Char.code c)) Pixmaps.icon_data;
- p
+ lazy begin
+ let p = GdkPixbuf.create ~width:48 ~height:48 ~has_alpha:true () in
+ Gpointer.blit
+ ~src:(Gpointer.region_of_bytes (Bytes.of_string Pixmaps.icon_data))
+ ~dst:(GdkPixbuf.get_pixels p);
+ p
+ end
let leftPtrWatch =
- lazy
- (let bitmap =
- Gdk.Bitmap.create_from_data
- ~width:32 ~height:32 Pixmaps.left_ptr_watch
- in
- let color =
- Gdk.Color.alloc ~colormap:(Gdk.Color.get_system_colormap ()) `BLACK in
- Gdk.Cursor.create_from_pixmap
- (bitmap :> Gdk.pixmap) ~mask:bitmap ~fg:color ~bg:color ~x:2 ~y:2)
+ lazy (Gdk.Cursor.create `WATCH)
let make_busy w =
if Util.osType <> `Win32 then
@@ -145,10 +132,18 @@ let toplevelWindow () =
let busy = ref false
let getLock f =
+ let protect ~(finally : unit -> unit) f =
+ (* Very simple [protect] when we know that [finally] does not raise *)
+ (* FIXME: Switch to [Fun.protect] once OCaml 4.09 is the minimum? *)
+ try let () = f () in finally () with
+ | e ->
+ finally ();
+ raise e
+ in
if !busy then
Trace.status "Synchronizer is busy, please wait.."
else begin
- busy := true; f (); busy := false
+ busy := true; protect ~finally:(fun () -> busy := false) f
end
(**********************************************************************
@@ -266,21 +261,21 @@ let transcode s =
USEFUL LOW-LEVEL WIDGETS
**********************************************************************)
-class scrolled_text ?editable ?shadow_type ?word_wrap
- ~width ~height ?packing ?show
+class scrolled_text ?editable ?shadow_type ?(wrap_mode=`WORD) ?packing ?show
() =
let sw =
GBin.scrolled_window ?packing ~show:false
- ?shadow_type ~hpolicy:`NEVER ~vpolicy:`AUTOMATIC ()
+ ?shadow_type ~hpolicy:`AUTOMATIC ~vpolicy:`AUTOMATIC ()
in
- let text = GText.view ?editable ~wrap_mode:`WORD ~packing:sw#add () in
+ let text = GText.view ?editable ~wrap_mode ~packing:sw#add () in
+ let () = text#set_left_margin 4
+ and () = text#set_right_margin 4 in
object
inherit GObj.widget_full sw#as_widget
method text = text
method insert s = text#buffer#set_text s;
method show () = sw#misc#show ()
initializer
- text#misc#set_size_chars ~height ~width ();
if show <> Some false then sw#misc#show ()
end
@@ -306,8 +301,8 @@ let primaryText msg =
chosen, false if the second button is chosen. *)
let twoBox ?(kind=`DIALOG_WARNING) ~parent ~title ~astock ~bstock message =
let t =
- GWindow.dialog ~parent ~border_width:6 ~modal:true ~no_separator:true
- ~allow_grow:false () in
+ GWindow.dialog ~parent ~border_width:6 ~modal:true
+ ~resizable:false () in
t#vbox#set_spacing 12;
let h1 = GPack.hbox ~border_width:6 ~spacing:12 ~packing:t#vbox#pack () in
ignore (GMisc.image ~stock:kind ~icon_size:`DIALOG
@@ -353,7 +348,7 @@ let warnBox ~parent title message =
(* In batch mode, just pop up a window and go ahead *)
let t =
GWindow.dialog ~parent
- ~border_width:6 ~modal:true ~no_separator:true ~allow_grow:false () in
+ ~border_width:6 ~modal:true ~resizable:false () in
t#vbox#set_spacing 12;
let h1 = GPack.hbox ~border_width:6 ~spacing:12 ~packing:t#vbox#pack () in
ignore (GMisc.image ~stock:`DIALOG_INFO ~icon_size:`DIALOG
@@ -406,27 +401,28 @@ class ['a] gMenuFactory
(* Register this accel path *)
GtkBase.Widget.set_accel_path item#as_widget accel_path accel_group;
Gaux.may callback ~f:(fun callback -> item#connect#activate ~callback)
- method add_item ?key ?modi ?callback ?submenu label =
+ method add_item ?key ?modi ?callback ?submenu ?bindname label =
let item = GMenu.menu_item ~use_mnemonic:true ~label () in
- self#bind ?modi ?key ?callback label item;
+ self#bind ?modi ?key ?callback label ?name:bindname item;
Gaux.may (submenu : GMenu.menu option) ~f:item#set_submenu;
item
method add_image_item ?(image : GObj.widget option)
?modi ?key ?callback ?stock ?name label =
+ (* GTK 3 does not provide image menu items (there is a way to
+ manually create a workaround but that does not work with
+ lablgtk. Let's create a regular menu item instead. *)
let item =
- GMenu.image_menu_item ~use_mnemonic:true ?image ~label ?stock () in
+ GMenu.menu_item ~use_mnemonic:true ~label () in
match stock with
| None ->
- self#bind ?modi ?key ?callback label ?name
- (item : GMenu.image_menu_item :> GMenu.menu_item);
+ self#bind ?modi ?key ?callback label ?name item;
item
| Some s ->
try
let st = GtkStock.Item.lookup s in
self#bind
?modi ?key:(if st.GtkStock.keyval=0 then key else None)
- ?callback label ?name
- (item : GMenu.image_menu_item :> GMenu.menu_item);
+ ?callback label ?name item;
item
with Not_found -> item
@@ -449,54 +445,83 @@ end
HIGHER-LEVEL WIDGETS
***********************************************************************)
+(* FIXME: This is a lowest-effort port of GTK2 pixmap-based code to GTK3.
+ It works but is probably needlessly inefficient(??). It should be
+ rewritten from scratch to match the new GTK(+Cairo) API and only draw
+ updated regions. *)
class stats width height =
- let pixmap = GDraw.pixmap ~width ~height () in
let area =
- pixmap#set_foreground `WHITE;
- pixmap#rectangle ~filled:true ~x:0 ~y:0 ~width ~height ();
- GMisc.pixmap pixmap ~width ~height ~xpad:4 ~ypad:8 ()
+ let d = GMisc.drawing_area () in
+ d#set_width_request width;
+ d#set_height_request height;
+ d#set_margin_left 4;
+ d#set_margin_right 4;
+ d#set_margin_top 8;
+ d#set_margin_bottom 8;
+ d#set_hexpand true;
+ d#set_vexpand true;
+ d
in
object (self)
inherit GObj.widget_full area#as_widget
val mutable maxim = ref 0.
val mutable scale = ref 1.
val mutable min_scale = 1.
- val values = Array.make width 0.
+ val mutable values = Array.make width 0.
val mutable active = false
+ val mutable width = float_of_int width
+ val mutable height = float_of_int height
+ initializer
+ ignore (area#misc#connect#size_allocate ~callback:self#resize);
+ ignore (area#misc#connect#draw ~callback:self#redraw)
+
+ method resize rect =
+ let oldw = truncate width in
+ let neww = min rect.Gtk.width 640 in
+ if neww > oldw then
+ values <- Array.append (Array.make (neww - oldw) 0.) (Array.sub values 0 oldw)
+ else if neww < oldw then begin
+ Array.blit values (oldw - neww) values 0 neww
+ end;
+ width <- float_of_int neww;
+ height <- float_of_int (min rect.Gtk.height 200);
+ area#misc#queue_draw ()
- method redraw () =
+ method redraw cr =
scale := min_scale;
while !maxim > !scale do
scale := !scale *. 1.5
done;
- pixmap#set_foreground `WHITE;
- pixmap#rectangle ~filled:true ~x:0 ~y:0 ~width ~height ();
- pixmap#set_foreground `BLACK;
- for i = 0 to width - 1 do
- self#rect i values.(max 0 (i - 1)) values.(i)
- done
+ Cairo.set_source_rgb cr 1. 1. 1.;
+ Cairo.rectangle cr 0. 0. ~w:width ~h:height;
+ Cairo.fill cr;
+ for i = 0 to truncate width - 1 do
+ self#rect cr i values.(max 0 (i - 1)) values.(i)
+ done;
+ true
- method activate a = active <- a; if a then self#redraw ()
+ method activate a = active <- a; if a then area#misc#queue_draw ()
- method scale h = truncate ((float height) *. h /. !scale)
+ method scale h = height *. h /. !scale
- method private rect i v' v =
+ method private rect cr i v' v =
let h = self#scale v in
let h' = self#scale v' in
let h1 = min h' h in
let h2 = max h' h in
- pixmap#set_foreground `BLACK;
- pixmap#rectangle
- ~filled:true ~x:i ~y:(height - h1) ~width:1 ~height:h1 ();
- for h = h1 + 1 to h2 do
- let v = truncate (65535. *. (float (h - h1) /. float (h2 - h1))) in
- let v = (v / 4096) * 4096 in (* Only use 16 gray levels *)
- pixmap#set_foreground (`RGB (v, v, v));
- pixmap#rectangle
- ~filled:true ~x:i ~y:(height - h) ~width:1 ~height:1 ();
+ Cairo.set_source_rgb cr 0. 0. 0.;
+ Cairo.rectangle cr (float_of_int i) (height -. h1) ~w:1. ~h:h1;
+ Cairo.fill cr;
+ for h = (truncate h1) + 1 to (truncate h2) do
+ let v = ((float h -. h1) /. (h2 -. h1)) in
+ Cairo.set_source_rgb cr v v v;
+ Cairo.rectangle cr (float_of_int i) (height -. float h) ~w:1. ~h:1.;
+ Cairo.fill cr;
+ ()
done
method push v =
+ let width = truncate width in
let need_max = values.(0) = !maxim in
for i = 0 to width - 2 do
values.(i) <- values.(i + 1)
@@ -508,18 +533,7 @@ class stats width height =
end else
maxim := max !maxim v;
if active then begin
- let need_resize =
- !maxim > !scale || (!maxim > min_scale && !maxim < !scale /. 1.5) in
- if need_resize then
- self#redraw ()
- else begin
- pixmap#put_pixmap ~x:0 ~y:0 ~xsrc:1 (pixmap#pixmap);
- pixmap#set_foreground `WHITE;
- pixmap#rectangle
- ~filled:true ~x:(width - 1) ~y:0 ~width:1 ~height ();
- self#rect (width - 1) values.(width - 2) values.(width - 1)
- end;
- area#misc#draw None
+ area#misc#queue_draw ()
end
end
@@ -545,9 +559,20 @@ let rate2str v =
" "
end
+let mib = 1024. *. 1024.
+let kib2str v =
+ if v > 100_000_000. then
+ Format.sprintf "%.0f MiB" (v /. mib)
+ else if v > 1_000_000. then
+ Format.sprintf "%.1f MiB" (v /. mib)
+ else if v > 1024. then
+ Format.sprintf "%.1f KiB" (v /. 1024.)
+ else
+ Format.sprintf "%.0f B" v
+
let statistics () =
let title = "Statistics" in
- let t = GWindow.dialog ~title () in
+ let t = GWindow.dialog ~title ~parent:(toplevelWindow ()) () in
let t_dismiss = GButton.button ~stock:`CLOSE ~packing:t#action_area#add () in
t_dismiss#grab_default ();
let dismiss () = t#misc#hide () in
@@ -559,22 +584,28 @@ let statistics () =
let reception = new stats 320 50 in
t#vbox#pack ~expand:false ~padding:4 (reception :> GObj.widget);
- let lst =
- GList.clist
- ~packing:(t#vbox#add)
- ~titles_active:false
- ~titles:[""; "Client"; "Server"; "Total"] ()
- in
- lst#set_column ~auto_resize:true 0;
- lst#set_column ~auto_resize:true ~justification:`RIGHT 1;
- lst#set_column ~auto_resize:true ~justification:`RIGHT 2;
- lst#set_column ~auto_resize:true ~justification:`RIGHT 3;
- ignore (lst#append ["Reception rate"]);
- ignore (lst#append ["Data received"]);
- ignore (lst#append ["File data written"]);
- for r = 0 to 2 do
- lst#set_row ~selectable:false r
- done;
+ let cols = new GTree.column_list in
+ let c_1 = cols#add Gobject.Data.string in
+ let c_client = cols#add Gobject.Data.string in
+ let c_server = cols#add Gobject.Data.string in
+ let c_total = cols#add Gobject.Data.string in
+ let lst = GTree.list_store cols in
+ let l = GTree.view ~model:lst ~enable_search:false ~packing:(t#vbox#add) () in
+ l#selection#set_mode `NONE;
+ ignore (l#append_column (GTree.view_column ~title:""
+ ~renderer:(GTree.cell_renderer_text [], ["text", c_1]) ()));
+ ignore (l#append_column (GTree.view_column ~title:"Client"
+ ~renderer:(GTree.cell_renderer_text [`XALIGN 1.0], ["text", c_client]) ()));
+ ignore (l#append_column (GTree.view_column ~title:"Server"
+ ~renderer:(GTree.cell_renderer_text [`XALIGN 1.0], ["text", c_server]) ()));
+ ignore (l#append_column (GTree.view_column ~title:"Total"
+ ~renderer:(GTree.cell_renderer_text [`XALIGN 1.0], ["text", c_total]) ()));
+ let rate_row = lst#append () in
+ ignore (lst#set ~row:rate_row ~column:c_1 "Reception rate");
+ let receive_row = lst#append () in
+ ignore (lst#set ~row:receive_row ~column:c_1 "Data received");
+ let data_row = lst#append () in
+ ignore (lst#set ~row:data_row ~column:c_1 "File data written");
ignore (t#event#connect#map ~callback:(fun _ ->
emission#activate true;
@@ -597,19 +628,18 @@ let statistics () =
let stopCounter = ref 0 in
let updateTable () =
- let kib2str v = Format.sprintf "%.0f B" v in
- lst#set_cell ~text:(rate2str !receiveRate2) 0 1;
- lst#set_cell ~text:(rate2str !emitRate2) 0 2;
- lst#set_cell ~text:
- (rate2str (!receiveRate2 +. !emitRate2)) 0 3;
- lst#set_cell ~text:(kib2str !receivedBytes) 1 1;
- lst#set_cell ~text:(kib2str !emittedBytes) 1 2;
- lst#set_cell ~text:
- (kib2str (!receivedBytes +. !emittedBytes)) 1 3;
- lst#set_cell ~text:(kib2str !clientWritten) 2 1;
- lst#set_cell ~text:(kib2str !serverWritten) 2 2;
- lst#set_cell ~text:
- (kib2str (!clientWritten +. !serverWritten)) 2 3
+ let row = rate_row in
+ lst#set ~row ~column:c_client (rate2str !receiveRate2);
+ lst#set ~row ~column:c_server (rate2str !emitRate2);
+ lst#set ~row ~column:c_total (rate2str (!receiveRate2 +. !emitRate2));
+ let row = receive_row in
+ lst#set ~row ~column:c_client (kib2str !receivedBytes);
+ lst#set ~row ~column:c_server (kib2str !emittedBytes);
+ lst#set ~row ~column:c_total (kib2str (!receivedBytes +. !emittedBytes));
+ let row = data_row in
+ lst#set ~row ~column:c_client (kib2str !clientWritten);
+ lst#set ~row ~column:c_server (kib2str !serverWritten);
+ lst#set ~row ~column:c_total (kib2str (!clientWritten +. !serverWritten))
in
let timeout _ =
emitRate :=
@@ -648,31 +678,29 @@ let statistics () =
let stopStats () = stopCounter := 10 in
(t, startStats, stopStats)
-(****)
-
-(* Standard file dialog *)
-let file_dialog ~parent ~title ~callback ?filename () =
- let sel = GWindow.file_selection ~parent ~title ~modal:true ?filename () in
- ignore (sel#cancel_button#connect#clicked ~callback:sel#destroy);
- ignore (sel#ok_button#connect#clicked ~callback:
- (fun () ->
- let name = sel#filename in
- sel#destroy ();
- callback name));
- sel#show ();
- ignore (sel#connect#destroy ~callback:GMain.Main.quit);
- GMain.Main.main ()
-
(* ------ *)
-let fatalError message =
+let gui_safe_eprintf fmt =
+ Printf.ksprintf (fun s ->
+ if System.has_stderr ~info:s then Printf.eprintf "%s%!" s) fmt
+
+let fatalError ?(quit=false) message =
let () =
+ Trace.sendLogMsgsToStderr := false; (* We don't know if stderr is available *)
try Trace.log (message ^ "\n")
with Util.Fatal _ -> () in (* Can't allow fatal errors in fatal error handler *)
let title = "Fatal error" in
+ let toplevelWindow =
+ try toplevelWindow ()
+ with Util.Fatal err ->
+ begin
+ gui_safe_eprintf "\n%s:\n%s\n\n%s\n\n" title err message;
+ exit 1
+ end
+ in
let t =
- GWindow.dialog ~parent:(toplevelWindow ())
- ~border_width:6 ~modal:true ~no_separator:true ~allow_grow:false () in
+ GWindow.dialog ~parent:toplevelWindow
+ ~border_width:6 ~modal:true ~resizable:false () in
t#vbox#set_spacing 12;
let h1 = GPack.hbox ~border_width:6 ~spacing:12 ~packing:t#vbox#pack () in
ignore (GMisc.image ~stock:`DIALOG_ERROR ~icon_size:`DIALOG
@@ -683,19 +711,20 @@ let fatalError message =
escapeMarkup (transcode message))
~line_wrap:true ~selectable:true ~yalign:0. ~packing:v1#add ());
t#add_button_stock `QUIT `QUIT;
- t#set_default_response `QUIT;
+ if not quit then t#add_button_stock `CLOSE `CLOSE;
+ t#set_default_response (if quit then `QUIT else `CLOSE);
+ ignore (t#connect#response
+ ~callback:(function `QUIT -> exit 1 | _ -> ()));
t#show(); ignore (t#run ()); t#destroy ();
- exit 1
-
-(* ------ *)
+ if quit then exit 1
-let tryAgainOrQuit = fatalError
+let fatalErrorHandler = ref (fatalError ~quit:true)
(* ------ *)
let getFirstRoot () =
let t = GWindow.dialog ~parent:(toplevelWindow ()) ~title:"Root selection"
- ~modal:true ~allow_grow:true () in
+ ~modal:true ~resizable:true () in
t#misc#grab_focus ();
let hb = GPack.hbox
@@ -709,20 +738,22 @@ let getFirstRoot () =
ignore (GMisc.label ~text:"Dir:" ~packing:(f1#pack ~expand:false) ());
let fileE = GEdit.entry ~packing:f1#add () in
fileE#misc#grab_focus ();
- let browseCommand() =
- file_dialog ~parent:t ~title:"Select a local directory"
- ~callback:fileE#set_text ~filename:fileE#text () in
- let b = GButton.button ~label:"Browse"
- ~packing:(f1#pack ~expand:false) () in
- ignore (b#connect#clicked ~callback:browseCommand);
+ let b = GFile.chooser_button ~action:`SELECT_FOLDER
+ ~title:"Select a local directory"
+ ~packing:(f1#pack ~expand:false) () in
+ ignore (b#connect#selection_changed ~callback:(fun () ->
+ if not fileE#is_focus then
+ fileE#set_text (match b#filename with None -> "" | Some s -> s)));
+ ignore (fileE#connect#changed ~callback:(fun () ->
+ if fileE#is_focus then ignore (b#set_filename fileE#text)));
let f3 = t#action_area in
let result = ref None in
let contCommand() =
- result := Some(fileE#text);
+ result := Some (Util.trimWhitespace fileE#text);
t#destroy () in
- let quitButton = GButton.button ~stock:`QUIT ~packing:f3#add () in
- ignore (quitButton#connect#clicked
+ let cancelButton = GButton.button ~stock:`CANCEL ~packing:f3#add () in
+ ignore (cancelButton#connect#clicked
~callback:(fun () -> result := None; t#destroy()));
let contButton = GButton.button ~stock:`OK ~packing:f3#add () in
ignore (contButton#connect#clicked ~callback:contCommand);
@@ -739,7 +770,7 @@ let getFirstRoot () =
let getSecondRoot () =
let t = GWindow.dialog ~parent:(toplevelWindow ()) ~title:"Root selection"
- ~modal:true ~allow_grow:true () in
+ ~modal:true ~resizable:true () in
t#misc#grab_focus ();
let message = "Please enter the second directory you want to synchronize." in
@@ -762,12 +793,14 @@ let getSecondRoot () =
ignore (GMisc.label ~text:"Directory:" ~packing:(f1#pack ~expand:false) ());
let fileE = GEdit.entry ~packing:f1#add () in
fileE#misc#grab_focus ();
- let browseCommand() =
- file_dialog ~parent:t ~title:"Select a local directory"
- ~callback:fileE#set_text ~filename:fileE#text () in
- let b = GButton.button ~label:"Browse"
- ~packing:(f1#pack ~expand:false) () in
- ignore (b#connect#clicked ~callback:browseCommand);
+ let b = GFile.chooser_button ~action:`SELECT_FOLDER
+ ~title:"Select a local directory"
+ ~packing:(f1#pack ~expand:false) () in
+ ignore (b#connect#selection_changed ~callback:(fun () ->
+ if not fileE#is_focus then
+ fileE#set_text (match b#filename with None -> "" | Some s -> s)));
+ ignore (fileE#connect#changed ~callback:(fun () ->
+ if fileE#is_focus then ignore (b#set_filename fileE#text)));
let f0 = GPack.hbox ~spacing:4 ~packing:f#add () in
let localB = GButton.radio_button ~packing:(f0#pack ~expand:false)
@@ -775,8 +808,6 @@ let getSecondRoot () =
let sshB = GButton.radio_button ~group:localB#group
~packing:(f0#pack ~expand:false)
~label:"SSH" () in
- let rshB = GButton.radio_button ~group:localB#group
- ~packing:(f0#pack ~expand:false) ~label:"RSH" () in
let socketB = GButton.radio_button ~group:sshB#group
~packing:(f0#pack ~expand:false) ~label:"Socket" () in
@@ -792,7 +823,7 @@ let getSecondRoot () =
~packing:(f2#pack ~expand:false) ());
let portE = GEdit.entry ~packing:f2#add () in
- let varLocalRemote = ref (`Local : [`Local|`SSH|`RSH|`SOCKET]) in
+ let varLocalRemote = ref (`Local : [`Local|`SSH|`SOCKET]) in
let localState() =
varLocalRemote := `Local;
hostE#misc#set_sensitive false;
@@ -812,30 +843,29 @@ let getSecondRoot () =
remoteState() in
ignore (localB#connect#clicked ~callback:localState);
ignore (sshB#connect#clicked ~callback:(fun () -> protoState(`SSH)));
- ignore (rshB#connect#clicked ~callback:(fun () -> protoState(`RSH)));
ignore (socketB#connect#clicked ~callback:(fun () -> protoState(`SOCKET)));
localState();
let getRoot() =
- let file = fileE#text in
- let user = userE#text in
- let host = hostE#text in
- let port = portE#text in
+ let file = Util.trimWhitespace fileE#text in
+ let user = Util.trimWhitespace userE#text in
+ let host = Util.trimWhitespace hostE#text in
+ let port = Util.trimWhitespace portE#text in
match !varLocalRemote with
`Local ->
Clroot.clroot2string(Clroot.ConnectLocal(Some file))
- | `SSH | `RSH ->
- Clroot.clroot2string(
- Clroot.ConnectByShell((if !varLocalRemote=`SSH then "ssh" else "rsh"),
+ | `SSH ->
+ Clroot.clroot2string(Clroot.fixHost(
+ Clroot.ConnectByShell("ssh",
host,
(if user="" then None else Some user),
(if port="" then None else Some port),
- Some file))
+ Some file)))
| `SOCKET ->
- Clroot.clroot2string(
+ Clroot.clroot2string(Clroot.fixHost(
(* FIX: report an error if the port entry is not well formed *)
Clroot.ConnectBySocket(host,
portE#text,
- Some file)) in
+ Some file))) in
let contCommand() =
try
let root = getRoot() in
@@ -846,13 +876,14 @@ let getSecondRoot () =
okBox ~parent:t ~title:"Error" ~typ:`ERROR ~message:"Please enter a port"
else okBox ~parent:t ~title:"Error" ~typ:`ERROR
~message:"The port you specify must be an integer"
- | _ ->
+ | Util.Transient s | Util.Fatal s | Invalid_argument s | Prefs.IllegalValue s ->
okBox ~parent:t ~title:"Error" ~typ:`ERROR
- ~message:"Something's wrong with the values you entered, try again" in
+ ~message:("Something's wrong with the values you entered, try again.\n" ^ s) in
let f3 = t#action_area in
- let quitButton =
- GButton.button ~stock:`QUIT ~packing:f3#add () in
- ignore (quitButton#connect#clicked ~callback:safeExit);
+ let cancelButton =
+ GButton.button ~stock:`CANCEL ~packing:f3#add () in
+ ignore (cancelButton#connect#clicked
+ ~callback:(fun () -> result := None; t#destroy ()));
let contButton =
GButton.button ~stock:`OK ~packing:f3#add () in
ignore (contButton#connect#clicked ~callback:contCommand);
@@ -864,13 +895,29 @@ let getSecondRoot () =
GMain.Main.main ();
!result
+let promptForRoots () =
+ match getFirstRoot () with
+ | None -> None
+ | Some r1 ->
+ begin match getSecondRoot () with
+ | None -> None
+ | Some r2 -> Some (r1, r2)
+ end
+
(* ------ *)
-let getPassword rootName msg =
+type 'a pwdDialog = {
+ labelAppend : string -> unit;
+ presentAndRun : unit -> unit;
+ closeInput : unit -> unit;
+}
+let passwordDialogs = ref []
+
+let createPasswordDialog passwordDialog rootName msg response =
let t =
GWindow.dialog ~parent:(toplevelWindow ())
~title:"Unison: SSH connection" ~position:`CENTER
- ~no_separator:true ~modal:true ~allow_grow:false ~border_width:6 () in
+ ~modal:true ~resizable:false ~border_width:6 () in
t#misc#grab_focus ();
t#vbox#set_spacing 12;
@@ -883,9 +930,9 @@ let getPassword rootName msg =
ignore (GMisc.image ~stock:`DIALOG_AUTHENTICATION ~icon_size:`DIALOG
~yalign:0. ~packing:h1#pack ());
let v1 = GPack.vbox ~spacing:12 ~packing:h1#pack () in
- ignore(GMisc.label ~markup:(header ^ "\n\n" ^
+ let msgLbl = (GMisc.label ~markup:(header ^ "\n\n" ^
escapeMarkup (Unicode.protect msg))
- ~selectable:true ~yalign:0. ~packing:v1#pack ());
+ ~selectable:true ~yalign:0. ~packing:v1#pack ()) in
let passwordE = GEdit.entry ~packing:v1#pack ~visibility:false () in
passwordE#misc#grab_focus ();
@@ -896,16 +943,50 @@ let getPassword rootName msg =
ignore (passwordE#connect#activate ~callback:(fun _ -> t#response `OK));
t#show();
- let res = t#run () in
- let pwd = passwordE#text in
- t#destroy ();
- gtk_sync true;
- begin match res with
- `DELETE_EVENT | `QUIT -> safeExit (); ""
- | `OK -> pwd
- end
-let termInteract = Some getPassword
+ let labelAppend msg =
+ msgLbl#set_label (msgLbl#label ^ escapeMarkup (Unicode.protect msg)) in
+ let presentAndRun () =
+ try t#present (); ignore (t#run ()) with Failure _ -> () in
+ let closeInput () =
+ passwordE#set_editable false; passwordE#set_visible false; passwordE#set_text "" in
+ passwordDialog := Some { labelAppend; presentAndRun; closeInput };
+
+ let callback res =
+ passwordDialog := None;
+ let pwd = passwordE#text in
+ let editable = passwordE#editable in
+ t#destroy ();
+ gtk_sync true;
+ match res with
+ | `DELETE_EVENT | `QUIT -> safeExit ()
+ | `OK -> if editable then response pwd
+ in
+ ignore (t#connect#response ~callback)
+
+let getPassword passwordDialog rootName msg response =
+ match !passwordDialog with
+ | Some { labelAppend; _ } -> labelAppend msg
+ | None -> createPasswordDialog passwordDialog rootName msg response
+
+let disablePassword passwordDialog () =
+ match !passwordDialog with
+ | Some { closeInput; _ } -> closeInput ()
+ | None -> ()
+
+let waitForPasswordWindowClosing () =
+ let present x =
+ match !x with
+ | Some { presentAndRun; _ } -> presentAndRun ()
+ | None -> ()
+ in
+ passwordDialogs :=
+ Safelist.filter (fun x -> present x; !x <> None) !passwordDialogs
+
+let termInteract rootName =
+ let d = ref None in
+ passwordDialogs := d :: !passwordDialogs;
+ { Terminal.userInput = getPassword d rootName; endInput = disablePassword d }
(* ------ *)
@@ -1048,6 +1129,7 @@ let createProfile parent =
assistant#set_modal true;
assistant#set_title "Profile Creation";
+ let empty s = s = "" in
let nonEmpty s = s <> "" in
(*
let integerRe =
@@ -1062,7 +1144,7 @@ let createProfile parent =
GMisc.label
~xpad:12 ~ypad:12
~text:"Welcome to the Unison Profile Creation Assistant.\n\n\
- Click \"Forward\" to begin."
+ Click \"Next\" to begin."
() in
ignore
(assistant#append_page
@@ -1145,7 +1227,7 @@ let createProfile parent =
GBin.alignment ~xscale:0. ~xalign:0.
~packing:(tbl#attach ~left:1 ~top:0) () in
GEdit.combo_box_text
- ~strings:["Local"; "Using SSH"; "Using RSH";
+ ~strings:["Local"; "Using SSH";
"Through a plain TCP connection"]
~active:0 ~packing:(al#add) ()
in
@@ -1154,7 +1236,7 @@ let createProfile parent =
~packing:(tbl#attach ~left:0 ~top:0 ~expand:`NONE) ());
let kind =
GtkReact.text_combo kindCombo
- >> fun i -> List.nth [`Local; `SSH; `RSH; `SOCKET] i
+ >> fun i -> List.nth [`Local; `SSH; `SOCKET] i
in
let isLocal = kind >> fun k -> k = `Local in
let isSSH = kind >> fun k -> k = `SSH in
@@ -1173,9 +1255,6 @@ let createProfile parent =
"This is the recommended way to synchronize \
with a remote machine. A\xc2\xa0remote instance of Unison is \
automatically started via SSH."
- | `RSH ->
- "Synchronization with a remote machine by starting \
- automatically a remote instance of Unison via RSH."
| `SOCKET ->
"Synchronization with a remote machine by connecting \
to an instance of Unison already listening \
@@ -1200,9 +1279,6 @@ let createProfile parent =
| `SSH ->
"There must be an SSH client installed on this machine, \
and Unison and an SSH server installed on the remote machine."
- | `RSH ->
- "There must be an RSH client installed on this machine, \
- and Unison and an RSH server installed on the remote machine."
| `SOCKET ->
"There must be a Unison server running on the remote machine, \
listening on the port that you specify here. \
@@ -1219,8 +1295,6 @@ let createProfile parent =
`Local -> ""
| `SSH -> "Please enter the host to connect to and a user name, \
if different from your user name on this machine."
- | `RSH -> "Please enter the host to connect to and a user name, \
- if different from your user name on this machine."
| `SOCKET -> "Please enter the host and port to connect to.");
let tbl =
let al = GBin.alignment ~packing:(vb#pack ~expand:false) () in
@@ -1288,10 +1362,14 @@ let createProfile parent =
let connectImmediately =
React.lift2 (&&) connectImmediately (isLocal >> not) in
*)
+ let isNotUnixPath s = String.length s > 0 && s.[0] <> '{' in
+ let isTCPsocket = React.lift2 (&&) isSocket (host >> isNotUnixPath) in
let pageComplete =
React.lift2 (||) isLocal
(React.lift2 (&&) (host >> nonEmpty)
- (React.lift2 (||) (isSocket >> not) (port >> isInteger)))
+ (React.lift2 (||)
+ (React.lift2 (&&) isTCPsocket (port >> isInteger))
+ (React.lift2 (&&) (isTCPsocket >> not) (port >> empty))))
in
ignore
(assistant#append_page
@@ -1493,17 +1571,52 @@ let createProfile parent =
then
assistant#set_current_page (p + 1)));
+ let conclusionOk = "You have now finished filling in the profile.\n\n\
+ Click \"Apply\" to create it."
+ and conclusionFail = "There was an error when preparing the profile.\n\n\
+ Click \"Back\" to review what you entered." in
let conclusion =
GMisc.label
~xpad:12 ~ypad:12
- ~text:"You have now finished filling in the profile.\n\n\
- Click \"Apply\" to create it."
+ ~text:conclusionOk
() in
- ignore
+ let conclusionp =
(assistant#append_page
~title:"Done" ~complete:true
~page_type:`CONFIRM
- conclusion#as_widget);
+ conclusion#as_widget) in
+
+ let makeRemoteRoot () =
+ let secondDir = Util.trimWhitespace (React.state secondDir) in
+ let host = Util.trimWhitespace (React.state host) in
+ let user = match React.state user with "" -> None | u -> Some (Util.trimWhitespace u) in
+ let secondRoot =
+ match React.state kind with
+ `Local -> Clroot.ConnectLocal (Some secondDir)
+ | `SSH -> Clroot.ConnectByShell
+ ("ssh", host, user, None, Some secondDir)
+ | `SOCKET -> Clroot.ConnectBySocket
+ (host, React.state port, Some secondDir)
+ in
+ try
+ let root = Clroot.clroot2string (Clroot.fixHost secondRoot) in
+ ignore (Clroot.parseRoot root);
+ Some root
+ with
+ | Util.Transient s | Util.Fatal s | Invalid_argument s | Prefs.IllegalValue s ->
+ begin
+ okBox ~parent ~title:"Error" ~typ:`ERROR
+ ~message:("There was a problem with the remote root "
+ ^ "data you entered.\n\n" ^ s);
+ None
+ end
+ in
+ ignore (assistant#connect#prepare ~callback:(fun () ->
+ if assistant#current_page = conclusionp then
+ let ok = (React.state kind = `Local) || (makeRemoteRoot () <> None) in
+ let () = setPageComplete conclusion ok in
+ if ok then conclusion#set_text conclusionOk
+ else conclusion#set_text conclusionFail));
let profileName = ref None in
let saveProfile () =
@@ -1512,24 +1625,20 @@ let createProfile parent =
let ch =
System.open_out_gen [Open_wronly; Open_creat; Open_excl] 0o600 filename
in
+ let close_on_error f =
+ try f () with e -> close_out_noerr ch; raise e
+ in
+ close_on_error (fun () ->
Printf.fprintf ch "# Unison preferences\n";
let label = React.state label in
if label <> "" then Printf.fprintf ch "label = %s\n" label;
Printf.fprintf ch "root = %s\n" (React.state firstDir);
- let secondDir = React.state secondDir in
- let host = React.state host in
- let user = match React.state user with "" -> None | u -> Some u in
let secondRoot =
- match React.state kind with
- `Local -> Clroot.ConnectLocal (Some secondDir)
- | `SSH -> Clroot.ConnectByShell
- ("ssh", host, user, None, Some secondDir)
- | `RSH -> Clroot.ConnectByShell
- ("rsh", host, user, None, Some secondDir)
- | `SOCKET -> Clroot.ConnectBySocket
- (host, React.state port, Some secondDir)
+ match makeRemoteRoot () with
+ | None -> assert false (* We should never reach here due to validation above *)
+ | Some s -> s
in
- Printf.fprintf ch "root = %s\n" (Clroot.clroot2string secondRoot);
+ Printf.fprintf ch "root = %s\n" secondRoot;
if React.state compress && React.state kind = `SSH then
Printf.fprintf ch "sshargs = -C\n";
(*
@@ -1539,7 +1648,7 @@ let createProfile parent =
Printf.fprintf ch "unicode = true\n";
*)
if React.state fat then Printf.fprintf ch "fat = true\n";
- close_out ch;
+ close_out ch);
profileName := Some (React.state name)
with Sys_error _ as e ->
okBox ~parent:assistant ~typ:`ERROR ~title:"Could not save profile"
@@ -1579,7 +1688,7 @@ let defaultValue t =
let editPreference parent nm ty vl =
let t =
GWindow.dialog ~parent ~border_width:12
- ~no_separator:true ~title:"Edit the Preference"
+ ~title:"Edit the Preference"
~modal:true () in
let vb = t#vbox in
vb#set_spacing 6;
@@ -1602,7 +1711,7 @@ let editPreference parent nm ty vl =
~packing:(tbl#attach ~left:0 ~top:2 ~expand:`NONE) ());
ignore (GMisc.label ~text:(Unicode.protect nm) ~xalign:0. ~selectable:true ()
~packing:(tbl#attach ~left:1 ~top:0 ~expand:`X));
- let (doc, _, _) = Prefs.documentation nm in
+ let (doc, _) = Prefs.documentation nm in
ignore (GMisc.label ~text:doc ~xalign:0. ~selectable:true ()
~packing:(tbl#attach ~left:1 ~top:1 ~expand:`X));
ignore (GMisc.label ~text:(nameOfType ty) ~xalign:0. ~selectable:true ()
@@ -1870,6 +1979,10 @@ let documentPreference ~compact ~packing =
in
GText.view ~editable:false ~packing:sw#add ~wrap_mode:`WORD ()
in
+ let () = longDescr#set_left_margin 4
+ and () = longDescr#set_right_margin 4
+ and () = longDescr#set_top_margin 1
+ and () = longDescr#set_bottom_margin 2 in
let (>>>) x f = f x in
let newlineRe = Str.regexp "\n *" in
let styleRe = Str.regexp "{\\\\\\([a-z]+\\) \\([^{}]*\\)}" in
@@ -1914,14 +2027,14 @@ let documentPreference ~compact ~packing =
("tt", create [`FONT_DESC (Lazy.force fontMonospace)])]
in
fun nm ->
- let (short, long, _) =
+ let (short, long) =
match nm with
Some nm ->
tbl#misc#set_sensitive true;
Prefs.documentation nm
| _ ->
tbl#misc#set_sensitive false;
- ("", "", false)
+ ("", "")
in
shortDescr#set_text (String.capitalize_ascii short);
insertMarkup tags longDescr (formatDoc long)
@@ -1930,13 +2043,14 @@ let documentPreference ~compact ~packing =
let addPreference parent =
let t =
GWindow.dialog ~parent ~border_width:12
- ~no_separator:true ~title:"Add a Preference"
+ ~title:"Add a Preference"
~modal:true () in
+ t#set_default_height 575;
let vb = t#vbox in
(* vb#set_spacing 18;*)
let paned = GPack.paned `VERTICAL ~packing:vb#add () in
- let lvb = GPack.vbox ~spacing:6 ~packing:paned#pack1 () in
+ let lvb = GPack.vbox ~spacing:6 ~packing:(paned#pack1 ~resize:true) () in
let preferenceLabel =
GMisc.label
~text:"_Preferences:" ~use_underline:true
@@ -1944,8 +2058,8 @@ let addPreference parent =
in
let cols = new GTree.column_list in
let c_name = cols#add Gobject.Data.string in
- let basic_store = GTree.list_store cols in
- let full_store = GTree.list_store cols in
+ let c_font = cols#add Gobject.Data.string in
+ let store = GTree.tree_store cols in
let lst =
let sw =
GBin.scrolled_window ~packing:(lvb#pack ~expand:true)
@@ -1953,54 +2067,98 @@ let addPreference parent =
~hpolicy:`AUTOMATIC ~vpolicy:`AUTOMATIC () in
GTree.view ~headers_visible:false ~packing:sw#add () in
preferenceLabel#set_mnemonic_widget (Some (lst :> GObj.widget));
- ignore (lst#append_column
- (GTree.view_column
- ~renderer:(GTree.cell_renderer_text [], ["text", c_name]) ()));
- let hiddenPrefs =
- ["auto"; "doc"; "silent"; "terse"; "testserver"; "version"] in
+
+ let cell_r = GTree.cell_renderer_text [] in
+ let view_col = (GTree.view_column ~renderer:(cell_r, ["text", c_name]) ()) in
+ view_col#add_attribute cell_r "font" c_font;
+ ignore (lst#append_column view_col);
+ (*let hiddenPrefs =
+ ["auto"; "silent"; "terse"] in*)
let shownPrefs =
["label"; "key"] in
- let insert (store : #GTree.list_store) all =
+
+ let createGroup n =
+ let row = store#append () in
+ store#set ~row ~column:c_name n;
+ store#set ~row ~column:c_font "bold";
+ row
+ in
+ let createTopic parent n =
+ let row = store#append ~parent () in
+ store#set ~row ~column:c_name n;
+ store#set ~row ~column:c_font "italic";
+ row
+ in
+ let createTopics parent g =
+ Safelist.map (fun t ->
+ let topic = g t in
+ (topic, (createTopic parent (Prefs.topic_title topic))))
+ in
+
+ let topicsInOrder = [ `Sync; `Syncprocess; `Syncprocess_CLI; `CLI; `GUI; `Remote; `Archive ] in
+
+ let basic = createGroup "1 — Basic preferences" in
+ let l = createTopics basic (fun t -> `Basic t) (`General :: topicsInOrder) in
+
+ let adv = createGroup "2 — Advanced preferences" in
+ let l = l @ createTopics adv (fun t -> `Advanced t) (topicsInOrder @ [`General]) in
+
+ let l = (`Expert, createGroup "3 — Expert preferences") :: l in
+
+ let parents = l in
+ let purgeParents () =
+ Safelist.iter (fun (_, row) ->
+ if not (store#iter_has_child row) then begin
+ let parent = store#iter_parent row in
+ ignore (store#remove row);
+ match parent with
+ | None -> ()
+ | Some parent -> if not (store#iter_has_child parent) then
+ ignore (store#remove parent)
+ end
+ ) parents
+ in
+ let categoryParent nm =
+ match Prefs.category nm with
+ | None -> None
+ | Some _ when List.mem nm shownPrefs -> Some basic
+ | Some cat -> begin
+ try Some (Safelist.assoc cat parents) with
+ | Not_found -> None
+ end
+ in
+ let isParent r = store#iter_has_child r in
+
+ let () =
List.iter
(fun nm ->
- if
- all || List.mem nm shownPrefs ||
- (let (_, _, basic) = Prefs.documentation nm in basic &&
- not (List.mem nm hiddenPrefs))
- then begin
- let row = store#append () in
- store#set ~row ~column:c_name nm
- end)
- (Prefs.list ())
+ let row =
+ match categoryParent nm with
+ | None -> store#append ()
+ | Some parent -> store#append ~parent ()
+ in
+ store#set ~row ~column:c_name nm
+ )
+ (Prefs.list false);
in
- insert basic_store false;
- insert full_store true;
+ purgeParents ();
- let showAll =
- GtkReact.toggle_button
- (GButton.check_button ~label:"_Show all preferences"
- ~use_mnemonic:true ~active:false ~packing:(lvb#pack ~expand:false) ())
- in
- showAll >|
- (fun b ->
- lst#set_model
- (Some (if b then full_store else basic_store :> GTree.model)));
+ lst#set_model (Some store#coerce);
+ let getSelectedPref rf =
+ let row = rf#iter in
+ if isParent row then
+ None
+ else
+ Some (store#get ~row ~column:c_name)
+ in
let selection = GtkReact.tree_view_selection lst in
let updateDoc = documentPreference ~compact:true ~packing:paned#pack2 in
- selection >|
- (fun l ->
- let nm =
- match l with
- [rf] ->
- let row = rf#iter in
- let store =
- if React.state showAll then full_store else basic_store in
- Some (store#get ~row ~column:c_name)
- | _ ->
- None
- in
- updateDoc nm);
+ let prefSelection = selection >> (function
+ | [rf] -> getSelectedPref rf
+ | _ -> None)
+ in
+ prefSelection >| updateDoc;
let cancelCommand () = t#destroy () in
let cancelButton =
@@ -2012,7 +2170,7 @@ let addPreference parent =
let addButton =
GButton.button ~stock:`ADD ~packing:t#action_area#add () in
ignore (addButton#connect#clicked ~callback:addCommand);
- GtkReact.set_sensitive addButton (selection >> fun l -> l <> []);
+ GtkReact.set_sensitive addButton (prefSelection >> fun nm -> nm <> None);
ignore (lst#connect#row_activated ~callback:(fun _ _ -> addCommand ()));
addButton#grab_default ();
@@ -2021,18 +2179,15 @@ let addPreference parent =
GMain.Main.main ();
if not !ok then None else
match React.state selection with
- [rf] ->
- let row = rf#iter in
- let store =
- if React.state showAll then full_store else basic_store in
- Some (store#get ~row ~column:c_name)
+ | [rf] ->
+ getSelectedPref rf
| _ ->
None
let editProfile parent name =
let t =
GWindow.dialog ~parent ~border_width:12
- ~no_separator:true ~title:(Format.sprintf "%s - Profile Editor" name)
+ ~title:(Format.sprintf "%s - Profile Editor" name)
~modal:true () in
let vb = t#vbox in
(* t#vbox#set_spacing 18;*)
@@ -2201,7 +2356,7 @@ let editProfile parent name =
in
let (>>>) x f = f x in
Prefs.readAFile name
- >>> List.map (fun (_, _, nm, v) -> Prefs.canonicalName nm, v)
+ >>> List.map (fun (_, nm, v) -> Prefs.canonicalName nm, v)
>>> List.stable_sort (fun (nm, _) (nm', _) -> compare nm nm')
>>> group
>>> List.iter
@@ -2225,6 +2380,10 @@ let editProfile parent name =
System.open_out_gen [Open_wronly; Open_creat; Open_trunc] 0o600
filename
in
+ let close_on_error f =
+ try f () with e -> close_out_noerr ch; raise e
+ in
+ close_on_error (fun () ->
(*XXX Should trim whitespaces and check for '\n' at some point *)
Printf.fprintf ch "# Unison preferences\n";
lst_store#foreach
@@ -2232,7 +2391,7 @@ let editProfile parent name =
let (nm, _, vl) = lst_store#get ~row ~column:c_ml in
List.iter (fun v -> Printf.fprintf ch "%s = %s\n" nm v) vl;
false);
- close_out ch;
+ close_out ch);
setModified false
with Sys_error _ as e ->
okBox ~parent:t ~typ:`ERROR ~title:"Could not save profile"
@@ -2277,15 +2436,24 @@ TODO:
(* ------ *)
+let documentationFn = ref (fun ~parent _ -> ())
+
let getProfile quit =
let ok = ref false in
+ let parent = toplevelWindow () in
+ (* Make sure that a potentially open password window from a (failed) previous
+ session is not hidden underneath this window. *)
+ waitForPasswordWindowClosing ();
(* Build the dialog *)
let t =
- GWindow.dialog ~parent:(toplevelWindow ()) ~border_width:12
- ~no_separator:true ~title:"Profile Selection"
- ~modal:true () in
+ GWindow.dialog ~parent ~border_width:12
+ ~title:"Profile Selection"
+ ~modal:false () in
t#set_default_width 550;
+ (* Simulate modal dialog (allowing to open other windows, such as help) *)
+ parent#set_sensitive false;
+ ignore (t#connect#destroy ~callback:(fun () -> parent#set_sensitive true));
let cancelCommand _ = t#destroy () in
let cancelButton =
@@ -2351,10 +2519,10 @@ let getProfile quit =
~packing:(tbl#attach ~left:0 ~top:1 ~expand:`NONE) ());
let root1 =
GMisc.label ~packing:(tbl#attach ~left:1 ~top:0 ~expand:`X)
- ~xalign:0. ~selectable:true () in
+ ~xalign:0. ~selectable:true ~ellipsize:`MIDDLE () in
let root2 =
GMisc.label ~packing:(tbl#attach ~left:1 ~top:1 ~expand:`X)
- ~xalign:0. ~selectable:true () in
+ ~xalign:0. ~selectable:true ~ellipsize:`MIDDLE () in
let fillLst default =
Uicommon.scanProfiles();
@@ -2397,9 +2565,10 @@ let getProfile quit =
tbl#misc#set_sensitive false);
GtkReact.set_sensitive okButton hasSel;
+ let box = GPack.vbox ~packing:(hb#pack ~expand:false) () in
let vb =
GPack.button_box
- `VERTICAL ~layout:`START ~spacing:6 ~packing:(hb#pack ~expand:false) ()
+ `VERTICAL ~layout:`START ~spacing:6 ~packing:(box#pack ~expand:false) ()
in
let addButton =
GButton.button ~stock:`ADD ~packing:(vb#pack ~expand:false) () in
@@ -2439,6 +2608,13 @@ let getProfile quit =
GtkReact.set_sensitive deleteButton hasSel;
List.iter (fun b -> b#set_xalign 0.) [addButton; editButton; deleteButton];
+ ignore (GPack.vbox ~packing:(box#pack ~expand:true) ());
+ let helpButton =
+ GButton.button ~stock:`HELP ~packing:(box#pack ~expand:false) () in
+ helpButton#set_xalign 0.;
+ ignore (helpButton#connect#clicked
+ ~callback:(fun () -> !documentationFn ~parent:t ""));
+
ignore (lst#connect#row_activated ~callback:(fun _ _ -> okCommand ()));
fillLst None;
lst#misc#grab_focus ();
@@ -2451,9 +2627,14 @@ let getProfile quit =
(* ------ *)
-let documentation sect =
+let get_size_chars obj ?desc ?lang ~height ~width () =
+ let metrics = obj#misc#pango_context#get_metrics ?desc ?lang () in
+ (width * GPango.to_pixels metrics#approx_digit_width,
+ height * GPango.to_pixels (metrics#ascent+metrics#descent))
+
+let documentation ~parent sect =
let title = "Documentation" in
- let t = GWindow.dialog ~title () in
+ let t = GWindow.dialog ~title ~parent () in
let t_dismiss =
GButton.button ~stock:`CLOSE ~packing:t#action_area#add () in
t_dismiss#grab_default ();
@@ -2461,48 +2642,53 @@ let documentation sect =
ignore (t_dismiss#connect#clicked ~callback:dismiss);
ignore (t#event#connect#delete ~callback:(fun _ -> dismiss (); true));
- let (name, docstr) = Safelist.assoc sect Strings.docs in
- let hb = GPack.hbox ~packing:(t#vbox#pack ~expand:false ~padding:2) () in
- let optionmenu =
- GMenu.option_menu ~packing:(hb#pack ~expand:true ~fill:false) () in
+ let nb = GPack.notebook ~show_tabs:true ~tab_pos:`LEFT ~border_width:5
+ ~packing:(t#vbox#pack ~expand:true) () in
- let t_text =
- new scrolled_text ~editable:false
- ~width:80 ~height:20 ~packing:t#vbox#add ()
+ let sect_idx = ref 0 in
+ let add_nb_page label active w =
+ let i = nb#append_page ~tab_label:label#coerce w in
+ if active then sect_idx := i
in
- t_text#insert docstr;
- let sect_idx = ref 0 in
- let idx = ref 0 in
- let menu = GMenu.menu () in
+ let lw = ref 1 in
let addDocSection (shortname, (name, docstr)) =
- if shortname <> "" && name <> "" then begin
- if shortname = sect then sect_idx := !idx;
- incr idx;
- let item = GMenu.menu_item ~label:name ~packing:menu#append () in
- ignore
- (item#connect#activate ~callback:(fun () -> t_text#insert docstr))
- end
+ if shortname = "" || name = "" then () else
+ let () = lw := max !lw (String.length name) in
+ let label = GMisc.label ~markup:("<b>" ^ name ^ "</b>")
+ ~xalign:1. ~justify:`LEFT ~ellipsize:`NONE () in
+ let box = GBin.frame ~border_width:8
+ ~packing:(add_nb_page label (shortname = sect)) () in
+ let text = new scrolled_text ~editable:false ~wrap_mode:`NONE
+ ~packing:box#add () in
+ text#insert docstr
in
Safelist.iter addDocSection Strings.docs;
- optionmenu#set_menu menu;
- optionmenu#set_history !sect_idx;
+
+ nb#goto_page !sect_idx;
+
+ let (width, height) = get_size_chars t ~width:(80 + !lw) ~height:25 () in
+ t#set_default_size ~width ~height;
t#show ()
+let () = documentationFn := documentation
(* ------ *)
let messageBox ~title ?(action = fun t -> t#destroy) message =
let utitle = transcode title in
- let t = GWindow.dialog ~title:utitle ~position:`CENTER () in
+ let t = GWindow.dialog ~title:utitle ~parent:(toplevelWindow ())
+ ~position:`CENTER () in
let t_dismiss = GButton.button ~stock:`CLOSE ~packing:t#action_area#add () in
t_dismiss#grab_default ();
ignore (t_dismiss#connect#clicked ~callback:(action t));
let t_text =
- new scrolled_text ~editable:false
- ~width:80 ~height:20 ~packing:t#vbox#add ()
+ new scrolled_text ~editable:false ~wrap_mode:`NONE
+ ~packing:(t#vbox#pack ~expand:true) ()
in
t_text#insert message;
+ let (width, height) = get_size_chars t_text ~width:82 ~height:20 () in
+ t#set_default_size ~width ~height;
ignore (t#event#connect#delete ~callback:(fun _ -> action t (); true));
t#show ()
@@ -2513,8 +2699,8 @@ let messageBox ~title ?(action = fun t -> t#destroy) message =
let twoBoxAdvanced
~parent ~title ~message ~longtext ~advLabel ~astock ~bstock =
let t =
- GWindow.dialog ~parent ~border_width:6 ~modal:true ~no_separator:true
- ~allow_grow:false () in
+ GWindow.dialog ~parent ~border_width:6 ~modal:true
+ ~resizable:false () in
t#vbox#set_spacing 12;
let h1 = GPack.hbox ~border_width:6 ~spacing:12 ~packing:t#vbox#pack () in
ignore (GMisc.image ~stock:`DIALOG_QUESTION ~icon_size:`DIALOG
@@ -2546,8 +2732,8 @@ let twoBoxAdvanced
let summaryBox ~parent ~title ~message ~f =
let t =
- GWindow.dialog ~parent ~border_width:6 ~modal:true ~no_separator:true
- ~allow_grow:false ~focus_on_map:false () in
+ GWindow.dialog ~parent ~border_width:6 ~modal:true
+ ~resizable:true ~focus_on_map:true () in
t#vbox#set_spacing 12;
let h1 = GPack.hbox ~border_width:6 ~spacing:12 ~packing:t#vbox#pack () in
ignore (GMisc.image ~stock:`DIALOG_INFO ~icon_size:`DIALOG
@@ -2555,12 +2741,15 @@ let summaryBox ~parent ~title ~message ~f =
let v1 = GPack.vbox ~spacing:12 ~packing:h1#pack () in
ignore (GMisc.label
~markup:(primaryText title ^ "\n\n" ^ escapeMarkup message)
- ~selectable:true ~xalign:0. ~yalign:0. ~packing:v1#add ());
- let exp = GBin.expander ~spacing:12 ~label:"Show details" ~packing:v1#add () in
+ ~selectable:true ~xalign:0. ~yalign:0. ~packing:(v1#pack ~expand:false) ());
+ let exp = GBin.expander ~spacing:12 ~label:"Show details"
+ ~packing:(v1#pack ~expand:true) () in
let t_text =
- new scrolled_text ~editable:false ~shadow_type:`IN
- ~width:60 ~height:10 ~packing:exp#add ()
- in
+ new scrolled_text ~editable:false ~shadow_type:`IN ~packing:exp#add () in
+ t_text#set_expand true;
+ let (width, height) = get_size_chars t_text ~width:60 ~height:10 () in
+ t_text#set_width_request width;
+ t_text#set_height_request height;
f (t_text#text);
t#add_button_stock `OK `OK;
t#set_default_response `OK;
@@ -2578,6 +2767,15 @@ let displayWaitMessage () =
make_busy (toplevelWindow ());
Trace.status (Uicommon.contactingServerMsg ())
+let prepDebug () =
+ if Sys.os_type = "Win32" then
+ (* As a side-effect, this allocates a console if the process doesn't
+ have one already. This call is here only for the side-effect,
+ because debugging output is produced on stderr and the GUI will
+ crash if there is no stderr. *)
+ try ignore (System.terminalStateFunctions ())
+ with Unix.Unix_error _ -> ()
+
(* ------ *)
type status = NoStatus | Done | Failed
@@ -2590,7 +2788,7 @@ let createToplevelWindow () =
setToplevelWindow toplevelWindow;
(* There is already a default icon under Windows, and transparent
icons are not supported by all version of Windows *)
- if Util.osType <> `Win32 then toplevelWindow#set_icon (Some icon);
+ if Util.osType <> `Win32 then toplevelWindow#set_icon (Some (Lazy.force icon));
let toplevelVBox = GPack.vbox ~packing:toplevelWindow#add () in
(*******************************************************************
@@ -2606,6 +2804,7 @@ let createToplevelWindow () =
let grDiff = ref [] in
let grGo = ref [] in
let grRescan = ref [] in
+ let grStop = ref [] in
let grDetail = ref [] in
let grAdd gr w = gr := w#misc::!gr in
let grSet gr st = Safelist.iter (fun x -> x#set_sensitive st) !gr in
@@ -2614,6 +2813,7 @@ let createToplevelWindow () =
grSet grDiff false;
grSet grGo false;
grSet grRescan false;
+ grSet grStop false;
grSet grDetail false
in
@@ -2655,9 +2855,11 @@ let createToplevelWindow () =
| "default", _ -> label
| _ -> Format.sprintf "%s (%s)" p label
in
+ let roots = String.concat " ↔ " (Globals.rawRoots ()) in
+ let roots = if roots = "" then "" else " | " ^ roots in
toplevelWindow#set_title
(if s = "" then myNameCapitalized else
- Format.sprintf "%s [%s]" myNameCapitalized s);
+ Format.sprintf "%s [%s]%s" myNameCapitalized s roots);
let s = if s="" then "No profile" else "Profile: " ^ s in
profileLabel#set_text (transcode s)
in
@@ -2676,13 +2878,12 @@ let createToplevelWindow () =
Action bar
*********************************************************************)
let actionBar =
- let hb = GBin.handle_box ~packing:(toplevelVBox#pack ~expand:false) () in
GButton.toolbar ~style:`BOTH
(* 2003-0519 (stse): how to set space size in gtk 2.0? *)
(* Answer from Jacques Garrigue: this can only be done in
the user's.gtkrc, not programmatically *)
- ~orientation:`HORIZONTAL ~tooltips:true (* ~space_size:10 *)
- ~packing:(hb#add) () in
+ ~orientation:`HORIZONTAL (* ~space_size:10 *)
+ ~packing:(toplevelVBox#pack ~expand:false) () in
(*********************************************************************
Create the main window
@@ -2691,13 +2892,6 @@ let createToplevelWindow () =
GBin.scrolled_window ~packing:(toplevelVBox#pack ~expand:true)
~hpolicy:`AUTOMATIC ~vpolicy:`AUTOMATIC ()
in
- let sizeMainWindow () =
- let ctx = mainWindowSW#misc#pango_context in
- let metrics = ctx#get_metrics () in
- let h = GPango.to_pixels (metrics#ascent+metrics#descent) in
- toplevelWindow#set_default_height
- ((h + 3) * (Prefs.read Uicommon.mainWindowHeight + 1) + 200)
- in
let cols = new GTree.column_list in
let c_replica1 = cols#add Gobject.Data.string in
let c_action = cols#add Gobject.Data.gobject in
@@ -2748,7 +2942,6 @@ let createToplevelWindow () =
" " ^ Unicode.protect (String.sub s 15 12) ^ " "; " Status ";
" Path" |];
in
- sizeMainWindow ();
(* See above for comment about tree path index and [theState] array index
equivalence. *)
@@ -2823,17 +3016,20 @@ let createToplevelWindow () =
let detailsWindowSW =
GBin.scrolled_window ~packing:(toplevelVBox#pack ~expand:false)
- ~shadow_type:`IN ~hpolicy:`NEVER ~vpolicy:`AUTOMATIC ()
+ ~shadow_type:`IN ~hpolicy:`AUTOMATIC ~vpolicy:`AUTOMATIC ()
in
let detailsWindow =
GText.view ~editable:false ~packing:detailsWindowSW#add ()
in
+ let (width, height) = get_size_chars detailsWindow ~height:4 ~width:112 () in
+ let () = detailsWindowSW#set_height_request height in
+ (* width is set in [sizeMainWindow] *)
+
let detailsWindowPath = detailsWindow#buffer#create_tag [] in
let detailsWindowInfo =
detailsWindow#buffer#create_tag [`FONT_DESC (Lazy.force fontMonospace)] in
let detailsWindowError =
detailsWindow#buffer#create_tag [`WRAP_MODE `WORD] in
- detailsWindow#misc#set_size_chars ~height:3 ~width:112 ();
detailsWindow#misc#set_can_focus false;
let updateButtons () =
@@ -2932,12 +3128,16 @@ let createToplevelWindow () =
let progressBar =
GRange.progress_bar ~packing:(statusHBox#pack ~expand:false) () in
- progressBar#misc#set_size_chars ~height:1 ~width:28 ();
+ progressBar#misc#modify_font detailsWindow#misc#pango_context#font_description;
+ let (w, _) = get_size_chars progressBar ~width:28 ~height:1 () in
+ progressBar#set_width_request w;
+ progressBar#set_show_text true;
progressBar#set_pulse_step 0.02;
let progressBarPulse = ref false in
let statusWindow =
GMisc.statusbar ~packing:(statusHBox#pack ~expand:true) () in
+ statusWindow#set_margin 0;
let statusContext = statusWindow#new_context ~name:"status" in
ignore (statusContext#push "");
@@ -2956,6 +3156,65 @@ let createToplevelWindow () =
Trace.statusFormatter := formatStatus;
Trace.sendLogMsgsToStderr := false;
+
+ (* Window is created before initPrefs but we don't want the size to
+ jump around after window has been shown (which is inevitable when
+ height is specified in a profile). Scan the command line to check
+ for height preference. *)
+ begin try
+ let prefName = List.hd (Prefs.name Uicommon.mainWindowHeight) in
+ let clHeight = List.hd (Util.StringMap.find prefName (Prefs.scanCmdLine "")) in
+ Prefs.set Uicommon.mainWindowHeight (int_of_string clHeight)
+ with Not_found | Invalid_argument _ | Util.Fatal _ -> () end;
+
+ let calcWinSize () =
+ (* (Poor) approximation of row height. It is impossible to get real
+ GTK TreeView row height (and it depends on theme). *)
+ let row_height = (List.hd mainWindow#all_children)#misc#allocation.height in
+ let height =
+ if row_height < 2 then (* Oops, sizes clearly not allocated yet *)
+ let metrics = mainWindowSW#misc#pango_context#get_metrics () in
+ let h = GPango.to_pixels (metrics#ascent + metrics#descent) in
+ (h + 8) * (8 + (Prefs.read Uicommon.mainWindowHeight)) (* rought default *)
+ else
+ topHBox#misc#allocation.height
+ + actionBar#misc#allocation.height
+ + 2 * mainWindow#border_width (* top and bottom *)
+ + row_height (* column headers *)
+ + (row_height - 3) * (Prefs.read Uicommon.mainWindowHeight)
+ + detailsWindowSW#misc#allocation.height
+ + statusHBox#misc#allocation.height
+ in
+ let height = min height (Gdk.Screen.height ~screen:toplevelWindow#screen ()) in
+ let width =
+ let metrics = mainWindowSW#misc#pango_context#get_metrics () in
+ let w = GPango.to_pixels metrics#approx_digit_width in
+ max (w * 112) 860
+ in
+ let width = min width (Gdk.Screen.width ~screen:toplevelWindow#screen ()) in
+ (height, width)
+ in
+
+ let prevHeightPref = ref 0 in
+
+ let sizeMainWindow () =
+ (* Only update height if the preference changed, otherwise risk undoing
+ user's manual height adjustments. Also assume no change if the
+ preference is at the default value. *)
+ let prefHeight = Prefs.read Uicommon.mainWindowHeight in
+ if !prevHeightPref <> prefHeight &&
+ (!prevHeightPref = 0 ||
+ prefHeight <> Prefs.readDefault Uicommon.mainWindowHeight) then begin
+ let (height, _) = calcWinSize ()
+ and width = toplevelWindow#misc#allocation.width in
+ toplevelWindow#resize ~height ~width
+ end;
+ prevHeightPref := prefHeight
+ in
+ let (height, width) = calcWinSize () in
+ toplevelWindow#set_default_size ~height ~width;
+ ignore (toplevelWindow#misc#connect#show ~callback:sizeMainWindow);
+
(*********************************************************************
Functions used to print in the main window
*********************************************************************)
@@ -3099,10 +3358,11 @@ let createToplevelWindow () =
displayRow row i r1 r2 action status path;
done;
mainWindow#set_model (Some mainWindowModel#coerce);
- match savedCurrent with
+ begin match savedCurrent with
| [] -> selectSomethingIfPossible ()
| [x] -> select x true
- | _ -> Safelist.iter (fun p -> mainWindow#selection#select_path p) savedCurrent;
+ | _ -> Safelist.iter (fun p -> mainWindow#selection#select_path p) savedCurrent
+ end;
progressBar#set_text ""; progressBar#set_fraction 0.;
updateDetails (); (* Do we need this line? *)
@@ -3139,11 +3399,9 @@ let createToplevelWindow () =
let totalBytesToTransfer = ref Uutil.Filesize.zero in
let totalBytesTransferred = ref Uutil.Filesize.zero in
- let t0 = ref 0. in
let t1 = ref 0. in
let lastFrac = ref 0. in
- let oldWritten = ref 0. in
- let writeRate = ref 0. in
+ let sta = ref (Uicommon.Stats.init (Uutil.Filesize.zero)) in
let displayGlobalProgress v =
if v = 0. || abs_float (v -. !lastFrac) > 1. then begin
lastFrac := v;
@@ -3153,21 +3411,15 @@ let createToplevelWindow () =
progressBar#set_text " "
else begin
let t = Unix.gettimeofday () in
+ Uicommon.Stats.update !sta t !totalBytesTransferred;
let delta = t -. !t1 in
if delta >= 0.5 then begin
t1 := t;
let remTime =
if v >= 100. then "00:00 remaining" else
- let t = truncate ((!t1 -. !t0) *. (100. -. v) /. v +. 0.5) in
- Format.sprintf "%02d:%02d remaining" (t / 60) (t mod 60)
+ (Uicommon.Stats.eta !sta "--:--") ^ " remaining"
in
- let written = !clientWritten +. !serverWritten in
- let b = 0.64 ** delta in
- writeRate :=
- b *. !writeRate +.
- (1. -. b) *. (written -. !oldWritten) /. delta;
- oldWritten := written;
- let rate = !writeRate (*!emitRate2 +. !receiveRate2*) in
+ let rate = Uicommon.Stats.avgRate1 !sta in
let txt =
if rate > 99. then
Format.sprintf "%s (%s)" remTime (rate2str rate)
@@ -3198,8 +3450,8 @@ let createToplevelWindow () =
root2IsLocal := fst root2 = Local;
totalBytesToTransfer := b;
totalBytesTransferred := Uutil.Filesize.zero;
- t0 := Unix.gettimeofday (); t1 := !t0;
- writeRate := 0.; oldWritten := !clientWritten +. !serverWritten;
+ t1 := Unix.gettimeofday ();
+ sta := Uicommon.Stats.init !totalBytesToTransfer;
displayGlobalProgress 0.
in
@@ -3276,7 +3528,10 @@ let createToplevelWindow () =
let clearMainWindow () =
grDisactivateAll ();
make_busy toplevelWindow;
+ mainWindow#set_model None;
mainWindowModel#clear ();
+ mainWindow#set_model (Some mainWindowModel#coerce);
+ theState := [||];
detailsWindow#buffer#set_text ""
in
@@ -3288,7 +3543,7 @@ let createToplevelWindow () =
let findUpdates () =
let t = Trace.startTimer "Checking for updates" in
Trace.status "Looking for changes";
- let updates = Update.findUpdates ~wantWatcher:() !unsynchronizedPaths in
+ let updates = Update.findUpdates ~wantWatcher:true !unsynchronizedPaths in
Trace.showTimer t;
updates in
let reconcile updates =
@@ -3337,13 +3592,14 @@ let createToplevelWindow () =
Help menu
*********************************************************************)
let addDocSection (shortname, (name, docstr)) =
+ let parent = toplevelWindow in
if shortname = "about" then
ignore (helpMenu#add_image_item
- ~stock:`ABOUT ~callback:(fun () -> documentation shortname)
+ ~stock:`ABOUT ~callback:(fun () -> documentation ~parent shortname)
name)
else if shortname <> "" && name <> "" then
ignore (helpMenu#add_item
- ~callback:(fun () -> documentation shortname)
+ ~callback:(fun () -> documentation ~parent shortname)
name) in
Safelist.iter addDocSection Strings.docs;
@@ -3418,7 +3674,8 @@ let createToplevelWindow () =
make_busy toplevelWindow;
Trace.status "Propagating changes";
- Transport.logStart ();
+ Uicommon.transportStart ();
+ grSet grStop true;
let totalLength =
Array.fold_left
(fun l si ->
@@ -3432,78 +3689,54 @@ let createToplevelWindow () =
Uutil.Filesize.zero !theState in
initGlobalProgress totalLength;
let t = Trace.startTimer "Propagating changes" in
- let im = Array.length !theState in
- let rec loop i actions pRiThisRound =
- if i < im then begin
- let theSI = !theState.(i) in
- let textDetailed = ref None in
- let action =
- match theSI.whatHappened with
- None ->
- if not (pRiThisRound theSI.ri) then
- return ()
- else
- catch (fun () ->
- Transport.transportItem
- theSI.ri (Uutil.File.ofLine i)
- (fun title text ->
- textDetailed := (Some text);
- if Prefs.read Uicommon.confirmmerge then
- twoBoxAdvanced
- ~parent:toplevelWindow
- ~title:title
- ~message:("Do you want to commit the changes to"
- ^ " the replicas ?")
- ~longtext:text
- ~advLabel:"View details..."
- ~astock:`YES
- ~bstock:`NO
- else
- true)
- >>= (fun () ->
- return Util.Succeeded))
- (fun e ->
- match e with
- Util.Transient s ->
- return (Util.Failed s)
- | _ ->
- fail e)
- >>= (fun res ->
- let rem =
- Uutil.Filesize.sub
- theSI.bytesToTransfer theSI.bytesTransferred
- in
- if rem <> Uutil.Filesize.zero then
- showProgress (Uutil.File.ofLine i) rem "done";
- theSI.whatHappened <- Some (res, !textDetailed);
- fastRedisplay i;
-(* JV (7/09): It does not seem that useful to me to scroll the display
- to make the first unfinished item visible. The scrolling is way
- too fast, and it makes it impossible to browse the list. *)
-(*
- sync_action :=
- Some
- (fun () ->
- makeFirstUnfinishedVisible pRiThisRound;
- sync_action := None);
-*)
- gtk_sync false;
- return ())
- | Some _ ->
- return () (* Already processed this one (e.g. merged it) *)
- in
- loop (i + 1) (action :: actions) pRiThisRound
- end else
- actions
+ let uiWrapper i theSI =
+ match theSI.whatHappened with
+ None ->
+ let textDetailed = ref None in
+ catch (fun () ->
+ Transport.transportItem
+ theSI.ri (Uutil.File.ofLine i)
+ (fun title text ->
+ textDetailed := (Some text);
+ if Prefs.read Uicommon.confirmmerge then
+ twoBoxAdvanced
+ ~parent:toplevelWindow
+ ~title:title
+ ~message:("Do you want to commit the changes to"
+ ^ " the replicas ?")
+ ~longtext:text
+ ~advLabel:"View details..."
+ ~astock:`YES
+ ~bstock:`NO
+ else
+ true)
+ >>= (fun () ->
+ return Util.Succeeded))
+ (fun e ->
+ match e with
+ Util.Transient s ->
+ return (Util.Failed s)
+ | _ ->
+ fail e)
+ >>= (fun res ->
+ let rem =
+ Uutil.Filesize.sub
+ theSI.bytesToTransfer theSI.bytesTransferred
+ in
+ if rem <> Uutil.Filesize.zero then
+ showProgress (Uutil.File.ofLine i) rem "done";
+ theSI.whatHappened <- Some (res, !textDetailed);
+ fastRedisplay i;
+ gtk_sync false;
+ return ())
+ | Some _ ->
+ return () (* Already processed this one (e.g. merged it) *)
in
startStats ();
- Lwt_unix.run
- (let actions = loop 0 [] (fun ri -> not (Common.isDeletion ri)) in
- Lwt_util.join actions);
- Lwt_unix.run
- (let actions = loop 0 [] Common.isDeletion in
- Lwt_util.join actions);
- Transport.logFinish ();
+ Uicommon.transportItems !theState (fun {ri; _} -> not (Common.isDeletion ri)) uiWrapper;
+ Uicommon.transportItems !theState (fun {ri; _} -> Common.isDeletion ri) uiWrapper;
+ Uicommon.transportFinish ();
+ grSet grStop false;
Trace.showTimer t;
commitUpdates ();
stopStats ();
@@ -3567,19 +3800,29 @@ let createToplevelWindow () =
if skippedCount = 0 then [] else
[Printf.sprintf "%d skipped" skippedCount]
in
+ let nostartCount =
+ if not (Abort.isAll ()) then 0 else
+ Array.fold_left
+ (fun c si -> if si.whatHappened = None then c + 1 else c)
+ 0 !theState
+ in
+ let nostart =
+ if nostartCount = 0 then [] else
+ [Printf.sprintf "%d not started" nostartCount]
+ in
unsynchronizedPaths :=
Some (Safelist.map (fun (si, _, _) -> si.ri.path1)
(failureList @ partialList @ skippedList),
[]);
Trace.status
(Printf.sprintf "Synchronization complete %s"
- (String.concat ", " (failures @ partials @ skipped)));
+ (String.concat ", " (failures @ partials @ skipped @ nostart)));
displayGlobalProgress 0.;
grSet grRescan true;
make_interactive toplevelWindow;
- let totalCount = failureCount + partialCount + skippedCount in
+ let totalCount = failureCount + partialCount + skippedCount + nostartCount in
if totalCount > 0 then begin
let format n item sing plur =
match n with
@@ -3590,10 +3833,12 @@ let createToplevelWindow () =
let infos =
format failureCount "failure" "" "s" @
format partialCount "partially transferred director" "y" "ies" @
- format skippedCount "skipped item" "" "s"
+ format skippedCount "skipped item" "" "s" @
+ format nostartCount "not started item" "" "s"
in
let message =
- (if failureCount = 0 then "The synchronization was successful.\n\n"
+ (if failureCount = 0 && nostartCount = 0 then
+ "The synchronization was successful.\n\n"
else "") ^
"The replicas are not fully synchronized.\n" ^
(if totalCount < 2 then "There was" else "There were") ^
@@ -3608,7 +3853,7 @@ let createToplevelWindow () =
~title:"Synchronization summary" ~message ~f:
(fun t ->
let bullet = "\xe2\x80\xa2 " in
- let layout = t#misc#pango_context#create_layout in
+ let layout = Pango.Layout.create t#misc#pango_context#as_context in
Pango.Layout.set_text layout bullet;
let (n, _) = Pango.Layout.get_pixel_size layout in
let path =
@@ -3674,35 +3919,39 @@ let createToplevelWindow () =
let questionAction _ = doAction (fun _ diff -> diff.direction <- Conflict "") in
let mergeAction _ = doAction (fun _ diff -> diff.direction <- Merge) in
+ let insert_button (toolbar : #GButton.toolbar) ~stock ~text ~tooltip ~callback () =
+ let b = GButton.tool_button ~stock ~label:text ~packing:toolbar#insert () in
+ ignore (b#connect#clicked ~callback);
+ b#misc#set_tooltip_text tooltip;
+ b
+ in
+
(* actionBar#insert_space ();*)
grAdd grAction
- (actionBar#insert_button
-(* ~icon:((GMisc.pixmap rightArrowBlack ())#coerce)*)
- ~icon:((GMisc.image ~stock:`GO_FORWARD ())#coerce)
+ (insert_button actionBar
+ ~stock:`GO_FORWARD
~text:"Left to Right"
~tooltip:"Propagate selected items\n\
from the left replica to the right one"
~callback:rightAction ());
(* actionBar#insert_space ();*)
grAdd grAction
- (actionBar#insert_button ~text:"Skip"
- ~icon:((GMisc.image ~stock:`NO ())#coerce)
+ (insert_button actionBar ~text:"Skip"
+ ~stock:`NO
~tooltip:"Skip selected items"
~callback:questionAction ());
(* actionBar#insert_space ();*)
grAdd grAction
- (actionBar#insert_button
-(* ~icon:((GMisc.pixmap leftArrowBlack ())#coerce)*)
- ~icon:((GMisc.image ~stock:`GO_BACK ())#coerce)
+ (insert_button actionBar
+ ~stock:`GO_BACK
~text:"Right to Left"
~tooltip:"Propagate selected items\n\
from the right replica to the left one"
~callback:leftAction ());
(* actionBar#insert_space ();*)
grAdd grAction
- (actionBar#insert_button
-(* ~icon:((GMisc.pixmap mergeLogoBlack())#coerce)*)
- ~icon:((GMisc.image ~stock:`ADD ())#coerce)
+ (insert_button actionBar
+ ~stock:`ADD
~text:"Merge"
~tooltip:"Merge selected files"
~callback:mergeAction ());
@@ -3735,9 +3984,9 @@ let createToplevelWindow () =
| None ->
() in
- actionBar#insert_space ();
- grAdd grDiff (actionBar#insert_button ~text:"Diff"
- ~icon:((GMisc.image ~stock:`DIALOG_INFO ())#coerce)
+ actionBar#insert (GButton.separator_tool_item ());
+ grAdd grDiff (insert_button actionBar ~text:"Diff"
+ ~stock:`DIALOG_INFO
~tooltip:"Compare the two files at each replica"
~callback:diffCmd ());
@@ -3745,8 +3994,8 @@ let createToplevelWindow () =
Detail button
*********************************************************************)
(* actionBar#insert_space ();*)
- grAdd grDetail (actionBar#insert_button ~text:"Details"
- ~icon:((GMisc.image ~stock:`INFO ())#coerce)
+ grAdd grDetail (insert_button actionBar ~text:"Details"
+ ~stock:`INFO
~tooltip:"Show detailed information about\n\
an item, when available"
~callback:showDetCommand ());
@@ -3764,46 +4013,37 @@ let createToplevelWindow () =
(*********************************************************************
go button
*********************************************************************)
- actionBar#insert_space ();
+ actionBar#insert (GButton.separator_tool_item ());
grAdd grGo
- (actionBar#insert_button ~text:"Go"
+ (insert_button actionBar ~text:"Go"
(* tooltip:"Go with displayed actions" *)
- ~icon:((GMisc.image ~stock:`EXECUTE ())#coerce)
+ ~stock:`EXECUTE
~tooltip:"Perform the synchronization"
~callback:(fun () ->
getLock synchronize) ());
- (* Does not quite work: too slow, and Files.copy must be modifed to
- support an interruption without error. *)
- (*
- ignore (actionBar#insert_button ~text:"Stop"
- ~icon:((GMisc.image ~stock:`STOP ())#coerce)
- ~tooltip:"Exit Unison"
- ~callback:Abort.all ());
- *)
+ grAdd grStop
+ (insert_button actionBar ~text:"Stop"
+ ~stock:`STOP
+ ~tooltip:"Stop update propagation"
+ ~callback:Abort.all ());
(*********************************************************************
Rescan button
*********************************************************************)
+ let profileInitSuccess = ref false in
let updateFromProfile = ref (fun () -> ()) in
- let prepDebug () =
- if Sys.os_type = "Win32" then
- (* As a side-effect, this allocates a console if the process doesn't
- have one already. This call is here only for the side-effect,
- because debugging output is produced on stderr and the GUI will
- crash if there is no stderr. *)
- try ignore (System.terminalStateFunctions ())
- with Unix.Unix_error _ -> ()
- in
-
let loadProfile p reload =
debug (fun()-> Util.msg "Loading profile %s..." p);
Trace.status "Loading profile";
unsynchronizedPaths := None;
- Uicommon.initPrefs ~profileName:p
+ profileInitSuccess := false;
+ Uicommon.initPrefs ~profileName:p ~promptForRoots ~prepDebug ();
+ Uicommon.connectRoots
~displayWaitMessage:(fun () -> if not reload then displayWaitMessage ())
- ~getFirstRoot ~getSecondRoot ~prepDebug ~termInteract ();
+ ~termInteract ();
+ profileInitSuccess := true;
!updateFromProfile ()
in
@@ -3814,35 +4054,41 @@ let createToplevelWindow () =
| Some n -> n
in
clearMainWindow ();
- if not (Prefs.profileUnchanged ()) then loadProfile n true
- else Uicommon.refreshConnection ~displayWaitMessage ~termInteract
+ if not (Prefs.profileUnchanged ()) || not (!profileInitSuccess) then
+ loadProfile n true
+ else Uicommon.connectRoots ~displayWaitMessage ~termInteract ()
in
let detectCmd () =
- getLock detectUpdatesAndReconcile;
- updateDetails ();
- if Prefs.read Globals.batch then begin
- Prefs.set Globals.batch false; synchronize()
+ if !profileInitSuccess then begin
+ getLock detectUpdatesAndReconcile;
+ updateDetails ();
+ if Prefs.read Globals.batch then begin
+ Prefs.set Globals.batch false; synchronize()
+ end
+ end else begin
+ grSet grRescan true;
+ make_interactive toplevelWindow
end
in
(* actionBar#insert_space ();*)
grAdd grRescan
- (actionBar#insert_button ~text:"Rescan"
- ~icon:((GMisc.image ~stock:`REFRESH ())#coerce)
+ (insert_button actionBar ~text:"Rescan"
+ ~stock:`REFRESH
~tooltip:"Check for updates"
~callback: (fun () -> reloadProfile(); detectCmd()) ());
(*********************************************************************
Profile change button
*********************************************************************)
- actionBar#insert_space ();
+ actionBar#insert (GButton.separator_tool_item ());
let profileChange _ =
match getProfile false with
None -> ()
| Some p -> clearMainWindow (); loadProfile p false; detectCmd ()
in
- grAdd grRescan (actionBar#insert_button ~text:"Change Profile"
- ~icon:((GMisc.image ~stock:`OPEN ())#coerce)
+ grAdd grRescan (insert_button actionBar ~text:"Change Profile"
+ ~stock:`OPEN
~tooltip:"Select a different profile"
~callback:profileChange ());
@@ -3921,6 +4167,7 @@ let createToplevelWindow () =
"Do _Not Propagate Changes" in
grAdd grAction skip;
skip#add_accelerator ~group:accel_group ~modi:[`SHIFT] GdkKeysyms._minus;
+ skip#add_accelerator ~group:accel_group GdkKeysyms._KP_Divide;
let merge =
actionMenu#add_image_item ~key:GdkKeysyms._m ~callback:mergeAction
@@ -3971,7 +4218,7 @@ let createToplevelWindow () =
(actionMenu#add_item
~callback:(fun () ->
doAction (fun ri _ -> Recon.revertToDefaultDirection ri))
- "_Revert to Unison's Recommendations");
+ "_Revert to Unison's Recommendation");
grAdd grAction
(actionMenu#add_item
~callback:(fun () ->
@@ -4061,28 +4308,44 @@ let createToplevelWindow () =
~image:(GMisc.image ~stock:`OPEN ~icon_size:`MENU () :> GObj.widget)
"Change _Profile...");
- let fastProf name key =
- grAdd grRescan
- (fileMenu#add_item ~key:key
+ let fastProf i key =
+ let item = fileMenu#add_item ~key:key ~bindname:(string_of_int i) "" in
+ item#misc#hide ();
+ grAdd grRescan item;
+ let show name =
+ match item#children with
+ | [] | _::_::_ -> ()
+ | [l] ->
+ let label = (GMisc.label_cast l) in
+ label#set_label ("Select profile " ^ name);
+ ignore (item#connect#activate
~callback:(fun _ ->
if System.file_exists (Prefs.profilePathname name) then begin
Trace.status ("Loading profile " ^ name);
loadProfile name false; detectCmd ()
end else
Trace.status ("Profile " ^ name ^ " not found"))
- ("Select profile " ^ name)) in
+ );
+ item#misc#show ()
+ in
+ (item#misc#hide, show) in
let fastKeysyms =
[| GdkKeysyms._0; GdkKeysyms._1; GdkKeysyms._2; GdkKeysyms._3;
GdkKeysyms._4; GdkKeysyms._5; GdkKeysyms._6; GdkKeysyms._7;
GdkKeysyms._8; GdkKeysyms._9 |] in
- Array.iteri
- (fun i v -> match v with
- None -> ()
- | Some(profile, info) ->
- fastProf profile fastKeysyms.(i))
- Uicommon.profileKeymap;
+ let fastKeyitems = Array.init 10 (fun i -> fastProf i fastKeysyms.(i)) in
+
+ let updateProfileKeyMenu () =
+ if !Uicommon.profilesAndRoots = [] then Uicommon.scanProfiles ();
+
+ Array.iteri
+ (fun i v -> match v with
+ | None -> (fst fastKeyitems.(i)) ()
+ | Some (profile, info) -> (snd fastKeyitems.(i)) profile)
+ Uicommon.profileKeymap
+ in
ignore (fileMenu#add_separator ());
ignore (fileMenu#add_item
@@ -4104,11 +4367,9 @@ let createToplevelWindow () =
let (expertMenu, _) = add_submenu "Expert" in
let addDebugToggle modname =
- let cm =
- expertMenu#add_check_item ~active:(Trace.enabled modname)
- ~callback:(fun b -> Trace.enable modname b)
- ("Debug '" ^ modname ^ "'") in
- cm#set_show_toggle true in
+ ignore (expertMenu#add_check_item ~active:(Trace.enabled modname)
+ ~callback:(fun b -> Trace.enable modname b)
+ ("Debug '" ^ modname ^ "'")) in
addDebugToggle "all";
addDebugToggle "verbose";
@@ -4134,15 +4395,35 @@ let createToplevelWindow () =
(fun () ->
displayNewProfileLabel ();
setMainWindowColumnHeaders (Uicommon.roots2string ());
+ sizeMainWindow ();
buildActionMenu false);
+ fatalErrorHandler :=
+ (fun err ->
+ grDisactivateAll ();
+ make_interactive toplevelWindow;
+ Trace.status ("Fatal error: " ^ err);
+ inExit := true;
+ fatalError err;
+ inExit := false;
+ match !Prefs.profileName with
+ | Some _ -> grSet grRescan true
+ | None -> (* Normally should never get here; exceptions loading the
+ very first profile are handled in the [start] function. *)
+ begin match getProfile true with
+ | None -> exit 1
+ | Some p -> clearMainWindow (); loadProfile p false; detectCmd ()
+ end
+ );
+
ignore (toplevelWindow#event#connect#delete ~callback:
(fun _ -> safeExit (); true));
toplevelWindow#show ();
- fun () ->
- !updateFromProfile ();
+ fun p ->
+ updateProfileKeyMenu ();
mainWindow#misc#grab_focus ();
+ loadProfile p false;
detectCmd ()
@@ -4151,7 +4432,15 @@ let createToplevelWindow () =
*********************************************************************)
let start _ =
- begin try
+ try
+ (* Stop GTK 3 from forcing client-side decorations *)
+ begin
+ try ignore (Unix.getenv "GTK_CSD") with
+ | Unix.Unix_error _ | Not_found ->
+ try Unix.putenv "GTK_CSD" "0" with
+ | Unix.Unix_error _ -> ()
+ end;
+
(* Initialize the GTK library *)
ignore (GMain.Main.init ());
@@ -4159,10 +4448,9 @@ let start _ =
Some (fun msg -> warnBox ~parent:(toplevelWindow ()) "Warning" msg);
GtkSignal.user_handler :=
- (fun exn ->
- match exn with
- Util.Transient(s) | Util.Fatal(s) -> fatalError s
- | exn -> fatalError (Uicommon.exn2string exn));
+ (function
+ | Util.Transient s | Util.Fatal s -> !fatalErrorHandler s
+ | exn -> !fatalErrorHandler (Uicommon.exn2string exn));
(* Ask the Remote module to call us back at regular intervals during
long network operations. *)
@@ -4172,31 +4460,34 @@ let start _ =
in
ignore_result (tick ());
- let prepDebug () =
- if Sys.os_type = "Win32" then
- (* As a side-effect, this allocates a console if the process doesn't
- have one already. This call is here only for the side-effect,
- because debugging output is produced on stderr and the GUI will
- crash if there is no stderr. *)
- try ignore (System.terminalStateFunctions ())
- with Unix.Unix_error _ -> ()
+ let startGUI = createToplevelWindow () in
+
+ (* Any exceptions here will be caught by the main catch handler
+ and the GUI will exit. *)
+ let getProfile () = match getProfile true with None -> exit 0 | Some x -> x in
+ let profileName =
+ match Uicommon.uiInitClRootsAndProfile ~prepDebug () with
+ | Error s -> begin fatalError s;
+ Uicommon.clearClRoots (); getProfile () end
+ | Ok None -> getProfile ()
+ | Ok (Some s) -> s
in
- Os.createUnisonDir();
- Uicommon.scanProfiles();
- let detectCmd = createToplevelWindow() in
-
- Uicommon.uiInit
- ~prepDebug
- ~reportError:fatalError
- ~tryAgainOrQuit
- ~displayWaitMessage
- ~getProfile:(fun () -> getProfile true)
- ~getFirstRoot
- ~getSecondRoot
- ~termInteract
- ();
- detectCmd ();
+ (* Exceptions from here onwards will be caught by the inner catch handler
+ and the GUI will not exit. Instead, the profile manager is re-opened.
+ User has the option to quit in the profile manager. *)
+ let rec initLoop profileName =
+ try startGUI profileName with
+ | Util.Transient s | Util.Fatal s ->
+ s |> fatalError |> Uicommon.clearClRoots |> getProfile |> initLoop
+ (* Since we have not started the GTK main loop yet, it is easier to
+ handle exceptions here directly. [GtkSignal.safe_call] could be
+ used but it will fail in case of subsequent exceptions without
+ raising, thus escaping further exception handlers.
+ This separate handling sequence could in theory be removed if
+ [startGUI] is called while the GTK main loop is running. *)
+ in
+ initLoop profileName;
(* Display the ui *)
(*JV: not useful, as Unison does not handle any signal
@@ -4206,9 +4497,8 @@ let start _ =
*)
GMain.Main.main ()
with
- Util.Transient(s) | Util.Fatal(s) -> fatalError s
- | exn -> fatalError (Uicommon.exn2string exn)
- end
+ | Util.Transient s | Util.Fatal s -> fatalError ~quit:true s
+ | exn -> fatalError ~quit:true (Uicommon.exn2string exn)
end (* module Private *)
@@ -4225,12 +4515,15 @@ let start = function
let displayAvailable =
Util.osType = `Win32
||
- try System.getenv "DISPLAY" <> "" with Not_found -> false
+ (try System.getenv "DISPLAY" <> "" with Not_found -> false)
+ ||
+ (try System.getenv "WAYLAND_DISPLAY" <> "" with Not_found -> false)
in
if displayAvailable then Private.start Uicommon.Graphic
- else
- Util.warn "DISPLAY not set or empty; starting the Text UI\n";
+ else begin
+ Util.warn "DISPLAY and WAYLAND_DISPLAY not set or empty; starting the Text UI\n";
Uitext.Body.start Uicommon.Text
+ end
let defaultUi = Uicommon.Graphic
diff --git a/src/uigtk2.mli b/src/uigtk3.mli
similarity index 67%
rename from src/uigtk2.mli
rename to src/uigtk3.mli
index 4da1eac..4998e81 100644
--- a/src/uigtk2.mli
+++ b/src/uigtk3.mli
@@ -1,4 +1,4 @@
-(* Unison file synchronizer: src/uigtk2.mli *)
+(* Unison file synchronizer: src/uigtk3.mli *)
(* Copyright 1999-2020, Benjamin C. Pierce (see COPYING for details) *)
module Body : Uicommon.UI
diff --git a/src/uimac/MyController.m b/src/uimac/MyController.m
index 445c876..a14b84c 100644
--- a/src/uimac/MyController.m
+++ b/src/uimac/MyController.m
@@ -478,10 +478,36 @@ CAMLprim value unisonInit1Complete(value v)
return;
}
}
- NSLog(@"Unrecognized message from ssh: '%@'",prompt);
- ocamlCall("x@", "openConnectionCancel", preconn);
- NSRunAlertPanel(@"Connection Error", @"Unrecognized message from ssh: '%@'", @"OK", nil, nil, prompt);
- [self chooseProfiles];
+ /* Unison uimac versions <= 2.51.5 always produce an NSLog message
+ * "Calling nonGuiStartup". Previously, this was just hidden from the
+ * user. Starting Unison uimac version 2.51.5, error messages are
+ * displayed to the user. Since this is not an error message, and it
+ * is a known message to ignore, silently drop it here */
+ if (NSEqualRanges([prompt rangeOfString:@"Calling nonGuiStartup"],
+ NSMakeRange(NSNotFound, 0))) {
+ NSLog(@"Unrecognized message from ssh: '%@'",prompt);
+ NSInteger i = NSRunAlertPanel(@"Connection Error", @"Unrecognized message from ssh: '%@'",
+ @"Continue", @"Cancel", nil, prompt);
+ if (i == NSAlertAlternateReturn) {
+ ocamlCall("x@", "openConnectionCancel", preconn);
+ [self chooseProfiles];
+ return;
+ }
+ }
+ /* Unrecognized message from ssh does not immediately mean connection
+ * failure. Continue. */
+ prompt = ocamlCall("S@", "openConnectionPrompt", preconn);
+ if (!prompt) {
+ // all done with prompts, finish opening connection
+ ocamlCall("x@", "openConnectionEnd", preconn);
+ waitingForPassword = NO;
+ [self afterOpen];
+ return;
+ } else {
+ [self raisePasswordWindow:[NSString
+ stringWithUTF8String:String_val(Field(prompt, 0))]];
+ return;
+ }
}
// The password window will invoke this when Enter occurs, b/c we
@@ -934,7 +960,7 @@ CAMLprim value displayStatus(value s)
[statusText setStringValue:s];
}
-// Called from ocaml to dislpay progress bar
+// Called from ocaml to display progress bar
CAMLprim value displayGlobalProgress(value p)
{
id pool = [[NSAutoreleasePool alloc] init];
diff --git a/src/uimac/cltool.c b/src/uimac/cltool.c
index 2251a5b..5715c33 100644
--- a/src/uimac/cltool.c
+++ b/src/uimac/cltool.c
@@ -1,7 +1,7 @@
/* cltool.c
This is a command-line tool for Mac OS X that looks up the unison
- application, whereever it has been installed, and runs it. This
+ application, wherever it has been installed, and runs it. This
is intended to be installed in a standard place (e.g.,
/usr/bin/unison) to make it easy to invoke unison as a server, or
to use unison from the command line when it has been installed with
diff --git a/src/uimac/main.m b/src/uimac/main.m
index 8068a61..b51dbee 100644
--- a/src/uimac/main.m
+++ b/src/uimac/main.m
@@ -35,7 +35,7 @@ int main(int argc, const char *argv[])
!strcmp(argv[i],"-server") ||
!strcmp(argv[i],"-socket") ||
!strcmp(argv[i],"-ui")) {
- NSLog(@"Calling nonGuiStartup");
+ //NSLog(@"Calling nonGuiStartup");
@try {
ocamlCall("x", "unisonNonGuiStartup");
} @catch (NSException *ex) {
diff --git a/src/uimac/uimacnew.xcodeproj/project.pbxproj b/src/uimac/uimacnew.xcodeproj/project.pbxproj
index 09908d3..62b5c05 100644
--- a/src/uimac/uimacnew.xcodeproj/project.pbxproj
+++ b/src/uimac/uimacnew.xcodeproj/project.pbxproj
@@ -496,7 +496,6 @@
"-lthreadsnat",
"-lcamlstr",
"-lasmrun",
- "$(LIB_BIGARRAY)",
);
PRODUCT_BUNDLE_IDENTIFIER = edu.upenn.cis.Unison;
PRODUCT_NAME = Unison;
@@ -528,7 +527,6 @@
"-lthreadsnat",
"-lcamlstr",
"-lasmrun",
- "$(LIB_BIGARRAY)",
);
PRODUCT_BUNDLE_IDENTIFIER = edu.upenn.cis.Unison;
PRODUCT_NAME = Unison;
@@ -558,7 +556,6 @@
"-lthreadsnat",
"-lcamlstr",
"-lasmrun",
- "$(LIB_BIGARRAY)",
);
PRODUCT_BUNDLE_IDENTIFIER = edu.upenn.cis.Unison;
PRODUCT_NAME = Unison;
@@ -603,7 +600,6 @@
GCC_WARN_UNUSED_FUNCTION = YES;
GCC_WARN_UNUSED_VARIABLE = YES;
LIBRARY_SEARCH_PATHS = "";
- MACOSX_DEPLOYMENT_TARGET = 10.6;
ONLY_ACTIVE_ARCH = YES;
PRODUCT_BUNDLE_IDENTIFIER = edu.upenn.cis.Unison;
SDKROOT = macosx;
@@ -640,7 +636,6 @@
GCC_WARN_UNUSED_FUNCTION = YES;
GCC_WARN_UNUSED_VARIABLE = YES;
LIBRARY_SEARCH_PATHS = "";
- MACOSX_DEPLOYMENT_TARGET = 10.6;
PRODUCT_BUNDLE_IDENTIFIER = edu.upenn.cis.Unison;
SDKROOT = macosx;
SYSTEM_HEADER_SEARCH_PATHS = "$(OCAMLLIBDIR)";
@@ -676,7 +671,6 @@
GCC_WARN_UNUSED_FUNCTION = YES;
GCC_WARN_UNUSED_VARIABLE = YES;
LIBRARY_SEARCH_PATHS = "";
- MACOSX_DEPLOYMENT_TARGET = 10.6;
PRODUCT_BUNDLE_IDENTIFIER = edu.upenn.cis.Unison;
SDKROOT = macosx;
SYSTEM_HEADER_SEARCH_PATHS = "$(OCAMLLIBDIR)";
diff --git a/src/uimacbridge.ml b/src/uimacbridge.ml
index eb0e4c5..d6912fb 100644
--- a/src/uimacbridge.ml
+++ b/src/uimacbridge.ml
@@ -14,18 +14,102 @@ Callback.register "unisonNonGuiStartup" unisonNonGuiStartup;;
type stateItem = { mutable ri : reconItem;
mutable bytesTransferred : Uutil.Filesize.t;
+ mutable bytesToTransfer : Uutil.Filesize.t;
mutable whatHappened : Util.confirmation option;
mutable statusMessage : string option };;
let theState = ref [| |];;
let unsynchronizedPaths = ref None;;
-let unisonDirectory() = System.fspathToPrintString Util.unisonDir
+let unisonDirectory() = Util.unisonDir
;;
Callback.register "unisonDirectory" unisonDirectory;;
+(* Global progress indicator, similar to uigtk2.m; *)
+external displayGlobalProgress : float -> unit = "displayGlobalProgress";;
+
+let totalBytesToTransfer = ref Uutil.Filesize.zero;;
+let totalBytesTransferred = ref Uutil.Filesize.zero;;
+
+let lastFrac = ref 0.;;
+let showGlobalProgress b =
+ (* Concatenate the new message *)
+ totalBytesTransferred := Uutil.Filesize.add !totalBytesTransferred b;
+ let v =
+ if !totalBytesToTransfer = Uutil.Filesize.dummy then 0.
+ else if !totalBytesToTransfer = Uutil.Filesize.zero then 100.
+ else (Uutil.Filesize.percentageOfTotalSize
+ !totalBytesTransferred !totalBytesToTransfer)
+ in
+ if v = 0. || abs_float (v -. !lastFrac) > 1. then begin
+ lastFrac := v;
+ displayGlobalProgress v
+ end;;
+
+let initGlobalProgress b =
+ totalBytesToTransfer := b;
+ totalBytesTransferred := Uutil.Filesize.zero;
+ displayGlobalProgress 0.;;
+
+(* Defined in Bridge.m, used to redisplay the table
+ when the status for a row changes *)
+external bridgeThreadWait : int -> unit = "bridgeThreadWait";;
+
(* Defined in MyController.m, used to redisplay the table
when the status for a row changes *)
external displayStatus : string -> unit = "displayStatus";;
+let displayStatus s = displayStatus (Unicode.protect s);;
+
+(*
+ Called to create callback threads which wait on the C side for callbacks.
+ (We create three just for good measure...)
+
+ FIXME: the thread created by Thread.create doesn't run even if we yield --
+ we have to join. At that point we actually do get a different pthread, but
+ we've caused the calling thread to block (forever). As a result, this call
+ never returns.
+*)
+let callbackThreadCreate() =
+ let tCode () =
+ bridgeThreadWait 1;
+ in ignore (Thread.create tCode ()); ignore (Thread.create tCode ());
+ let tid = Thread.create tCode ()
+ in Thread.join tid;
+;;
+Callback.register "callbackThreadCreate" callbackThreadCreate;;
+
+(* Defined in MyController.m; display the error message and exit *)
+external displayFatalError : string -> unit = "fatalError";;
+
+let fatalError message =
+ let () =
+ try Trace.log (message ^ "\n")
+ with Util.Fatal _ -> () in (* Can't allow fatal errors in fatal error handler *)
+ displayFatalError message
+
+(* Defined in MyController.m; display the warning and ask whether to
+ exit or proceed *)
+external displayWarnPanel : string -> bool = "warnPanel";;
+
+let setWarnPrinter() =
+ Util.warnPrinter :=
+ Some(fun s ->
+ Trace.log ("Warning: " ^ s ^ "\n");
+ if not (Prefs.read Globals.batch) then begin
+ if (displayWarnPanel s) then begin
+ Lwt_unix.run (Update.unlockArchives ());
+ exit Uicommon.fatalExit
+ end
+ end)
+
+let doInOtherThread f =
+ Thread.create
+ (fun () ->
+ try
+ f ()
+ with
+ Util.Transient s | Util.Fatal s -> fatalError s
+ | exn -> fatalError (Uicommon.exn2string exn))
+ ()
(* Defined in MyController.m, used to redisplay the table
when the status for a row changes *)
@@ -33,27 +117,29 @@ external reloadTable : int -> unit = "reloadTable";;
(* from uigtk2 *)
let showProgress i bytes dbg =
(* Trace.status "showProgress"; *)
-(* XXX There should be a way to reset the amount of bytes transferred... *)
let i = Uutil.File.toLine i in
let item = !theState.(i) in
item.bytesTransferred <- Uutil.Filesize.add item.bytesTransferred bytes;
let b = item.bytesTransferred in
- let len = Common.riLength item.ri in
+ let len = item.bytesToTransfer in
let newstatus =
if b = Uutil.Filesize.zero || len = Uutil.Filesize.zero then "start "
else if len = Uutil.Filesize.zero then
Printf.sprintf "%5s " (Uutil.Filesize.toString b)
else Util.percent2string (Uutil.Filesize.percentageOfTotalSize b len) in
+ let oldstatus = item.statusMessage in
item.statusMessage <- Some newstatus;
+ showGlobalProgress bytes;
(* FIX: No status window in Mac version, see GTK version for how to do it *)
- reloadTable i;;
+ if oldstatus <> Some newstatus then reloadTable i;;
let unisonGetVersion() = Uutil.myVersion
;;
Callback.register "unisonGetVersion" unisonGetVersion;;
(* snippets from Uicommon, duplicated for now *)
-(* BCP: Duplicating this is a bad idea!!! *)
+(* BCP: Duplicating this is a really bad idea!!! *)
+
(* First initialization sequence *)
(* Returns a string option: command line profile, if any *)
let unisonInit0() =
@@ -65,6 +151,8 @@ let unisonInit0() =
Trace.sendLogMsgsToStderr := false;
(* Display progress in GUI *)
Uutil.setProgressPrinter showProgress;
+ (* Initialise global progress so progress bar is not updated *)
+ initGlobalProgress Uutil.Filesize.dummy;
(* Make sure we have a directory for archives and profiles *)
Os.createUnisonDir();
(* Extract any command line profile or roots *)
@@ -105,37 +193,57 @@ let unisonInit0() =
let f = Prefs.profilePathname n in
if not(System.file_exists f)
then (Printf.eprintf "Profile %s does not exist"
- (System.fspathToPrintString f);
+ f;
exit 1)
end;
!clprofile
;;
Callback.register "unisonInit0" unisonInit0;;
+(* Utility function to tell the UI whether roots were set *)
+
+let areRootsSet () =
+ match Globals.rawRoots() with
+ | [] -> false
+ | _ -> true
+;;
+Callback.register "areRootsSet" areRootsSet;;
+
+(* Utility function to tell the UI whether -batch is set *)
+
+let isBatchSet () =
+ Prefs.read Globals.batch
+;;
+Callback.register "isBatchSet" isBatchSet;;
+
(* The first time we load preferences, we also read the command line
arguments; if we re-load prefs (because the user selected a new profile)
we ignore the command line *)
let firstTime = ref(true)
-(* After figuring out the profile name *)
-let unisonInit1 profileName =
+(* After figuring out the profile name. If the profileName is the empty
+ string, it means that only the roots were specified on the command
+ line *)
+let do_unisonInit1 profileName =
(* Load the profile and command-line arguments *)
(* Restore prefs to their default values, if necessary *)
if not !firstTime then Prefs.resetToDefaults();
unsynchronizedPaths := None;
- (* Tell the preferences module the name of the profile *)
- Prefs.profileName := Some(profileName);
+ if profileName <> "" then begin
+ (* Tell the preferences module the name of the profile *)
+ Prefs.profileName := Some(profileName);
- (* If the profile does not exist, create an empty one (this should only
- happen if the profile is 'default', since otherwise we will already
- have checked that the named one exists). *)
- if not(System.file_exists (Prefs.profilePathname profileName)) then
- Prefs.addComment "Unison preferences file";
+ (* If the profile does not exist, create an empty one (this should only
+ happen if the profile is 'default', since otherwise we will already
+ have checked that the named one exists). *)
+ if not(System.file_exists (Prefs.profilePathname profileName)) then
+ Prefs.addComment "Unison preferences file";
- (* Load the profile *)
- (Trace.debug "" (fun() -> Util.msg "about to load prefs");
- Prefs.loadTheFile());
+ (* Load the profile *)
+ (Trace.debug "" (fun() -> Util.msg "about to load prefs");
+ Prefs.loadTheFile())
+ end;
(* Parse the command line. This will temporarily override
settings from the profile. *)
@@ -156,7 +264,7 @@ let unisonInit1 profileName =
let localRoots,remoteRoots =
Safelist.partition
(function Clroot.ConnectLocal _ -> true | _ -> false)
- (Safelist.map Clroot.parseRoot (Globals.rawRoots())) in
+ (Globals.parsedClRawRoots ()) in
match remoteRoots with
[r] ->
@@ -167,13 +275,28 @@ let unisonInit1 profileName =
raise(Util.Fatal "cannot synchronize more than one remote root");
| _ -> None
;;
+external unisonInit1Complete : Remote.preconnection option -> unit = "unisonInit1Complete";;
+
+(* Do this in another thread and return immedidately to free up main thread in cocoa *)
+let unisonInit1 profileName =
+ doInOtherThread
+ (fun () ->
+ let r = do_unisonInit1 profileName in
+ unisonInit1Complete r)
+;;
Callback.register "unisonInit1" unisonInit1;;
Callback.register "openConnectionPrompt" Remote.openConnectionPrompt;;
Callback.register "openConnectionReply" Remote.openConnectionReply;;
Callback.register "openConnectionEnd" Remote.openConnectionEnd;;
Callback.register "openConnectionCancel" Remote.openConnectionCancel;;
-let unisonInit2 () =
+let commitUpdates () =
+ Trace.status "Updating synchronizer state";
+ let t = Trace.startTimer "Updating synchronizer state" in
+ Update.commitUpdates();
+ Trace.showTimer t
+
+let do_unisonInit2 () =
(* Canonize the names of the roots and install them in Globals. *)
Globals.installRoots2();
@@ -207,6 +330,9 @@ let unisonInit2 () =
Printf.eprintf "\n"
);
+ (* Install the warning panel, hopefully it's not too late *)
+ setWarnPrinter();
+
Lwt_unix.run
(Uicommon.validateAndFixupPrefs () >>=
Globals.propagatePrefs);
@@ -229,23 +355,28 @@ let unisonInit2 () =
let t = Trace.startTimer "Checking for updates" in
let findUpdates () =
Trace.status "Looking for changes";
- let updates = Update.findUpdates ~wantWatcher:() !unsynchronizedPaths in
+ let updates = Update.findUpdates ~wantWatcher:true !unsynchronizedPaths in
Trace.showTimer t;
updates in
let reconcile updates = Recon.reconcileAll updates in
let (reconItemList, thereAreEqualUpdates, dangerousPaths) =
reconcile (findUpdates ()) in
- if reconItemList = [] then
+ if not !Update.foundArchives then commitUpdates ();
+ if reconItemList = [] then begin
+ if !Update.foundArchives then commitUpdates ();
if thereAreEqualUpdates then
- Trace.status "Replicas have been changed only in identical ways since last sync"
+ Trace.status
+ "Replicas have been changed only in identical ways since last sync"
else
Trace.status "Everything is up to date"
- else
+ end else
Trace.status "Check and/or adjust selected actions; then press Go";
Trace.status (Printf.sprintf "There are %d reconitems" (Safelist.length reconItemList));
let stateItemList =
Safelist.map
- (fun ri -> { ri = ri; bytesTransferred = Uutil.Filesize.zero;
+ (fun ri -> { ri = ri;
+ bytesTransferred = Uutil.Filesize.zero;
+ bytesToTransfer = Uutil.Filesize.zero;
whatHappened = None; statusMessage = None })
reconItemList in
theState := Array.of_list stateItemList;
@@ -257,15 +388,29 @@ let unisonInit2 () =
end;
!theState
;;
+
+external unisonInit2Complete : stateItem array -> unit = "unisonInit2Complete";;
+
+(* Do this in another thread and return immedidately to free up main thread in cocoa *)
+let unisonInit2 () =
+ doInOtherThread
+ (fun () ->
+ let r = do_unisonInit2 () in
+ unisonInit2Complete r)
+;;
Callback.register "unisonInit2" unisonInit2;;
let unisonRiToDetails ri =
- match ri.whatHappened with
- Some (Util.Failed s) -> (Path.toString ri.ri.path1) ^ "\n" ^ s
- | _ -> (Path.toString ri.ri.path1) ^ "\n" ^ (Uicommon.details2string ri.ri " ");;
+ Unicode.protect
+ (match ri.whatHappened with
+ Some (Util.Failed s) ->
+ Path.toString ri.ri.path1 ^ "\n" ^ s
+ | _ ->
+ Path.toString ri.ri.path1 ^ "\n" ^
+ Uicommon.details2string ri.ri " ");;
Callback.register "unisonRiToDetails" unisonRiToDetails;;
-let unisonRiToPath ri = Path.toString ri.ri.path1;;
+let unisonRiToPath ri = Unicode.protect (Path.toString ri.ri.path1);;
Callback.register "unisonRiToPath" unisonRiToPath;;
let rcToString rc =
@@ -278,16 +423,24 @@ let rcToString rc =
let unisonRiToLeft ri =
match ri.ri.replicas with
Problem _ -> ""
- | Different diff -> rcToString diff.rc1;;
+ | Different {rc1 = rc} -> rcToString rc;;
Callback.register "unisonRiToLeft" unisonRiToLeft;;
let unisonRiToRight ri =
match ri.ri.replicas with
Problem _ -> ""
- | Different diff -> rcToString diff.rc2;;
+ | Different {rc2 = rc} -> rcToString rc;;
Callback.register "unisonRiToRight" unisonRiToRight;;
+let unisonRiToFileSize ri =
+ Uutil.Filesize.toFloat (riLength ri.ri);;
+Callback.register "unisonRiToFileSize" unisonRiToFileSize;;
+
+let unisonRiToFileType ri =
+ riFileType ri.ri;;
+Callback.register "unisonRiToFileType" unisonRiToFileType;;
+
let direction2niceString = function (* from Uicommon where it's not exported *)
- Conflict -> "<-?->"
+ Conflict _ -> "<-?->"
| Replica1ToReplica2 -> "---->"
| Replica2ToReplica1 -> "<----"
| Merge -> "<-M->"
@@ -310,7 +463,7 @@ Callback.register "unisonRiSetRight" unisonRiSetRight;;
let unisonRiSetConflict ri =
match ri.ri.replicas with
Problem _ -> ()
- | Different diff -> diff.direction <- Conflict;;
+ | Different diff -> diff.direction <- Conflict "skip requested";;
Callback.register "unisonRiSetConflict" unisonRiSetConflict;;
let unisonRiSetMerge ri =
match ri.ri.replicas with
@@ -327,65 +480,126 @@ Callback.register "unisonRiForceNewer" unisonRiForceNewer;;
let unisonRiToProgress ri =
match (ri.statusMessage, ri.whatHappened,ri.ri.replicas) with
(None,None,_) -> ""
- | (Some s,None,_) -> s
- | (_,_,Different {direction = Conflict}) -> ""
+ | (Some s,None,_) -> Unicode.protect s
+ | (_,_,Different {direction = Conflict "files differed"}) -> ""
| (_,_,Problem _) -> ""
| (_,Some Util.Succeeded,_) -> "done"
| (_,Some (Util.Failed s),_) -> "FAILED";;
Callback.register "unisonRiToProgress" unisonRiToProgress;;
-let unisonSynchronize () =
+let unisonRiToBytesTransferred ri =
+ Uutil.Filesize.toFloat ri.bytesTransferred;;
+Callback.register "unisonRiToBytesTransferred" unisonRiToBytesTransferred;;
+
+(* --------------------------------------------------- *)
+
+(* Defined in MyController.m, used to show diffs *)
+external displayDiff : string -> string -> unit = "displayDiff";;
+external displayDiffErr : string -> unit = "displayDiffErr";;
+let displayDiff title text =
+ displayDiff (Unicode.protect title) (Unicode.protect text);;
+let displayDiffErr err = displayDiffErr (Unicode.protect err)
+
+(* If only properties have changed, we can't diff or merge.
+ 'Can't diff' is produced (uicommon.ml) if diff is attempted
+ when either side has PropsChanged *)
+let filesAreDifferent status1 status2 =
+ match status1, status2 with
+ `PropsChanged, `Unchanged -> false
+ | `Unchanged, `PropsChanged -> false
+ | `PropsChanged, `PropsChanged -> false
+ | _, _ -> true;;
+
+(* check precondition for diff; used to disable diff button *)
+let canDiff ri =
+ match ri.ri.replicas with
+ Problem _ -> false
+ | Different {rc1 = {typ = `FILE; status = status1};
+ rc2 = {typ = `FILE; status = status2}} ->
+ filesAreDifferent status1 status2
+ | Different _ -> false;;
+Callback.register "canDiff" canDiff;;
+
+(* from Uicommon *)
+(* precondition: uc = File (Updates(_, ..) on both sides *)
+let showDiffs ri printer errprinter id =
+ match ri.replicas with
+ Problem _ ->
+ errprinter
+ "Can't diff files: there was a problem during update detection"
+ | Different
+ {rc1 = {typ = `FILE; status = status1; ui = ui1};
+ rc2 = {typ = `FILE; status = status2; ui = ui2}} ->
+ if filesAreDifferent status1 status2 then
+ (let (root1,root2) = Globals.roots() in
+ begin
+ try Files.diff root1 ri.path1 ui1 root2 ri.path2 ui2 printer id
+ with Util.Transient e -> errprinter e
+ end)
+ | Different _ ->
+ errprinter "Can't diff: path doesn't refer to a file in both replicas"
+
+let runShowDiffs ri i =
+ let file = Uutil.File.ofLine i in
+ showDiffs ri.ri displayDiff displayDiffErr file;;
+Callback.register "runShowDiffs" runShowDiffs;;
+
+(* --------------------------------------------------- *)
+
+let do_unisonSynchronize () =
if Array.length !theState = 0 then
Trace.status "Nothing to synchronize"
else begin
Trace.status "Propagating changes";
- Transport.logStart ();
+ Uicommon.transportStart ();
+ let totalLength =
+ Array.fold_left
+ (fun l si ->
+ si.bytesTransferred <- Uutil.Filesize.zero;
+ let len =
+ if si.whatHappened = None then Common.riLength si.ri else
+ Uutil.Filesize.zero
+ in
+ si.bytesToTransfer <- len;
+ Uutil.Filesize.add l len)
+ Uutil.Filesize.zero !theState in
+ initGlobalProgress totalLength;
let t = Trace.startTimer "Propagating changes" in
- let im = Array.length !theState in
- let rec loop i actions pRiThisRound =
- if i < im then begin
- let theSI = !theState.(i) in
- let action =
- match theSI.whatHappened with
- None ->
- if not (pRiThisRound theSI.ri) then
- return ()
- else
- catch (fun () ->
- Transport.transportItem
- theSI.ri (Uutil.File.ofLine i)
- (fun title text ->
- Trace.status (Printf.sprintf "MERGE %s: %s" title text); true)
- >>= (fun () ->
- return Util.Succeeded))
- (fun e ->
- match e with
- Util.Transient s ->
- return (Util.Failed s)
- | _ ->
- fail e)
- >>= (fun res ->
- theSI.whatHappened <- Some res;
- return ())
- | Some _ ->
- return () (* Already processed this one (e.g. merged it) *)
- in
- loop (i + 1) (action :: actions) pRiThisRound
- end else
- return actions
+ let uiWrapper i theSI =
+ match theSI.whatHappened with
+ None ->
+ catch (fun () ->
+ Transport.transportItem
+ theSI.ri (Uutil.File.ofLine i)
+ (fun title text ->
+ debug (fun () -> Util.msg "MERGE '%s': '%s'"
+ title text);
+ displayDiff title text; true)
+ >>= (fun () ->
+ return Util.Succeeded))
+ (fun e ->
+ match e with
+ Util.Transient s ->
+ return (Util.Failed s)
+ | _ ->
+ fail e)
+ >>= (fun res ->
+ let rem =
+ Uutil.Filesize.sub
+ theSI.bytesToTransfer theSI.bytesTransferred
+ in
+ if rem <> Uutil.Filesize.zero then
+ showProgress (Uutil.File.ofLine i) rem "done";
+ theSI.whatHappened <- Some res;
+ return ())
+ | Some _ ->
+ return () (* Already processed this one (e.g. merged it) *)
in
- Lwt_unix.run
- (loop 0 [] (fun ri -> not (Common.isDeletion ri)) >>= (fun actions ->
- Lwt_util.join actions));
- Lwt_unix.run
- (loop 0 [] Common.isDeletion >>= (fun actions ->
- Lwt_util.join actions));
- Transport.logFinish ();
- Trace.showTimer t;
- Trace.status "Updating synchronizer state";
- let t = Trace.startTimer "Updating synchronizer state" in
- Update.commitUpdates();
+ Uicommon.transportItems !theState (fun {ri; _} -> not (Common.isDeletion ri)) uiWrapper;
+ Uicommon.transportItems !theState (fun {ri; _} -> Common.isDeletion ri) uiWrapper;
+ Uicommon.transportFinish ();
Trace.showTimer t;
+ commitUpdates ();
let failureList =
Array.fold_right
@@ -432,9 +646,9 @@ let unisonSynchronize () =
match si.ri.replicas with
Problem err ->
(si, [err], "error during update detection") :: l
- | Different diff when diff.direction = Conflict ->
+ | Different diff when (isConflict diff.direction) ->
(si, [],
- if diff.default_direction = Conflict then
+ if (isConflict diff.default_direction) then
"conflict"
else "skipped") :: l
| _ ->
@@ -453,15 +667,25 @@ let unisonSynchronize () =
Trace.status
(Printf.sprintf "Synchronization complete %s"
(String.concat ", " (failures @ partials @ skipped)));
+ initGlobalProgress Uutil.Filesize.dummy;
end;;
+external syncComplete : unit -> unit = "syncComplete";;
+
+(* Do this in another thread and return immedidately to free up main thread in cocoa *)
+let unisonSynchronize () =
+ doInOtherThread
+ (fun () ->
+ do_unisonSynchronize ();
+ syncComplete ())
+;;
Callback.register "unisonSynchronize" unisonSynchronize;;
-let unisonIgnorePath si =
- Uicommon.addIgnorePattern (Uicommon.ignorePath si.ri.path1);;
-let unisonIgnoreExt si =
- Uicommon.addIgnorePattern (Uicommon.ignoreExt si.ri.path1);;
-let unisonIgnoreName si =
- Uicommon.addIgnorePattern (Uicommon.ignoreName si.ri.path1);;
+let unisonIgnorePath pathString =
+ Uicommon.addIgnorePattern (Uicommon.ignorePath (Path.fromString pathString));;
+let unisonIgnoreExt pathString =
+ Uicommon.addIgnorePattern (Uicommon.ignoreExt (Path.fromString pathString));;
+let unisonIgnoreName pathString =
+ Uicommon.addIgnorePattern (Uicommon.ignoreName (Path.fromString pathString));;
Callback.register "unisonIgnorePath" unisonIgnorePath;;
Callback.register "unisonIgnoreExt" unisonIgnoreExt;;
Callback.register "unisonIgnoreName" unisonIgnoreName;;
@@ -504,10 +728,10 @@ let roots2niceStrings length = function
| _ -> assert false (* BOGUS? *);;
let unisonFirstRootString() =
let replica1, replica2 = roots2niceStrings 32 (Globals.roots()) in
- replica1;;
+ Unicode.protect replica1;;
let unisonSecondRootString() =
let replica1, replica2 = roots2niceStrings 32 (Globals.roots()) in
- replica2;;
+ Unicode.protect replica2;;
Callback.register "unisonFirstRootString" unisonFirstRootString;;
Callback.register "unisonSecondRootString" unisonSecondRootString;;
@@ -516,9 +740,19 @@ Callback.register "unisonSecondRootString" unisonSecondRootString;;
the current setting is Conflict *)
let unisonRiIsConflict ri =
match ri.ri.replicas with
- | Different {default_direction = Conflict} -> true
+ | Different {default_direction = Conflict "files differ"} -> true
| _ -> false;;
Callback.register "unisonRiIsConflict" unisonRiIsConflict;;
+
+(* Test whether reconItem's current state is different from
+ Unison's recommendation. Used to colour arrows in
+ the reconItems table *)
+let changedFromDefault ri =
+ match ri.ri.replicas with
+ Different diff -> diff.direction <> diff.default_direction
+ | _ -> false;;
+Callback.register "changedFromDefault" changedFromDefault;;
+
let unisonRiRevert ri =
match ri.ri.replicas with
| Different diff -> diff.direction <- diff.default_direction
@@ -534,6 +768,7 @@ let unisonProfileInit (profileName:string) (r1:string) (r2:string) =
Callback.register "unisonProfileInit" unisonProfileInit;;
Callback.register "unisonPasswordMsg" Terminal.password;;
+Callback.register "unisonPassphraseMsg" Terminal.passphrase;;
Callback.register "unisonAuthenticityMsg" Terminal.authenticity;;
let unisonExnInfo e =
@@ -543,4 +778,5 @@ let unisonExnInfo e =
| Unix.Unix_error(ue,s1,s2) ->
Printf.sprintf "Unix error(%s,%s,%s)" (Unix.error_message ue) s1 s2
| _ -> Printexc.to_string e;;
-Callback.register "unisonExnInfo" unisonExnInfo;;
+Callback.register "unisonExnInfo"
+ (fun e -> Unicode.protect (unisonExnInfo e));;
diff --git a/src/uimacbridgenew.ml b/src/uimacbridgenew.ml
deleted file mode 100644
index ff97846..0000000
--- a/src/uimacbridgenew.ml
+++ /dev/null
@@ -1,797 +0,0 @@
-(* ML side of a bridge to C for the Mac GUI *)
-
-open Common;;
-open Lwt;;
-
-let debug = Trace.debug "startup"
-
-let unisonNonGuiStartup() = begin
- (* If there's no GUI, don't print progress in the GUI *)
- Uutil.setProgressPrinter (fun _ _ _ -> ());
- Main.nonGuiStartup() (* If this returns the GUI should be started *)
-end;;
-Callback.register "unisonNonGuiStartup" unisonNonGuiStartup;;
-
-type stateItem = { mutable ri : reconItem;
- mutable bytesTransferred : Uutil.Filesize.t;
- mutable bytesToTransfer : Uutil.Filesize.t;
- mutable whatHappened : Util.confirmation option;
- mutable statusMessage : string option };;
-let theState = ref [| |];;
-let unsynchronizedPaths = ref None;;
-
-let unisonDirectory() = System.fspathToString Util.unisonDir
-;;
-Callback.register "unisonDirectory" unisonDirectory;;
-
-(* Global progress indicator, similar to uigtk2.m; *)
-external displayGlobalProgress : float -> unit = "displayGlobalProgress";;
-
-let totalBytesToTransfer = ref Uutil.Filesize.zero;;
-let totalBytesTransferred = ref Uutil.Filesize.zero;;
-
-let lastFrac = ref 0.;;
-let showGlobalProgress b =
- (* Concatenate the new message *)
- totalBytesTransferred := Uutil.Filesize.add !totalBytesTransferred b;
- let v =
- if !totalBytesToTransfer = Uutil.Filesize.dummy then 0.
- else if !totalBytesToTransfer = Uutil.Filesize.zero then 100.
- else (Uutil.Filesize.percentageOfTotalSize
- !totalBytesTransferred !totalBytesToTransfer)
- in
- if v = 0. || abs_float (v -. !lastFrac) > 1. then begin
- lastFrac := v;
- displayGlobalProgress v
- end;;
-
-let initGlobalProgress b =
- totalBytesToTransfer := b;
- totalBytesTransferred := Uutil.Filesize.zero;
- displayGlobalProgress 0.;;
-
-(* Defined in Bridge.m, used to redisplay the table
- when the status for a row changes *)
-external bridgeThreadWait : int -> unit = "bridgeThreadWait";;
-
-(* Defined in MyController.m, used to redisplay the table
- when the status for a row changes *)
-external displayStatus : string -> unit = "displayStatus";;
-let displayStatus s = displayStatus (Unicode.protect s);;
-
-(*
- Called to create callback threads which wait on the C side for callbacks.
- (We create three just for good measure...)
-
- FIXME: the thread created by Thread.create doesn't run even if we yield --
- we have to join. At that point we actually do get a different pthread, but
- we've caused the calling thread to block (forever). As a result, this call
- never returns.
-*)
-let callbackThreadCreate() =
- let tCode () =
- bridgeThreadWait 1;
- in ignore (Thread.create tCode ()); ignore (Thread.create tCode ());
- let tid = Thread.create tCode ()
- in Thread.join tid;
-;;
-Callback.register "callbackThreadCreate" callbackThreadCreate;;
-
-(* Defined in MyController.m; display the error message and exit *)
-external displayFatalError : string -> unit = "fatalError";;
-
-let fatalError message =
- let () =
- try Trace.log (message ^ "\n")
- with Util.Fatal _ -> () in (* Can't allow fatal errors in fatal error handler *)
- displayFatalError message
-
-(* Defined in MyController.m; display the warning and ask whether to
- exit or proceed *)
-external displayWarnPanel : string -> bool = "warnPanel";;
-
-let setWarnPrinter() =
- Util.warnPrinter :=
- Some(fun s ->
- Trace.log ("Warning: " ^ s ^ "\n");
- if not (Prefs.read Globals.batch) then begin
- if (displayWarnPanel s) then begin
- Lwt_unix.run (Update.unlockArchives ());
- exit Uicommon.fatalExit
- end
- end)
-
-let doInOtherThread f =
- Thread.create
- (fun () ->
- try
- f ()
- with
- Util.Transient s | Util.Fatal s -> fatalError s
- | exn -> fatalError (Uicommon.exn2string exn))
- ()
-
-(* Defined in MyController.m, used to redisplay the table
- when the status for a row changes *)
-external reloadTable : int -> unit = "reloadTable";;
-(* from uigtk2 *)
-let showProgress i bytes dbg =
-(* Trace.status "showProgress"; *)
- let i = Uutil.File.toLine i in
- let item = !theState.(i) in
- item.bytesTransferred <- Uutil.Filesize.add item.bytesTransferred bytes;
- let b = item.bytesTransferred in
- let len = item.bytesToTransfer in
- let newstatus =
- if b = Uutil.Filesize.zero || len = Uutil.Filesize.zero then "start "
- else if len = Uutil.Filesize.zero then
- Printf.sprintf "%5s " (Uutil.Filesize.toString b)
- else Util.percent2string (Uutil.Filesize.percentageOfTotalSize b len) in
- let oldstatus = item.statusMessage in
- item.statusMessage <- Some newstatus;
- showGlobalProgress bytes;
-(* FIX: No status window in Mac version, see GTK version for how to do it *)
- if oldstatus <> Some newstatus then reloadTable i;;
-
-let unisonGetVersion() = Uutil.myVersion
-;;
-Callback.register "unisonGetVersion" unisonGetVersion;;
-
-(* snippets from Uicommon, duplicated for now *)
-(* BCP: Duplicating this is a really bad idea!!! *)
-
-(* First initialization sequence *)
-(* Returns a string option: command line profile, if any *)
-let unisonInit0() =
- ignore (Gc.set {(Gc.get ()) with Gc.max_overhead = 150});
- (* Display status in GUI instead of on stderr *)
- let formatStatus major minor = (Util.padto 30 (major ^ " ")) ^ minor in
- Trace.messageDisplayer := displayStatus;
- Trace.statusFormatter := formatStatus;
- Trace.sendLogMsgsToStderr := false;
- (* Display progress in GUI *)
- Uutil.setProgressPrinter showProgress;
- (* Initialise global progress so progress bar is not updated *)
- initGlobalProgress Uutil.Filesize.dummy;
- (* Make sure we have a directory for archives and profiles *)
- Os.createUnisonDir();
- (* Extract any command line profile or roots *)
- let clprofile = ref None in
- begin
- try
- let args = Prefs.scanCmdLine Uicommon.usageMsg in
- match Util.StringMap.find "rest" args with
- [] -> ()
- | [profile] -> clprofile := Some profile
- | [root2;root1] -> Globals.setRawRoots [root1;root2]
- | [root2;root1;profile] ->
- Globals.setRawRoots [root1;root2];
- clprofile := Some profile
- | _ ->
- (Printf.eprintf
- "%s was invoked incorrectly (too many roots)" Uutil.myName;
- exit 1)
- with Not_found -> ()
- end;
- (* Print header for debugging output *)
- debug (fun() ->
- Printf.eprintf "%s, version %s\n\n" Uutil.myName Uutil.myVersion);
- debug (fun() -> Util.msg "initializing UI");
- debug (fun () ->
- (match !clprofile with
- None -> Util.msg "No profile given on command line"
- | Some s -> Printf.eprintf "Profile '%s' given on command line" s);
- (match Globals.rawRoots() with
- [] -> Util.msg "No roots given on command line"
- | [root1;root2] ->
- Printf.eprintf "Roots '%s' and '%s' given on command line"
- root1 root2
- | _ -> assert false));
- begin match !clprofile with
- None -> ()
- | Some n ->
- let f = Prefs.profilePathname n in
- if not(System.file_exists f)
- then (Printf.eprintf "Profile %s does not exist"
- (System.fspathToPrintString f);
- exit 1)
- end;
- !clprofile
-;;
-Callback.register "unisonInit0" unisonInit0;;
-
-(* Utility function to tell the UI whether roots were set *)
-
-let areRootsSet () =
- match Globals.rawRoots() with
- | [] -> false
- | _ -> true
-;;
-Callback.register "areRootsSet" areRootsSet;;
-
-(* Utility function to tell the UI whether -batch is set *)
-
-let isBatchSet () =
- Prefs.read Globals.batch
-;;
-Callback.register "isBatchSet" isBatchSet;;
-
-(* The first time we load preferences, we also read the command line
- arguments; if we re-load prefs (because the user selected a new profile)
- we ignore the command line *)
-let firstTime = ref(true)
-
-(* After figuring out the profile name. If the profileName is the empty
- string, it means that only the roots were specified on the command
- line *)
-let do_unisonInit1 profileName =
- (* Load the profile and command-line arguments *)
- (* Restore prefs to their default values, if necessary *)
- if not !firstTime then Prefs.resetToDefaults();
- unsynchronizedPaths := None;
-
- if profileName <> "" then begin
- (* Tell the preferences module the name of the profile *)
- Prefs.profileName := Some(profileName);
-
- (* If the profile does not exist, create an empty one (this should only
- happen if the profile is 'default', since otherwise we will already
- have checked that the named one exists). *)
- if not(System.file_exists (Prefs.profilePathname profileName)) then
- Prefs.addComment "Unison preferences file";
-
- (* Load the profile *)
- (Trace.debug "" (fun() -> Util.msg "about to load prefs");
- Prefs.loadTheFile())
- end;
-
- (* Parse the command line. This will temporarily override
- settings from the profile. *)
- if !firstTime then begin
- Trace.debug "" (fun() -> Util.msg "about to parse command line");
- Prefs.parseCmdLine Uicommon.usageMsg;
- end;
-
- firstTime := false;
-
- (* Print the preference settings *)
- Trace.debug "" (fun() -> Prefs.dumpPrefsToStderr() );
-
- (* FIX: if no roots, ask the user *)
-
- Recon.checkThatPreferredRootIsValid();
-
- let localRoots,remoteRoots =
- Safelist.partition
- (function Clroot.ConnectLocal _ -> true | _ -> false)
- (Safelist.map Clroot.parseRoot (Globals.rawRoots())) in
-
- match remoteRoots with
- [r] ->
- (* FIX: tell the user the next step (contacting server) might
- take a while *)
- Remote.openConnectionStart r
- | _::_::_ ->
- raise(Util.Fatal "cannot synchronize more than one remote root");
- | _ -> None
-;;
-external unisonInit1Complete : Remote.preconnection option -> unit = "unisonInit1Complete";;
-
-(* Do this in another thread and return immedidately to free up main thread in cocoa *)
-let unisonInit1 profileName =
- doInOtherThread
- (fun () ->
- let r = do_unisonInit1 profileName in
- unisonInit1Complete r)
-;;
-Callback.register "unisonInit1" unisonInit1;;
-Callback.register "openConnectionPrompt" Remote.openConnectionPrompt;;
-Callback.register "openConnectionReply" Remote.openConnectionReply;;
-Callback.register "openConnectionEnd" Remote.openConnectionEnd;;
-Callback.register "openConnectionCancel" Remote.openConnectionCancel;;
-
-let commitUpdates () =
- Trace.status "Updating synchronizer state";
- let t = Trace.startTimer "Updating synchronizer state" in
- Update.commitUpdates();
- Trace.showTimer t
-
-let do_unisonInit2 () =
- (* Canonize the names of the roots and install them in Globals. *)
- Globals.installRoots2();
-
- (* If both roots are local, disable the xferhint table to save time *)
- begin match Globals.roots() with
- ((Local,_),(Local,_)) -> Prefs.set Xferhint.xferbycopying false
- | _ -> ()
- end;
-
- (* If no paths were specified, then synchronize the whole replicas *)
- if Prefs.read Globals.paths = [] then Prefs.set Globals.paths [Path.empty];
-
- (* Expand any "wildcard" paths [with final component *] *)
- Globals.expandWildcardPaths();
-
- Update.storeRootsName ();
-
- Trace.debug ""
- (fun() ->
- Printf.eprintf "Roots: \n";
- Safelist.iter (fun clr -> Printf.eprintf " %s\n" clr)
- (Globals.rawRoots ());
- Printf.eprintf " i.e. \n";
- Safelist.iter (fun clr -> Printf.eprintf " %s\n"
- (Clroot.clroot2string (Clroot.parseRoot clr)))
- (Globals.rawRoots ());
- Printf.eprintf " i.e. (in canonical order)\n";
- Safelist.iter (fun r ->
- Printf.eprintf " %s\n" (root2string r))
- (Globals.rootsInCanonicalOrder());
- Printf.eprintf "\n"
- );
-
- (* Install the warning panel, hopefully it's not too late *)
- setWarnPrinter();
-
- Lwt_unix.run
- (Uicommon.validateAndFixupPrefs () >>=
- Globals.propagatePrefs);
-
- (* Initializes some backups stuff according to the preferences just loaded from the profile.
- Important to do it here, after prefs are propagated, because the function will also be
- run on the server, if any. Also, this should be done each time a profile is reloaded
- on this side, that's why it's here. *)
- Stasher.initBackups ();
-
- (* Turn on GC messages, if the '-debug gc' flag was provided *)
- if Trace.enabled "gc" then Gc.set {(Gc.get ()) with Gc.verbose = 0x3F};
-
- (* BCPFIX: Should/can this be done earlier?? *)
- Files.processCommitLogs();
-
- (* from Uigtk2 *)
- (* detect updates and reconcile *)
- let _ = Globals.roots () in
- let t = Trace.startTimer "Checking for updates" in
- let findUpdates () =
- Trace.status "Looking for changes";
- let updates = Update.findUpdates ~wantWatcher:() !unsynchronizedPaths in
- Trace.showTimer t;
- updates in
- let reconcile updates = Recon.reconcileAll updates in
- let (reconItemList, thereAreEqualUpdates, dangerousPaths) =
- reconcile (findUpdates ()) in
- if not !Update.foundArchives then commitUpdates ();
- if reconItemList = [] then begin
- if !Update.foundArchives then commitUpdates ();
- if thereAreEqualUpdates then
- Trace.status
- "Replicas have been changed only in identical ways since last sync"
- else
- Trace.status "Everything is up to date"
- end else
- Trace.status "Check and/or adjust selected actions; then press Go";
- Trace.status (Printf.sprintf "There are %d reconitems" (Safelist.length reconItemList));
- let stateItemList =
- Safelist.map
- (fun ri -> { ri = ri;
- bytesTransferred = Uutil.Filesize.zero;
- bytesToTransfer = Uutil.Filesize.zero;
- whatHappened = None; statusMessage = None })
- reconItemList in
- theState := Array.of_list stateItemList;
- unsynchronizedPaths :=
- Some (Safelist.map (fun ri -> ri.path1) reconItemList, []);
- if dangerousPaths <> [] then begin
- Prefs.set Globals.batch false;
- Util.warn (Uicommon.dangerousPathMsg dangerousPaths)
- end;
- !theState
-;;
-
-external unisonInit2Complete : stateItem array -> unit = "unisonInit2Complete";;
-
-(* Do this in another thread and return immedidately to free up main thread in cocoa *)
-let unisonInit2 () =
- doInOtherThread
- (fun () ->
- let r = do_unisonInit2 () in
- unisonInit2Complete r)
-;;
-Callback.register "unisonInit2" unisonInit2;;
-
-let unisonRiToDetails ri =
- Unicode.protect
- (match ri.whatHappened with
- Some (Util.Failed s) ->
- Path.toString ri.ri.path1 ^ "\n" ^ s
- | _ ->
- Path.toString ri.ri.path1 ^ "\n" ^
- Uicommon.details2string ri.ri " ");;
-Callback.register "unisonRiToDetails" unisonRiToDetails;;
-
-let unisonRiToPath ri = Unicode.protect (Path.toString ri.ri.path1);;
-Callback.register "unisonRiToPath" unisonRiToPath;;
-
-let rcToString rc =
- match rc.status with
- `Deleted -> "Deleted"
- | `Modified -> "Modified"
- | `PropsChanged -> "PropsChanged"
- | `Created -> "Created"
- | `Unchanged -> "";;
-let unisonRiToLeft ri =
- match ri.ri.replicas with
- Problem _ -> ""
- | Different {rc1 = rc} -> rcToString rc;;
-Callback.register "unisonRiToLeft" unisonRiToLeft;;
-let unisonRiToRight ri =
- match ri.ri.replicas with
- Problem _ -> ""
- | Different {rc2 = rc} -> rcToString rc;;
-Callback.register "unisonRiToRight" unisonRiToRight;;
-
-let unisonRiToFileSize ri =
- Uutil.Filesize.toFloat (riLength ri.ri);;
-Callback.register "unisonRiToFileSize" unisonRiToFileSize;;
-
-let unisonRiToFileType ri =
- riFileType ri.ri;;
-Callback.register "unisonRiToFileType" unisonRiToFileType;;
-
-let direction2niceString = function (* from Uicommon where it's not exported *)
- Conflict _ -> "<-?->"
- | Replica1ToReplica2 -> "---->"
- | Replica2ToReplica1 -> "<----"
- | Merge -> "<-M->"
-let unisonRiToDirection ri =
- match ri.ri.replicas with
- Problem _ -> "XXXXX"
- | Different diff -> direction2niceString diff.direction;;
-Callback.register "unisonRiToDirection" unisonRiToDirection;;
-
-let unisonRiSetLeft ri =
- match ri.ri.replicas with
- Problem _ -> ()
- | Different diff -> diff.direction <- Replica2ToReplica1;;
-Callback.register "unisonRiSetLeft" unisonRiSetLeft;;
-let unisonRiSetRight ri =
- match ri.ri.replicas with
- Problem _ -> ()
- | Different diff -> diff.direction <- Replica1ToReplica2;;
-Callback.register "unisonRiSetRight" unisonRiSetRight;;
-let unisonRiSetConflict ri =
- match ri.ri.replicas with
- Problem _ -> ()
- | Different diff -> diff.direction <- Conflict "skip requested";;
-Callback.register "unisonRiSetConflict" unisonRiSetConflict;;
-let unisonRiSetMerge ri =
- match ri.ri.replicas with
- Problem _ -> ()
- | Different diff -> diff.direction <- Merge;;
-Callback.register "unisonRiSetMerge" unisonRiSetMerge;;
-let unisonRiForceOlder ri =
- Recon.setDirection ri.ri `Older `Force;;
-Callback.register "unisonRiForceOlder" unisonRiForceOlder;;
-let unisonRiForceNewer ri =
- Recon.setDirection ri.ri `Newer `Force;;
-Callback.register "unisonRiForceNewer" unisonRiForceNewer;;
-
-let unisonRiToProgress ri =
- match (ri.statusMessage, ri.whatHappened,ri.ri.replicas) with
- (None,None,_) -> ""
- | (Some s,None,_) -> Unicode.protect s
- | (_,_,Different {direction = Conflict "files differed"}) -> ""
- | (_,_,Problem _) -> ""
- | (_,Some Util.Succeeded,_) -> "done"
- | (_,Some (Util.Failed s),_) -> "FAILED";;
-Callback.register "unisonRiToProgress" unisonRiToProgress;;
-
-let unisonRiToBytesTransferred ri =
- Uutil.Filesize.toFloat ri.bytesTransferred;;
-Callback.register "unisonRiToBytesTransferred" unisonRiToBytesTransferred;;
-
-(* --------------------------------------------------- *)
-
-(* Defined in MyController.m, used to show diffs *)
-external displayDiff : string -> string -> unit = "displayDiff";;
-external displayDiffErr : string -> unit = "displayDiffErr";;
-let displayDiff title text =
- displayDiff (Unicode.protect title) (Unicode.protect text);;
-let displayDiffErr err = displayDiffErr (Unicode.protect err)
-
-(* If only properties have changed, we can't diff or merge.
- 'Can't diff' is produced (uicommon.ml) if diff is attemped
- when either side has PropsChanged *)
-let filesAreDifferent status1 status2 =
- match status1, status2 with
- `PropsChanged, `Unchanged -> false
- | `Unchanged, `PropsChanged -> false
- | `PropsChanged, `PropsChanged -> false
- | _, _ -> true;;
-
-(* check precondition for diff; used to disable diff button *)
-let canDiff ri =
- match ri.ri.replicas with
- Problem _ -> false
- | Different {rc1 = {typ = `FILE; status = status1};
- rc2 = {typ = `FILE; status = status2}} ->
- filesAreDifferent status1 status2
- | Different _ -> false;;
-Callback.register "canDiff" canDiff;;
-
-(* from Uicommon *)
-(* precondition: uc = File (Updates(_, ..) on both sides *)
-let showDiffs ri printer errprinter id =
- match ri.replicas with
- Problem _ ->
- errprinter
- "Can't diff files: there was a problem during update detection"
- | Different
- {rc1 = {typ = `FILE; status = status1; ui = ui1};
- rc2 = {typ = `FILE; status = status2; ui = ui2}} ->
- if filesAreDifferent status1 status2 then
- (let (root1,root2) = Globals.roots() in
- begin
- try Files.diff root1 ri.path1 ui1 root2 ri.path2 ui2 printer id
- with Util.Transient e -> errprinter e
- end)
- | Different _ ->
- errprinter "Can't diff: path doesn't refer to a file in both replicas"
-
-let runShowDiffs ri i =
- let file = Uutil.File.ofLine i in
- showDiffs ri.ri displayDiff displayDiffErr file;;
-Callback.register "runShowDiffs" runShowDiffs;;
-
-(* --------------------------------------------------- *)
-
-let do_unisonSynchronize () =
- if Array.length !theState = 0 then
- Trace.status "Nothing to synchronize"
- else begin
- Trace.status "Propagating changes";
- Transport.logStart ();
- let totalLength =
- Array.fold_left
- (fun l si ->
- si.bytesTransferred <- Uutil.Filesize.zero;
- let len =
- if si.whatHappened = None then Common.riLength si.ri else
- Uutil.Filesize.zero
- in
- si.bytesToTransfer <- len;
- Uutil.Filesize.add l len)
- Uutil.Filesize.zero !theState in
- initGlobalProgress totalLength;
- let t = Trace.startTimer "Propagating changes" in
- let im = Array.length !theState in
- let rec loop i actions pRiThisRound =
- if i < im then begin
- let theSI = !theState.(i) in
- let action =
- match theSI.whatHappened with
- None ->
- if not (pRiThisRound theSI.ri) then
- return ()
- else
- catch (fun () ->
- Transport.transportItem
- theSI.ri (Uutil.File.ofLine i)
- (fun title text ->
- debug (fun () -> Util.msg "MERGE '%s': '%s'"
- title text);
- displayDiff title text; true)
- >>= (fun () ->
- return Util.Succeeded))
- (fun e ->
- match e with
- Util.Transient s ->
- return (Util.Failed s)
- | _ ->
- fail e)
- >>= (fun res ->
- let rem =
- Uutil.Filesize.sub
- theSI.bytesToTransfer theSI.bytesTransferred
- in
- if rem <> Uutil.Filesize.zero then
- showProgress (Uutil.File.ofLine i) rem "done";
- theSI.whatHappened <- Some res;
- return ())
- | Some _ ->
- return () (* Already processed this one (e.g. merged it) *)
- in
- loop (i + 1) (action :: actions) pRiThisRound
- end else
- return actions
- in
- Lwt_unix.run
- (loop 0 [] (fun ri -> not (Common.isDeletion ri)) >>= (fun actions ->
- Lwt_util.join actions));
- Lwt_unix.run
- (loop 0 [] Common.isDeletion >>= (fun actions ->
- Lwt_util.join actions));
- Transport.logFinish ();
- Trace.showTimer t;
- commitUpdates ();
-
- let failureList =
- Array.fold_right
- (fun si l ->
- match si.whatHappened with
- Some (Util.Failed err) ->
- (si, [err], "transport failure") :: l
- | _ ->
- l)
- !theState []
- in
- let failureCount = List.length failureList in
- let failures =
- if failureCount = 0 then [] else
- [Printf.sprintf "%d failure%s"
- failureCount (if failureCount = 1 then "" else "s")]
- in
- let partialList =
- Array.fold_right
- (fun si l ->
- match si.whatHappened with
- Some Util.Succeeded
- when partiallyProblematic si.ri &&
- not (problematic si.ri) ->
- let errs =
- match si.ri.replicas with
- Different diff -> diff.errors1 @ diff.errors2
- | _ -> assert false
- in
- (si, errs,
- "partial transfer (errors during update detection)") :: l
- | _ ->
- l)
- !theState []
- in
- let partialCount = List.length partialList in
- let partials =
- if partialCount = 0 then [] else
- [Printf.sprintf "%d partially transferred" partialCount]
- in
- let skippedList =
- Array.fold_right
- (fun si l ->
- match si.ri.replicas with
- Problem err ->
- (si, [err], "error during update detection") :: l
- | Different diff when (isConflict diff.direction) ->
- (si, [],
- if (isConflict diff.default_direction) then
- "conflict"
- else "skipped") :: l
- | _ ->
- l)
- !theState []
- in
- let skippedCount = List.length skippedList in
- let skipped =
- if skippedCount = 0 then [] else
- [Printf.sprintf "%d skipped" skippedCount]
- in
- unsynchronizedPaths :=
- Some (Safelist.map (fun (si, _, _) -> si.ri.path1)
- (failureList @ partialList @ skippedList),
- []);
- Trace.status
- (Printf.sprintf "Synchronization complete %s"
- (String.concat ", " (failures @ partials @ skipped)));
- initGlobalProgress Uutil.Filesize.dummy;
- end;;
-external syncComplete : unit -> unit = "syncComplete";;
-
-(* Do this in another thread and return immedidately to free up main thread in cocoa *)
-let unisonSynchronize () =
- doInOtherThread
- (fun () ->
- do_unisonSynchronize ();
- syncComplete ())
-;;
-Callback.register "unisonSynchronize" unisonSynchronize;;
-
-let unisonIgnorePath pathString =
- Uicommon.addIgnorePattern (Uicommon.ignorePath (Path.fromString pathString));;
-let unisonIgnoreExt pathString =
- Uicommon.addIgnorePattern (Uicommon.ignoreExt (Path.fromString pathString));;
-let unisonIgnoreName pathString =
- Uicommon.addIgnorePattern (Uicommon.ignoreName (Path.fromString pathString));;
-Callback.register "unisonIgnorePath" unisonIgnorePath;;
-Callback.register "unisonIgnoreExt" unisonIgnoreExt;;
-Callback.register "unisonIgnoreName" unisonIgnoreName;;
-
-(* Update the state to take into account ignore patterns.
- Return the new index of the first state item that is
- not ignored starting at old index i.
-*)
-let unisonUpdateForIgnore i =
- let l = ref [] in
- let num = ref(-1) in
- let newI = ref None in
- (* FIX: we should actually test whether any prefix is now ignored *)
- let keep s = not (Globals.shouldIgnore s.ri.path1) in
- for j = 0 to (Array.length !theState - 1) do
- let s = !theState.(j) in
- if keep s then begin
- l := s :: !l;
- num := !num + 1;
- if (j>=i && !newI=None) then newI := Some !num
- end
- done;
- theState := Array.of_list (Safelist.rev !l);
- match !newI with None -> (Array.length !theState - 1)
- | Some i' -> i';;
-Callback.register "unisonUpdateForIgnore" unisonUpdateForIgnore;;
-
-let unisonState () = !theState;;
-Callback.register "unisonState" unisonState;;
-
-(* from Uicommon *)
-let roots2niceStrings length = function
- (Local,fspath1), (Local,fspath2) ->
- let name1, name2 = Fspath.differentSuffix fspath1 fspath2 in
- (Util.truncateString name1 length, Util.truncateString name2 length)
- | (Local,fspath1), (Remote host, fspath2) ->
- (Util.truncateString "local" length, Util.truncateString host length)
- | (Remote host, fspath1), (Local,fspath2) ->
- (Util.truncateString host length, Util.truncateString "local" length)
- | _ -> assert false (* BOGUS? *);;
-let unisonFirstRootString() =
- let replica1, replica2 = roots2niceStrings 32 (Globals.roots()) in
- Unicode.protect replica1;;
-let unisonSecondRootString() =
- let replica1, replica2 = roots2niceStrings 32 (Globals.roots()) in
- Unicode.protect replica2;;
-Callback.register "unisonFirstRootString" unisonFirstRootString;;
-Callback.register "unisonSecondRootString" unisonSecondRootString;;
-
-
-(* Note, this returns whether the files conflict, NOT whether
- the current setting is Conflict *)
-let unisonRiIsConflict ri =
- match ri.ri.replicas with
- | Different {default_direction = Conflict "files differ"} -> true
- | _ -> false;;
-Callback.register "unisonRiIsConflict" unisonRiIsConflict;;
-
-(* Test whether reconItem's current state is different from
- Unison's recommendation. Used to colour arrows in
- the reconItems table *)
-let changedFromDefault ri =
- match ri.ri.replicas with
- Different diff -> diff.direction <> diff.default_direction
- | _ -> false;;
-Callback.register "changedFromDefault" changedFromDefault;;
-
-let unisonRiRevert ri =
- match ri.ri.replicas with
- | Different diff -> diff.direction <- diff.default_direction
- | _ -> ();;
-Callback.register "unisonRiRevert" unisonRiRevert;;
-
-let unisonProfileInit (profileName:string) (r1:string) (r2:string) =
- Prefs.resetToDefaults();
- Prefs.profileName := Some(profileName);
- Prefs.addComment "Unison preferences file"; (* Creates the file, assumes it doesn't exist *)
- ignore (Prefs.add "root" r1);
- ignore (Prefs.add "root" r2);;
-Callback.register "unisonProfileInit" unisonProfileInit;;
-
-Callback.register "unisonPasswordMsg" Terminal.password;;
-Callback.register "unisonPassphraseMsg" Terminal.passphrase;;
-Callback.register "unisonAuthenticityMsg" Terminal.authenticity;;
-
-let unisonExnInfo e =
- match e with
- Util.Fatal s -> Printf.sprintf "Fatal error: %s" s
- | Invalid_argument s -> Printf.sprintf "Invalid argument: %s" s
- | Unix.Unix_error(ue,s1,s2) ->
- Printf.sprintf "Unix error(%s,%s,%s)" (Unix.error_message ue) s1 s2
- | _ -> Printexc.to_string e;;
-Callback.register "unisonExnInfo"
- (fun e -> Unicode.protect (unisonExnInfo e));;
diff --git a/src/uitext.ml b/src/uitext.ml
index 6b5b666..5d1513a 100644
--- a/src/uitext.ml
+++ b/src/uitext.ml
@@ -25,7 +25,8 @@ let debug = Trace.debug "ui"
let dumbtty =
Prefs.createBool "dumbtty"
(try System.getenv "EMACS" <> "" with Not_found -> false)
- "!do not change terminal settings in text UI"
+ ~category:(`Advanced `CLI)
+ "do not change terminal settings in text UI"
("When set to \\verb|true|, this flag makes the text mode user "
^ "interface avoid trying to change any of the terminal settings. "
^ "(Normally, Unison puts the terminal in `raw mode', so that it can "
@@ -40,7 +41,9 @@ let dumbtty =
^ "interface.")
let silent =
- Prefs.createBool "silent" false "print nothing except error messages"
+ Prefs.createBool "silent" false
+ ~category:(`Basic `Syncprocess_CLI)
+ "print nothing except error messages"
("When this preference is set to {\\tt true}, the textual user "
^ "interface will print nothing at all, except in the case of errors. "
^ "Setting \\texttt{silent} to true automatically sets the "
@@ -87,8 +90,9 @@ let setupTerminal() =
restoreTerminal ()
let colorMode =
- Prefs.createBoolWithDefault "color" ~local:true
- "!use color output for text UI (true/false/default)"
+ Prefs.createBoolWithDefault "color"
+ ~category:(`Advanced `CLI) ~local:true
+ "use color output for text UI (true/false/default)"
("When set to {\\tt true}, this flag enables color output in "
^ "text mode user interface. When set to {\\tt false}, all "
^ "color output is disabled. Default is to enable color if "
@@ -100,13 +104,15 @@ let setColorPreference () =
let envOk = try let _ = System.getenv "NO_COLOR" in false
with Not_found -> true
and termOk = try System.getenv "TERM" <> "dumb" with Not_found -> true
- and ttyOk = (Unix.isatty Unix.stdin) && (Unix.isatty Unix.stderr) in
+ and ttyOk = (Unix.isatty Unix.stdout) && (Unix.isatty Unix.stderr) in
let colorOk = envOk && termOk && ttyOk && not (Prefs.read dumbtty) in
colorEnabled :=
match Prefs.read colorMode with
| `True -> true
| `False -> false
- | `Default -> colorOk && Sys.os_type <> "Win32"
+ | `Default -> colorOk && (not Sys.win32
+ || (System.termVtCapable Unix.stdout
+ && System.termVtCapable Unix.stderr))
let color t =
if not !colorEnabled then "" else
@@ -461,7 +467,7 @@ let interact prilist rilist =
begin match !Prefs.profileName with None -> assert false |
Some(n) ->
display (" To un-ignore, edit "
- ^ System.fspathToPrintString (Prefs.profilePathname n)
+ ^ Prefs.profilePathname n
^ " and restart " ^ Uutil.myName ^ "\n") end;
let nukeIgnoredRis =
Safelist.filter (fun ri -> not (Globals.shouldIgnore ri.path1)) in
@@ -781,7 +787,7 @@ type stateItem =
mutable bytesTransferred : Uutil.Filesize.t;
mutable bytesToTransfer : Uutil.Filesize.t }
-let doTransport reconItemList =
+let doTransport reconItemList numskip isSkip =
let items =
Array.map
(fun ri ->
@@ -790,57 +796,138 @@ let doTransport reconItemList =
bytesToTransfer = Common.riLength ri})
(Array.of_list reconItemList)
in
+ let totalItemsTransferred = ref 0 in
+ let totalItemsToTransfer = Array.length items - numskip in
+ let totalItemsToTransferStr = string_of_int totalItemsToTransfer in
let totalBytesTransferred = ref Uutil.Filesize.zero in
let totalBytesToTransfer =
- ref
(Array.fold_left
(fun s item -> Uutil.Filesize.add item.bytesToTransfer s)
Uutil.Filesize.zero items)
in
- let t0 = Unix.gettimeofday () in
+ let totalBytesToTransferStr = Util.bytes2string
+ (Uutil.Filesize.toInt64 totalBytesToTransfer) in
+ let totalToTransfer =
+ Uutil.Filesize.(add totalBytesToTransfer (ofInt totalItemsToTransfer)) in
+ let sta = Uicommon.Stats.init totalBytesToTransfer in
let calcProgress i bytes dbg =
let i = Uutil.File.toLine i in
let item = items.(i) in
item.bytesTransferred <- Uutil.Filesize.add item.bytesTransferred bytes;
totalBytesTransferred := Uutil.Filesize.add !totalBytesTransferred bytes;
- let v =
- (Uutil.Filesize.percentageOfTotalSize
- !totalBytesTransferred !totalBytesToTransfer)
- in
+ let totalTransferred =
+ Uutil.Filesize.(add !totalBytesTransferred (ofInt !totalItemsTransferred)) in
+ Uutil.Filesize.percentageOfTotalSize totalTransferred totalToTransfer
+ in
+ let tlog = ref (Unix.gettimeofday ()) in
+ let t = ref 0. in
+ let prevItems = ref 0 in
+ let displayProgress v =
let t1 = Unix.gettimeofday () in
- let remTime =
- if v <= 0. then "--:--"
- else if v >= 100. then "00:00"
- else
- let t = truncate ((t1 -. t0) *. (100. -. v) /. v +. 0.5) in
- Format.sprintf "%02d:%02d" (t / 60) (t mod 60)
- in
- t1, Format.sprintf "%s %s ETA" (Util.percent2string v) remTime
+ let () = Uicommon.Stats.update sta t1 !totalBytesTransferred in
+ if t1 -. !t >= 0.1 || !prevItems <> !totalItemsTransferred then begin
+ t := t1;
+ prevItems := !totalItemsTransferred;
+ let remTime =
+ if v <= 0. then "--:--"
+ else if v >= 100. then "00:00:00"
+ else
+ let rate = Uicommon.Stats.avgRate1 sta in
+ if Float.is_nan rate then "--:--"
+ else
+ Format.sprintf "%8s/s %s"
+ (Util.bytes2string (Int64.of_float rate))
+ (Uicommon.Stats.eta sta "--:--")
+ in
+ let totalBytesTransferredStr = Util.bytes2string
+ (Uutil.Filesize.toInt64 !totalBytesTransferred) in
+ let s = Format.sprintf "%s %d/%s (%s of %s) %s ETA"
+ (Util.percent2string v)
+ !totalItemsTransferred totalItemsToTransferStr
+ totalBytesTransferredStr totalBytesToTransferStr remTime in
+
+ if not (Prefs.read Trace.terse) && (Prefs.read Trace.debugmods = []) then
+ Util.set_infos s;
+ if (Prefs.read Trace.terse) || (Prefs.read Globals.batch) then
+ if (t1 -. !tlog) >= 60. then
+ begin
+ Trace.logonly (s ^ "\n");
+ tlog := t1
+ end
+ end
in
- let tlog = ref t0 in
let showProgress i bytes dbg =
- let t1, s = calcProgress i bytes dbg in
- if not (Prefs.read Trace.terse) && (Prefs.read Trace.debugmods = []) then
- Util.set_infos s;
- if (Prefs.read Trace.terse) || (Prefs.read Globals.batch) then
- if (t1 -. !tlog) >= 60. then
- begin
- Trace.logonly (s ^ "\n");
- tlog := t1
- end
+ let v = calcProgress i bytes dbg in
+ displayProgress v
in
Uutil.setProgressPrinter showProgress;
- Transport.logStart ();
+ let intrcount = ref 0 in
+ let sigtermHandler _ =
+ if !intrcount >= 3 then raise Sys.Break;
+ Abort.all ();
+ incr intrcount
+ in
+ let ctrlCHandler n =
+ sigtermHandler n;
+ if !intrcount = 1 then
+ let s = "\n\nUpdate propagation interrupted. It may take a while \
+ to stop.\nIf the process doesn't stop soon then wait or press \
+ Ctrl-C\n3 more times to force immediate termination.\n\n\n" in
+ (* Don't use [Printf.*printf] or [Format.*printf] (or other functions
+ which use [Stdlib.out_channel]) because this can cause a deadlock
+ with other outputting functions (in this case most likely at
+ [Util.set_infos] called in [showProgress]) before OCaml 4.12. *)
+ try Unix.write_substring Unix.stdout s 0 (String.length s) |> ignore
+ with Unix.Unix_error _ -> ()
+ in
+ let stopAtIntr f =
+ let signal_noerr signa behv =
+ try Some (Sys.signal signa behv)
+ with Sys_error _ | Invalid_argument _ -> None
+ in
+ let restore_noerr signa = function
+ | Some prevSig -> ignore (signal_noerr signa prevSig)
+ | None -> ()
+ in
+ let prevSigInt = signal_noerr Sys.sigint (Signal_handle ctrlCHandler) in
+ let prevSigTerm = signal_noerr Sys.sigterm (Signal_handle sigtermHandler) in
+ let restoreSig () =
+ (* Set handlers will still raise [Sys.Break]; can ignore errors here. *)
+ restore_noerr Sys.sigint prevSigInt;
+ restore_noerr Sys.sigterm prevSigTerm
+ in
+
+ try f (); restoreSig ()
+ with e ->
+ let origbt = Printexc.get_raw_backtrace () in
+ restoreSig ();
+ Printexc.raise_with_backtrace e origbt
+ in
+
+ if not (Prefs.read Trace.terse) && (Prefs.read Trace.debugmods = []) then
+ Util.set_infos "Starting...";
+ Uicommon.transportStart ();
let fFailedPaths = ref [] in
let fPartialPaths = ref [] in
- let uiWrapper i item f =
- Lwt.try_bind f
+ let notstarted = ref (Array.length items) in
+ let progressItem i =
+ incr totalItemsTransferred;
+ showProgress (Uutil.File.ofLine i) Uutil.Filesize.zero "itm"
+ in
+ let uiWrapper i item =
+ Lwt.try_bind
+ (fun () -> decr notstarted;
+ Transport.transportItem item.ri
+ (Uutil.File.ofLine i) verifyMerge)
(fun () ->
- if partiallyProblematic item.ri && not (problematic item.ri) then
+ let notSkip = not (isSkip item.ri) in
+ if partiallyProblematic item.ri && notSkip then
fPartialPaths := item.ri.path1 :: !fPartialPaths;
+ if notSkip then progressItem i;
Lwt.return ())
(fun e ->
+ if not (isSkip item.ri) then progressItem i;
match e with
Util.Transient s ->
let rem =
@@ -856,42 +943,20 @@ let doTransport reconItemList =
return ()
| _ ->
fail e) in
- let im = Array.length items in
- let rec loop i actions pRiThisRound =
- if i < im then begin
- let item = items.(i) in
- let actions =
- if pRiThisRound item.ri then
- uiWrapper i item
- (fun () -> Transport.transportItem item.ri
- (Uutil.File.ofLine i) verifyMerge)
- :: actions
- else
- actions
- in
- loop (i + 1) actions pRiThisRound
- end else
- actions
- in
- Lwt_unix.run
- (let actions = loop 0 [] (fun ri -> not (Common.isDeletion ri)) in
- Lwt_util.join actions);
- Lwt_unix.run
- (let actions = loop 0 [] Common.isDeletion in
- Lwt_util.join actions);
- Transport.logFinish ();
+ stopAtIntr begin fun () ->
+ Uicommon.transportItems items (fun {ri; _} -> not (Common.isDeletion ri)) uiWrapper;
+ Uicommon.transportItems items (fun {ri; _} -> Common.isDeletion ri) uiWrapper
+ end;
+ Uicommon.transportFinish ();
Uutil.setProgressPrinter (fun _ _ _ -> ());
Util.set_infos "";
- (Safelist.rev !fFailedPaths, Safelist.rev !fPartialPaths)
+ (Safelist.rev !fFailedPaths, Safelist.rev !fPartialPaths, !notstarted, !intrcount > 0)
let setWarnPrinterForInitialization()=
Util.warnPrinter :=
- Some(fun s ->
- alwaysDisplay "Error: ";
- alwaysDisplay (s^"\n");
- exit Uicommon.fatalExit)
+ Some (fun s -> alwaysDisplay ("Warning: " ^ s ^ "\n\n"))
let setWarnPrinter() =
Util.warnPrinter :=
@@ -925,30 +990,76 @@ let formatStatus major minor =
s
let rec interactAndPropagateChanges prevItemList reconItemList
- : bool * bool * bool * (Path.t list)
- (* anySkipped?, anyPartial?, anyFailures?, failingPaths *) =
+ : bool * bool * bool * bool * (Path.t list)
+ (* anySkipped?, anyPartial?, anyFailures?, anyCancels?, failingPaths *) =
let (proceed,newReconItemList) = interact prevItemList reconItemList in
- let (updatesToDo, skipped) =
+ let isSkip = problematic in
+ let (updatesToDo, skipped, (totalBytesToRoot1, totalBytesToRoot2)) =
Safelist.fold_left
- (fun (howmany, skipped) ri ->
- if problematic ri then (howmany, skipped + 1)
- else (howmany + 1, skipped))
- (0, 0) newReconItemList in
+ (fun (howmany, skipped, (bytes1, bytes2)) ri ->
+ if isSkip ri then (howmany, skipped + 1, (bytes1, bytes2))
+ else (howmany + 1, skipped,
+ match ri.replicas with
+ | Problem _ -> (bytes1, bytes2)
+ | Different {direction; _} ->
+ match direction with
+ | Conflict _ | Merge -> (bytes1, bytes2)
+ | Replica1ToReplica2 -> (bytes1, Uutil.Filesize.add (Common.riLength ri) bytes2)
+ | Replica2ToReplica1 -> (Uutil.Filesize.add (Common.riLength ri) bytes1, bytes2)))
+ (0, 0, (Uutil.Filesize.zero, Uutil.Filesize.zero)) newReconItemList in
+ if not (Prefs.read Trace.terse) && (updatesToDo > 0 || skipped > 0) then begin
+ let root1, root2 =
+ match Globals.roots () with
+ | (Local, path1), (Local, path2) -> Fspath.differentSuffix path1 path2
+ | (Local, _), (Remote host, _) -> "local", host
+ | (Remote host, _), (Local, _) -> host, "local"
+ | (Remote host1, _), (Remote host2, _) -> host1, host2
+ in
+ Trace.log_color (Printf.sprintf
+ "\n%s%d%s items will be synced, %s%d%s skipped\n\
+ %s to be synced from %s to %s\n\
+ %s to be synced from %s to %s\n"
+ (color `Focus) updatesToDo (color `Reset)
+ (color `Information) skipped (color `Reset)
+ (Util.bytes2string (Uutil.Filesize.toInt64 totalBytesToRoot2)) root1 root2
+ (Util.bytes2string (Uutil.Filesize.toInt64 totalBytesToRoot1)) root2 root1)
+ end;
+ let doTransp () =
+ try
+ doTransport newReconItemList skipped isSkip
+ with e ->
+ let origbt = Printexc.get_raw_backtrace () in
+ let summary =
+ "\nSynchronization "
+ ^ (color `Failure)
+ ^ (match e with Sys.Break -> "interrupted" | _ -> "failed")
+ ^ (color `Reset)
+ ^ (try let tm = Util.localtime (Util.time ()) in
+ Printf.sprintf " at %02d:%02d:%02d"
+ tm.Unix.tm_hour tm.Unix.tm_min tm.Unix.tm_sec with _ -> "")
+ ^ (match e with Sys.Break -> " by user request" | _ -> " due to a fatal error")
+ ^ "\n\n"
+ in
+ Util.set_infos "";
+ Trace.log_color summary;
+ Printexc.raise_with_backtrace e origbt
+ in
let doit() =
if not (Prefs.read Globals.batch || Prefs.read Trace.terse) then newLine();
if not (Prefs.read Trace.terse) then Trace.status "Propagating updates";
let timer = Trace.startTimer "Transmitting all files" in
- let (failedPaths, partialPaths) = doTransport newReconItemList in
+ let (failedPaths, partialPaths, notstarted, intr) = doTransp () in
let failures = Safelist.length failedPaths in
let partials = Safelist.length partialPaths in
Trace.showTimer timer;
if not (Prefs.read Trace.terse) then Trace.status "Saving synchronizer state";
Update.commitUpdates ();
- let trans = updatesToDo - failures in
+ let trans = updatesToDo - notstarted - failures in
let summary =
Printf.sprintf
- "Synchronization %s at %s (%d item%s transferred, %s%s, %s)"
- (if failures = 0 then (color `Success) ^ "complete" ^ (color `Reset) else (color `Failure) ^ "incomplete" ^ (color `Reset))
+ "Synchronization %s at %s (%d item%s transferred, %s%s, %s%s)"
+ (if failures = 0 && notstarted = 0 then (color `Success) ^ "complete" ^ (color `Reset)
+ else (color `Failure) ^ "incomplete" ^ (color `Reset))
(let tm = Util.localtime (Util.time()) in
Printf.sprintf "%02d:%02d:%02d"
tm.Unix.tm_hour tm.Unix.tm_min tm.Unix.tm_sec)
@@ -958,7 +1069,8 @@ let rec interactAndPropagateChanges prevItemList reconItemList
else
"")
(if skipped = 0 then "0 skipped" else (color `Information) ^ (Printf.sprintf "%d skipped" skipped) ^ (color `Reset))
- (if failures = 0 then "0 failed" else (color `Failure) ^ (Printf.sprintf "%d failed" failures) ^ (color `Reset)) in
+ (if failures = 0 then "0 failed" else (color `Failure) ^ (Printf.sprintf "%d failed" failures) ^ (color `Reset))
+ (if notstarted = 0 then "" else ", " ^ (color `Information) ^ (Printf.sprintf "%d not started" notstarted) ^ (color `Reset)) in
Trace.log_color (summary ^ "\n");
if skipped>0 then
Safelist.iter
@@ -979,7 +1091,8 @@ let rec interactAndPropagateChanges prevItemList reconItemList
Safelist.iter
(fun p -> alwaysDisplayAndLog (" failed: " ^ (Path.toString p)))
failedPaths;
- (skipped > 0, partials > 0, failures > 0, failedPaths) in
+ if intr then raise Sys.Break; (* Make sure repeat mode is stopped *)
+ (skipped > 0, partials > 0, failures > 0, notstarted > 0, failedPaths) in
if updatesToDo = 0 then begin
(* BCP (3/09): We need to commit the archives even if there are
no updates to propagate because some files (in fact, if we've
@@ -988,7 +1101,7 @@ let rec interactAndPropagateChanges prevItemList reconItemList
(* JV (5/09): Don't save the archive in repeat mode as it has some
costs and its unlikely there is much change to the archives in
this mode. *)
- if !Update.foundArchives && Prefs.read Uicommon.repeat = "" then
+ if !Update.foundArchives && Prefs.read Uicommon.repeat = `NoRepeat then
Update.commitUpdates ();
display "No updates to propagate\n";
if skipped > 0 then begin
@@ -1014,7 +1127,7 @@ let rec interactAndPropagateChanges prevItemList reconItemList
| _ -> ())
newReconItemList
end;
- (skipped > 0, false, false, [])
+ (skipped > 0, false, false, false, [])
end else if proceed=ProceedImmediately then begin
doit()
end else
@@ -1096,24 +1209,46 @@ let checkForDangerousPath dangerousPaths =
end
end
-let synchronizeOnce ?wantWatcher ?skipRecentFiles pathsOpt =
+let displayWaitMessage () =
+ if not (Prefs.read silent) then
+ Util.msg "%s\n" (Uicommon.contactingServerMsg ())
+
+(* Most modern VT100 terminal emulators (and some ANSI) are able to switch
+ automatic line-wrapping off and on by control sequences ESC[?7l and ESC[?7h.
+ This here is a very blunt heuristic to filter out some that can't do it or
+ use a different control sequence. It does not need to be exact, as long as
+ it covers the vast majority of supported systems. *)
+let termNowrapOk =
+ System.termVtCapable Unix.stdout &&
+ let s = try System.getenv "TERM" with Not_found -> "" in
+ not (
+ s = "dumb"
+ || s = "emacs"
+ || Util.startswith s "sun"
+ || Util.startswith s "cons"
+ || Util.startswith s "eterm"
+ || Util.startswith s "cygwin"
+ || Util.startswith s "dvtm"
+ )
+
+let synchronizeOnce ?wantWatcher pathsOpt =
let showStatus path =
if path = "" then Util.set_infos "" else
- let max_len = 70 in
- let mid = (max_len - 3) / 2 in
- let path =
+ let shorten path =
+ let max_len = 70 in
+ let mid = (max_len - 3) / 2 in
let l = String.length path in
if l <= max_len then path else
String.sub path 0 (max_len - mid - 3) ^ "..." ^
String.sub path (l - mid) mid
in
let c = "-\\|/".[truncate (mod_float (4. *. Unix.gettimeofday ()) 4.)] in
- Util.set_infos (Format.sprintf "%c %s" c path)
+ if termNowrapOk && not (Prefs.read dumbtty) then
+ Util.set_infos (Format.sprintf "%c \027[?7l%s\027[?7h" c path) ~clr:"\r\027[K\r"
+ else
+ Util.set_infos (Format.sprintf "%c %s" c (shorten path))
in
- Uicommon.refreshConnection
- ~displayWaitMessage:(fun () -> if not (Prefs.read silent)
- then Util.msg "%s\n" (Uicommon.contactingServerMsg()))
- ~termInteract:None;
+ Uicommon.connectRoots ~displayWaitMessage ();
Trace.status "Looking for changes";
if not (Prefs.read Trace.terse) && (Prefs.read Trace.debugmods = []) then
Uutil.setUpdateStatusPrinter (Some showStatus);
@@ -1131,7 +1266,7 @@ let synchronizeOnce ?wantWatcher ?skipRecentFiles pathsOpt =
if not !Update.foundArchives then Update.commitUpdates ();
if reconItemList = [] then begin
- if !Update.foundArchives && Prefs.read Uicommon.repeat = "" then
+ if !Update.foundArchives && Prefs.read Uicommon.repeat = `NoRepeat then
Update.commitUpdates ();
(if anyEqualUpdates then
Trace.status ("Nothing to do: replicas have been changed only "
@@ -1141,12 +1276,85 @@ let synchronizeOnce ?wantWatcher ?skipRecentFiles pathsOpt =
(Uicommon.perfectExit, [])
end else begin
checkForDangerousPath dangerousPaths;
- let (anySkipped, anyPartial, anyFailures, failedPaths) =
+ let (anySkipped, anyPartial, anyFailures, anyCancel, failedPaths) =
interactAndPropagateChanges [] reconItemList in
- let exitStatus = Uicommon.exitCode(anySkipped || anyPartial,anyFailures) in
+ let exitStatus = Uicommon.exitCode (anySkipped || anyPartial || anyCancel, anyFailures) in
(exitStatus, failedPaths)
end
+(* ------------ Safe termination between synchronizations ------------ *)
+
+let safeStopReqd, requestSafeStop =
+ let safeStopReqd = ref false in
+ (* [safeStopReqd] can only go from false to true;
+ it must never be changed from true to false. *)
+ let isRequested () = !safeStopReqd
+ and request () = safeStopReqd := true in
+ isRequested, request
+
+(*** Requesting safe termination by signals ***)
+
+let set_signal_noerr signa nm behv =
+ try Sys.set_signal signa behv; true
+ with Invalid_argument _ | Sys_error _ as e ->
+ Trace.logonly
+ ("Warning: " ^ nm ^ " handler not set: " ^ (Printexc.to_string e) ^ "\n");
+ false
+
+let stopPipe = ref None
+
+let setupSafeStop () =
+ if supportSignals then begin
+ let safeStop _ =
+ if not (safeStopReqd ()) then begin
+ requestSafeStop ();
+ (* Interrupt the interruptible sleep *)
+ match !stopPipe with
+ | Some (i, o) -> Unix.close o; Lwt_unix.close i
+ | None -> ()
+ end
+ in
+ Util.blockSignals [Sys.sigusr2] (fun () ->
+ let ok = set_signal_noerr Sys.sigusr2 "SIGUSR2" (Signal_handle safeStop) in
+ if ok then stopPipe := Some (Lwt_unix.pipe_in ~cloexec:true ()))
+ end
+
+let safeStopRequested () =
+ safeStopReqd ()
+
+(*** Sleep interruptible by a termination request ***)
+
+let safeStopWait =
+ let safeStopWait_aux () =
+ let readStop =
+ match !stopPipe with
+ | None -> Lwt.wait ()
+ | Some (i, _) -> Lwt_unix.wait_read i
+ in
+ let readFail = function
+ | Unix.Unix_error (EBADF, _, _) -> Lwt.return (requestSafeStop ())
+ | e -> Lwt.fail e
+ in
+ let rec loop () =
+ Lwt.catch
+ (fun () -> readStop) readFail >>= fun () ->
+ if not (safeStopRequested ()) then
+ Lwt_unix.sleep 0.15 >>= loop
+ else
+ Lwt.return ()
+ in
+ loop ()
+ in
+ let wt = ref None in
+ fun () ->
+ match !wt with
+ | Some t -> t
+ | None -> let t = safeStopWait_aux () in wt := Some t; t
+
+let interruptibleSleepf dt =
+ Lwt_unix.run (Lwt.choose [Lwt_unix.sleep dt; safeStopWait ()])
+let interruptibleSleep dt = interruptibleSleepf (float dt)
+
(* ----------------- Filesystem watching mode ---------------- *)
let watchinterval = 1. (* Minimal interval between two synchronizations *)
@@ -1157,7 +1365,7 @@ module PathMap = Map.Make (Path)
let waitForChangesRoot: Common.root -> unit -> unit Lwt.t =
Remote.registerRootCmd
- "waitForChanges"
+ "waitForChanges" Umarshal.unit Umarshal.unit
(fun (fspath, _) -> Fswatchold.wait (Update.archiveHash fspath))
let waitForChanges t =
@@ -1167,12 +1375,17 @@ let waitForChanges t =
Lwt_unix.run
(Globals.allRootsMap (fun r -> Lwt.return (waitForChangesRoot r ()))
>>= fun l ->
- Lwt.choose (timeout @ l))
+ Lwt.choose (timeout @ l @ [safeStopWait ()]))
end
-let synchronizePathsFromFilesystemWatcher () =
- let rec loop isStart delayInfo =
+let synchronizePathsFromFilesystemWatcher fullintv =
+ let fullinterval = match fullintv with None -> 1e20 | Some i -> float i in
+ let rec loop lastFull delayInfo =
let t = Unix.gettimeofday () in
+ let sinceFull = t -. lastFull in
+ let isFull = sinceFull > fullinterval in
+ let lastFull = if isFull then t else lastFull in
+ let nextFull = lastFull +. fullinterval in
let (delayedPaths, readyPaths) =
PathMap.fold
(fun p (t', _) (delayed, ready) ->
@@ -1180,8 +1393,8 @@ let synchronizePathsFromFilesystemWatcher () =
delayInfo ([], [])
in
let (exitStatus, failedPaths) =
- synchronizeOnce ~wantWatcher:() ~skipRecentFiles:()
- (if isStart then None else Some (readyPaths, delayedPaths))
+ synchronizeOnce ~wantWatcher:true
+ (if isFull then None else Some (readyPaths, delayedPaths))
in
(* After a failure, we retry at once, then use an exponential backoff *)
let delayInfo =
@@ -1199,57 +1412,56 @@ let synchronizePathsFromFilesystemWatcher () =
PathMap.empty
(Safelist.append delayedPaths failedPaths)
in
- Lwt_unix.run (Lwt_unix.sleep watchinterval);
+ interruptibleSleepf watchinterval;
let nextTime =
- PathMap.fold (fun _ (t, d) t' -> min t t') delayInfo 1e20 in
- waitForChanges nextTime;
- loop false delayInfo
+ PathMap.fold (fun _ (t, d) t' -> min t t') delayInfo nextFull in
+ if not (safeStopRequested ()) then waitForChanges nextTime;
+ if safeStopRequested () then exitStatus else loop lastFull delayInfo
in
- loop true PathMap.empty
+ loop 0. PathMap.empty
(* ----------------- Repetition ---------------- *)
let synchronizeUntilNoFailures repeatMode =
+ let wantWatcher = repeatMode in
let rec loop triesLeft pathsOpt =
let (exitStatus, failedPaths) =
- synchronizeOnce
- ?wantWatcher:(if repeatMode then Some () else None) pathsOpt in
- if failedPaths <> [] && triesLeft <> 0 then begin
+ synchronizeOnce ~wantWatcher pathsOpt in
+ if failedPaths <> [] && triesLeft <> 0
+ && not (repeatMode && safeStopRequested ()) then begin
loop (triesLeft - 1) (Some (failedPaths, []))
end else begin
exitStatus
end in
loop (Prefs.read Uicommon.retry) None
-let rec synchronizeUntilDone () =
- let repeatinterval =
- if Prefs.read Uicommon.repeat = "" then -1 else
- try int_of_string (Prefs.read Uicommon.repeat)
- with Failure _ ->
- (* If the 'repeat' pref is not a valid number, switch modes... *)
- if Prefs.read Uicommon.repeat = "watch" then
- synchronizePathsFromFilesystemWatcher()
- else
- raise (Util.Fatal ("Value of 'repeat' preference ("
- ^Prefs.read Uicommon.repeat
- ^") should be either a number or 'watch'\n")) in
-
+let rec synchronizeUntilDone repeatinterval =
let exitStatus = synchronizeUntilNoFailures(repeatinterval >= 0) in
- if repeatinterval < 0 then
+ if repeatinterval < 0 || safeStopRequested () then
exitStatus
else begin
(* Do it again *)
Trace.status (Printf.sprintf
"\nSleeping for %d seconds...\n" repeatinterval);
- Unix.sleep repeatinterval;
- synchronizeUntilDone ()
+ interruptibleSleep repeatinterval;
+ if safeStopRequested () then exitStatus else synchronizeUntilDone repeatinterval
end
+let synchronizeUntilDone () =
+ match Prefs.read Uicommon.repeat with
+ | `Watch -> synchronizePathsFromFilesystemWatcher None
+ | `WatchAndInterval i -> synchronizePathsFromFilesystemWatcher (Some i)
+ | `Interval i -> synchronizeUntilDone i
+ | `NoRepeat -> synchronizeUntilDone (-1)
+ | `Invalid (_, e) -> raise e
+
(* ----------------- Startup ---------------- *)
let profmgrPrefName = "i"
let profmgrPref =
- Prefs.createBool profmgrPrefName false ~local:true
+ Prefs.createBool profmgrPrefName false
+ ~category:(`Basic `CLI)
+ ~cli_only:true
"interactive profile mode (text UI); command-line only"
("Provide this preference in the command line arguments to enable "
^ "interactive profile manager in the text user interface. Currently "
@@ -1284,18 +1496,26 @@ let addProfileKeys list default =
in
addKey 0 [] list
+let scanProfiles () =
+ let wp = !Util.warnPrinter in
+ (* Replace warn printer with something that doesn't quit
+ the UI just for errors in random scanned profiles. *)
+ Util.warnPrinter := Some (fun s -> alwaysDisplay ("Warning: " ^ s ^ "\n\n"));
+ let () = Uicommon.scanProfiles () in
+ Util.warnPrinter := wp
+
let getProfile default =
let cmdArgs = Prefs.scanCmdLine Uicommon.shortUsageMsg in
- Uicommon.scanProfiles ();
if Util.StringMap.mem Uicommon.runTestsPrefName cmdArgs ||
not (Util.StringMap.mem profmgrPrefName cmdArgs) then
Some default
else
+ let () = scanProfiles () in
if (List.length !Uicommon.profilesAndRoots) > 10 then begin
Trace.log (Format.sprintf "You have too many profiles in %s \
for interactive selection. Please specify profile \
or roots on command line.\n"
- (System.fspathToPrintString Util.unisonDir));
+ Util.unisonDir);
Trace.log "The profile names are:\n";
Safelist.iter (fun (p, _) -> Trace.log (Format.sprintf " %s\n" p))
!Uicommon.profilesAndRoots;
@@ -1372,27 +1592,48 @@ let rec start interface =
if interface <> Uicommon.Text then
Util.msg "This Unison binary only provides the text GUI...\n";
begin try
+ Sys.catch_break true;
(* Just to make sure something is there... *)
setWarnPrinterForInitialization();
- Uicommon.uiInit
- ~reportError:
- (fun s -> Util.msg "%s%s\n\n%s\n" Uicommon.shortUsageMsg profmgrUsageMsg s; exit 1)
- ~tryAgainOrQuit:
- (fun s -> Util.msg "%s" Uicommon.shortUsageMsg; exit 1)
- ~displayWaitMessage:
- (fun () -> setWarnPrinter();
- if Prefs.read silent then Prefs.set Trace.terse true;
- if not (Prefs.read silent)
- then Util.msg "%s\n" (Uicommon.contactingServerMsg()))
- ~getProfile:
- (fun () -> let prof = getProfile "default" in restoreTerminal(); prof)
- ~getFirstRoot:
- (fun () -> Util.msg "%s%s\n" Uicommon.shortUsageMsg profmgrUsageMsg; exit 1)
- ~getSecondRoot:
- (fun () -> Util.msg "%s%s\n" Uicommon.shortUsageMsg profmgrUsageMsg; exit 1)
- ~termInteract:
- None
- ();
+ setupSafeStop ();
+ let errorOut s =
+ Util.msg "%s%s%s\n" Uicommon.shortUsageMsg profmgrUsageMsg s;
+ exit 1
+ in
+ let profileName = match Uicommon.uiInitClRootsAndProfile () with
+ | Error s -> errorOut ("\n\n" ^ s)
+ | Ok None ->
+ let profile = getProfile "default" in
+ let () = restoreTerminal () in
+ begin
+ match profile with
+ | None -> exit 0
+ | Some x -> x
+ end
+ | Ok (Some s) -> s
+ in
+ Uicommon.initPrefs ~profileName ~promptForRoots:(fun () -> errorOut "") ()
+ with e ->
+ handleException e;
+ exit Uicommon.fatalExit
+ end;
+
+ (* Uncaught exceptions up to this point are non-recoverable, treated
+ as permanent and will inevitably exit the process. Uncaught exceptions
+ from here onwards are treated as potentially temporary or recoverable.
+ The process does not have to exit if in repeat mode and can try again. *)
+ begin try
+ if Prefs.read silent then Prefs.set Trace.terse true;
+
+ Uicommon.connectRoots ~displayWaitMessage ();
+
+ if Prefs.read Uicommon.testServer then exit 0;
+
+ (* Run unit tests if requested *)
+ if Prefs.read Uicommon.runtests then begin
+ !Uicommon.testFunction ();
+ exit 0
+ end;
(* Some preference settings imply others... *)
if Prefs.read silent then begin
@@ -1401,7 +1642,7 @@ let rec start interface =
Prefs.set dumbtty true;
Trace.sendLogMsgsToStderr := false;
end;
- if Prefs.read Uicommon.repeat <> "" then begin
+ if Prefs.read Uicommon.repeat <> `NoRepeat then begin
Prefs.set Globals.batch true;
end;
setColorPreference ();
@@ -1426,23 +1667,38 @@ let rec start interface =
handleException Sys.Break;
exit Uicommon.fatalExit
end
+ | e when breakRepeat e -> begin
+ handleException e;
+ exit Uicommon.fatalExit
+ end
| e -> begin
(* If any other bad thing happened and the -repeat preference is
set, then restart *)
- (* JV: it seems safer to just abort here, as we don't know in which
- state Unison is; for instance, if the connection is lost, there
- is no point in restarting as Unison will currently not attempt to
- establish a new connection. *)
handleException e;
- if false (*Prefs.read Uicommon.repeat <> ""*) then begin
- Util.msg "Restarting in 10 seconds...\n";
- Unix.sleep 10;
- start interface
- end else
- exit Uicommon.fatalExit
+ if Prefs.read Uicommon.repeat = `NoRepeat
+ || Prefs.read Uicommon.runtests then
+ exit Uicommon.fatalExit;
+
+ Util.msg "\nRestarting in 10 seconds...\n\n";
+ begin try interruptibleSleep 10 with Sys.Break -> exit Uicommon.fatalExit end;
+ if safeStopRequested () then exit Uicommon.fatalExit else start interface
end
end
+(* Though in some cases we could, there's no point in recovering
+ and continuing at any of these exceptions. *)
+and breakRepeat = function
+ (* Programming errors *)
+ | Assert_failure _
+ | Match_failure _
+ | Invalid_argument _
+ | Fun.Finally_raised _
+ (* Async exceptions *)
+ | Out_of_memory
+ | Stack_overflow
+ | Sys.Break -> true
+ | _ -> false
+
let defaultUi = Uicommon.Text
end
diff --git a/src/unicode.mli b/src/unicode.mli
index 2d82a6e..6112a1b 100644
--- a/src/unicode.mli
+++ b/src/unicode.mli
@@ -36,7 +36,7 @@ val from_utf_16 : string -> string
val to_utf_16_filename : string -> string
val from_utf_16_filename : string -> string
-(* Check wether the string contains only well-formed UTF-8 characters *)
+(* Check whether the string contains only well-formed UTF-8 characters *)
val check_utf_8 : string -> bool
(* Convert a string to UTF-8 by keeping all UTF-8 characters unchanged
diff --git a/src/update.ml b/src/update.ml
index a77b710..3548603 100644
--- a/src/update.ml
+++ b/src/update.ml
@@ -25,7 +25,8 @@ let debugignore = Trace.debug "ignore"
let ignoreArchives =
Prefs.createBool "ignorearchives" false
- "!ignore existing archive files"
+ ~category:(`Advanced `Archive)
+ "ignore existing archive files"
("When this preference is set, Unison will ignore any existing "
^ "archive files and behave as though it were being run for the first "
^ "time on these replicas. It is "
@@ -40,31 +41,68 @@ let ignoreArchives =
archive changes: old archives will then automatically be discarded. (We
do not use the unison version number for this because usually the archive
representation does not change between unison versions.) *)
-(*FIX: also change Fileinfo.stamp to drop the info.ctime component, next
- time the format is modified *)
-(*FIX: also make Jerome's suggested change about file times (see his mesg in
- unison-pending email folder). *)
-(*FIX: we could also drop the use of 8.3-style filenames on Windows, next
- time the format is changed *)
-(* FIX: use a special stamp rather than the current hack to leave a flag
- in the archive when a file transfer fails so as to turn off fastcheck
- for this file on the next sync. *)
(*FIX: consider changing the way case-sensitivity mode is stored in
the archive *)
-(*FIX: we should use only one Marshal.from_channel *)
-let archiveFormat = 22
+let archiveFormat = 23
module NameMap = MyMap.Make (Name)
+(* IMPORTANT!
+ This is the 2.51-compatible version of type [archive]. It must always remain
+ exactly the same as the type [archive] in version 2.51.5. This means that if
+ any of the types it is composed of changes, for each changed type a 2.51-
+ compatible version must be created (like has been done for [Props.t]). *)
+type archive251 =
+ ArchiveDir of Props.t251 * archive251 NameMap.t
+ | ArchiveFile of Props.t251 * Os.fullfingerprint * Fileinfo.stamp251 * Osx.ressStamp
+ | ArchiveSymlink of string
+ | NoArchive
+
type archive =
ArchiveDir of Props.t * archive NameMap.t
| ArchiveFile of Props.t * Os.fullfingerprint * Fileinfo.stamp * Osx.ressStamp
| ArchiveSymlink of string
| NoArchive
+let marchive_rec marchive =
+ Umarshal.(sum4
+ (prod2 Props.m (NameMap.m marchive) id id)
+ (prod4 Props.m Os.mfullfingerprint Fileinfo.mstamp Osx.mressStamp id id)
+ string unit
+ (function
+ | ArchiveDir (a, b) -> I41 (a, b)
+ | ArchiveFile (a, b, c, d) -> I42 (a, b, c, d)
+ | ArchiveSymlink a -> I43 a
+ | NoArchive -> I44 ())
+ (function
+ | I41 (a, b) -> ArchiveDir (a, b)
+ | I42 (a, b, c, d) -> ArchiveFile (a, b, c, d)
+ | I43 a -> ArchiveSymlink a
+ | I44 () -> NoArchive))
+
+let marchive = Umarshal.rec1 marchive_rec
+
(* For directories, only the permissions part of the file description (desc)
is used for synchronization at the moment. *)
+let rec to_compat251 (arch : archive) : archive251 =
+ match arch with
+ | ArchiveDir (desc, children) ->
+ ArchiveDir (Props.to_compat251 desc, NameMap.map to_compat251 children)
+ | ArchiveFile (desc, dig, stamp, ress) ->
+ ArchiveFile (Props.to_compat251 desc, dig, Fileinfo.stamp_to_compat251 stamp, ress)
+ | ArchiveSymlink content -> ArchiveSymlink content
+ | NoArchive -> NoArchive
+
+let rec of_compat251 (arch : archive251) : archive =
+ match arch with
+ | ArchiveDir (desc, children) ->
+ ArchiveDir (Props.of_compat251 desc, NameMap.map of_compat251 children)
+ | ArchiveFile (desc, dig, stamp, ress) ->
+ ArchiveFile (Props.of_compat251 desc, dig, Fileinfo.stamp_of_compat251 stamp, ress)
+ | ArchiveSymlink content -> ArchiveSymlink content
+ | NoArchive -> NoArchive
+
let archive2string = function
ArchiveDir(_) -> "ArchiveDir"
| ArchiveFile(_) -> "ArchiveFile"
@@ -105,7 +143,9 @@ let archive2string = function
reasons. *)
let rootsName : string Prefs.t =
- Prefs.createString "rootsName" "" "*Canonical root names" ""
+ Prefs.createString "rootsName" ""
+ ~category:(`Internal `Pseudo)
+ "*Canonical root names" ""
let getRootsName () = Prefs.read rootsName
@@ -117,7 +157,8 @@ let foundArchives = ref true
let rootAliases : string list Prefs.t =
Prefs.createStringList "rootalias"
- "!register alias for canonical root names"
+ ~category:(`Advanced `General)
+ "register alias for canonical root names"
("When calculating the name of the archive files for a given pair of roots,"
^ " Unison replaces any roots matching the left-hand side of any rootalias"
^ " rule by the corresponding right-hand side.")
@@ -156,15 +197,6 @@ let storeRootsName () =
(Globals.rootsInCanonicalOrder())))) in
Prefs.set rootsName n
-(* How many characters of the filename should be used for the unique id of
- the archive? On Unix systems, we use the full fingerprint (32 bytes).
- On windows systems, filenames longer than 8 bytes can cause problems, so
- we chop off all but the first 6 from the fingerprint. *)
-let significantDigits =
- match Util.osType with
- `Win32 -> 6
- | `Unix -> 32
-
let thisRootsGlobalName (fspath: Fspath.t): string =
root2stringOrAlias (Common.Remote (Os.myCanonicalHostName ()), fspath)
@@ -173,11 +205,26 @@ let thisRootsGlobalName (fspath: Fspath.t): string =
(* The status of an archive *)
type archiveVersion = MainArch | NewArch | ScratchArch | Lock | FPCache
+let marchiveVersion = Umarshal.(sum5 unit unit unit unit unit
+ (function
+ | MainArch -> I51 ()
+ | NewArch -> I52 ()
+ | ScratchArch -> I53 ()
+ | Lock -> I54 ()
+ | FPCache -> I55 ())
+ (function
+ | I51 () -> MainArch
+ | I52 () -> NewArch
+ | I53 () -> ScratchArch
+ | I54 () -> Lock
+ | I55 () -> FPCache))
+
let showArchiveName =
Prefs.createBool "showarchive" false
- "!show 'true names' (for rootalias) of roots and archive"
+ ~category:(`Advanced `General)
+ "show 'true names' (for rootalias) of roots and archive"
("When this preference is set, Unison will print out the 'true names'"
- ^ "of the roots, in the same form as is expected by the {\\tt rootalias}"
+ ^ "of the roots, in the same form as is expected by the {\\tt rootalias} "
^ "preference.")
let _ = Prefs.alias showArchiveName "showArchiveName"
@@ -193,7 +240,7 @@ let archiveHash fspath =
debugverbose (fun()-> Util.msg "Archive name is %s; hashcode is %s\n" n d);
if Prefs.read showArchiveName then
Util.msg "Archive name is %s; hashcode is %s\n" n d;
- (String.sub d 0 significantDigits)
+ d
(* We include the hash part of the archive name in the names of temp files
created by this run of Unison. The reason for this is that, during
@@ -213,6 +260,39 @@ let archiveName fspath (v: archiveVersion): string * string =
(Printf.sprintf "%s%s" temp n,
thisRootsGlobalName fspath)
+(* IMPORTANT!
+ This is the 2.51-compatible version of [archiveName]. It must produce
+ exactly the same result as [archiveName] would in version 2.51.5.
+ If code changes elsewhere make this function produce a different result then
+ it must be updated accordingly to again return the 2.51-compatible result.
+
+ This code is here only to support a smooth upgrade from versions <= 2.51.5
+ It is safe to delete it when that support is no longer required. *)
+let archiveName251 fspath (v: archiveVersion): string * string =
+ let archiveHash251 fspath =
+ (* How many characters of the filename should be used for the unique id of
+ the archive? On Unix systems, we use the full fingerprint (32 bytes).
+ On windows systems, filenames longer than 8 bytes can cause problems, so
+ we chop off all but the first 6 from the fingerprint. *)
+ let significantDigits =
+ match Util.osType with
+ `Win32 -> 6
+ | `Unix -> 32
+ in
+ let thisRoot = thisRootsGlobalName fspath in
+ let r = Prefs.read rootsName in
+ let n = Printf.sprintf "%s;%s;22" thisRoot r in
+ let d = Fingerprint.toString (Fingerprint.string n) in
+ (String.sub d 0 significantDigits)
+ in
+ let n = archiveHash251 fspath in
+ let temp = match v with
+ MainArch -> "ar" | NewArch -> "tm" | ScratchArch -> "sc"
+ | Lock -> "lk" | FPCache -> "fp"
+ in
+ (Printf.sprintf "%s%s" temp n,
+ thisRootsGlobalName fspath)
+
(*****************************************************************************)
(* SANITY CHECKS *)
@@ -262,6 +342,48 @@ let rec checkArchive
| NoArchive ->
135
+(* IMPORTANT!
+ This is the 2.51-compatible version of [checkArchive]. It must produce
+ exactly the same result as [checkArchive] in version 2.51.5.
+ If code changes elsewhere make this function produce a different result then
+ it must be updated accordingly to again return the 2.51-compatible result. *)
+let rec checkArchive251
+ (top: bool) (path: Name.t list) (arch: archive251) (h: int): int =
+ match arch with
+ ArchiveDir (desc, children) ->
+ begin match NameMap.validate children with
+ `Ok ->
+ ()
+ | `Duplicate nm ->
+ let path =
+ List.fold_right (fun n p -> Path.child p n) path Path.empty in
+ raise
+ (Util.Fatal (Printf.sprintf
+ "Corrupted archive: \
+ the file %s occurs twice in path %s"
+ (Name.toString nm) (Path.toString path)));
+ | `Invalid (nm, nm') ->
+ let path =
+ List.fold_right (fun n p -> Path.child p n) path Path.empty in
+ raise
+ (Util.Fatal (Printf.sprintf
+ "Corrupted archive: the files %s and %s are not \
+ correctly ordered in directory %s"
+ (Name.toString nm) (Name.toString nm')
+ (Path.toString path)));
+ end;
+ NameMap.fold
+ (fun n a h ->
+ Uutil.hash2 (Name.hash n)
+ (checkArchive251 false (n :: path) a h))
+ children (Props.hash251 desc h)
+ | ArchiveFile (desc, dig, _, ress) ->
+ Uutil.hash2 (Uutil.hash dig) (Props.hash251 desc h)
+ | ArchiveSymlink content ->
+ Uutil.hash2 (Uutil.hash content) h
+ | NoArchive ->
+ 135
+
(* [archivesIdentical l] returns true if all elements in [l] are the
same and distinct from None *)
let archivesIdentical l =
@@ -273,7 +395,7 @@ let (archiveNameOnRoot
: Common.root -> archiveVersion -> (string * string * bool) Lwt.t)
=
Remote.registerRootCmd
- "archiveName"
+ "archiveName" marchiveVersion Umarshal.(prod3 string string bool id id)
(fun (fspath, v) ->
let (name,_) = archiveName fspath v in
Lwt.return
@@ -290,11 +412,18 @@ let (archiveNameOnRoot
archiveFormat and root names. They appear in the header of the archive
files *)
let formatString = Printf.sprintf "Unison archive format %d" archiveFormat
+let compatFormatString = "Unison archive format 22"
+(* Every supported version released prior to the new archive encoding
+ uses this archive format string. *)
let verboseArchiveName thisRoot =
Printf.sprintf "Archive for root %s synchronizing roots %s"
thisRoot (Prefs.read rootsName)
+let mpayload = Umarshal.prod4
+ marchive Umarshal.int Umarshal.string Proplist.m
+ Umarshal.id Umarshal.id
+
(* Load in the archive in [fspath]; check that archiveFormat (first line)
and roots (second line) match skip the third line (time stamp), and read
in the archive *)
@@ -305,6 +434,10 @@ let loadArchiveLocal fspath (thisRoot: string) :
Util.convertUnixErrorsToFatal "loading archive" (fun () ->
if System.file_exists fspath then
let c = System.open_in_bin fspath in
+ let close_on_error f =
+ try f () with e -> close_in_noerr c; raise e
+ in
+ close_on_error (fun () ->
let header = input_line c in
(* Sanity check on archive format *)
if header<>formatString then begin
@@ -326,12 +459,88 @@ let loadArchiveLocal fspath (thisRoot: string) :
I will delete the old archive and start from scratch.\n"
roots (verboseArchiveName thisRoot));
None
+ end else
+ let featrs =
+ match String.split_on_char '\030' (input_line c) with
+ | [] -> [] (* This is not possible, but compiler doesn't know it *)
+ | _ :: rest -> (* Ignore the first part of the timestamp line *)
+ Safelist.filter (fun x -> x <> "") rest
+ in
+ let commonFts = Features.inter featrs (Features.all ()) in
+ if Safelist.length featrs <> Safelist.length commonFts then
+ raise
+ (Util.Fatal ("Archive format mismatch: the archive was stored with \
+ features that are currently not available.\n\
+ Missing features: "
+ ^ (String.concat ", " (Safelist.filter
+ (fun x -> not (Safelist.mem x commonFts)) featrs))
+ ^ "\nArchive file: "
+ ^ fspath ^ "\n\
+ You should either upgrade Unison or invoke Unison \
+ once with -ignorearchives flag and then try again."));
+ try
+ (* Temporarily enable features that were used when storing the archive
+ to make sure the types are correct when loading the archive. *)
+ let negotiatedFts = Features.getEnabled () in
+ let () = Features.setEnabled commonFts in
+ (* Load the datastructure *)
+ let ((archive, hash, magic, properties) : archive * int * string * Proplist.t) =
+ Umarshal.from_channel mpayload c in
+ close_in c;
+ (* Restore to the negotiated features *)
+ let () = Features.setEnabled negotiatedFts in
+ Some (archive, hash, magic, properties)
+ with Failure s | Umarshal.Error s -> raise (Util.Fatal (Printf.sprintf
+ "Archive file seems damaged (%s): \
+ use the -ignorearchives option, or \
+ throw away archives on both machines and try again" s)))
+ else
+ (debug (fun() ->
+ Util.msg "Archive %s not found\n"
+ (System.fspathToDebugString fspath));
+ None))
+
+(* IMPORTANT!
+ This is the 2.51-compatible version of [loadArchiveLocal]. It must remain
+ capable of reading archives written by version 2.51.5. Be careful, as code
+ changes elsewhere may break this function unintentionally.
+
+ This code is here only to support a smooth upgrade from versions <= 2.51.5
+ It is safe to delete it when that support is no longer required. *)
+let loadArchiveLocal251 fspath (thisRoot: string) :
+ (archive * int * string * Proplist.t) option =
+ debug (fun() ->
+ Util.msg "Loading archive from %s\n" (System.fspathToDebugString fspath));
+ Util.convertUnixErrorsToFatal "loading archive" (fun () ->
+ if System.file_exists fspath then
+ let c = System.open_in_bin fspath in
+ let header = input_line c in
+ (* Sanity check on archive format *)
+ if header<>compatFormatString then begin
+ debug (fun () ->
+ Util.msg
+ "Archive format mismatch: found\n '%s'\n\
+ but expected\n '%s'.\n\
+ I will delete the old archive and start from scratch.\n"
+ header compatFormatString);
+ None
+ end else
+ let roots = input_line c in
+ (* Sanity check on roots. *)
+ if roots <> verboseArchiveName thisRoot then begin
+ debug (fun () ->
+ Util.msg
+ "Archive mismatch: found\n '%s'\n\
+ but expected\n '%s'.\n\
+ I will delete the old archive and start from scratch.\n"
+ roots (verboseArchiveName thisRoot));
+ None
end else
(* Throw away the timestamp line *)
let _ = input_line c in
(* Load the datastructure *)
try
- let ((archive, hash, magic) : archive * int * string) =
+ let ((archive, hash, magic) : archive251 * int * string) =
Marshal.from_channel c in
let properties =
try
@@ -341,7 +550,7 @@ let loadArchiveLocal fspath (thisRoot: string) :
Proplist.empty
in
close_in c;
- Some (archive, hash, magic, properties)
+ Some (of_compat251 archive, hash, magic, properties)
with Failure s -> raise (Util.Fatal (Printf.sprintf
"Archive file seems damaged (%s): \
use the -ignorearchives option, or throw away archives on both machines and try again" s))
@@ -360,35 +569,60 @@ let storeArchiveLocal fspath thisRoot archive hash magic properties =
System.open_out_gen
[Open_wronly; Open_creat; Open_trunc; Open_binary] 0o600 fspath
in
+ let close_on_error f =
+ try f () with e -> close_out_noerr c; raise e
+ in
+ close_on_error (fun () ->
output_string c formatString;
output_string c "\n";
output_string c (verboseArchiveName thisRoot);
output_string c "\n";
- (* This third line is purely informative *)
- output_string c (Printf.sprintf "Written at %s - %s mode\n"
+ (* First part of third line is purely informative *)
+ output_string c (Printf.sprintf "Written at %s - %s mode"
(Util.time2string (Util.time()))
((Case.ops())#modeDesc));
- Marshal.to_channel c (archive, hash, magic) [Marshal.No_sharing];
- output_char c '\000'; (* Marker that indicates that the archive
- is followed by a property list *)
- Marshal.to_channel c properties [Marshal.No_sharing];
- close_out c)
+ (* Second part of third line is not informative.
+ Record the features that change the archive format and must exist to
+ be able to load the archive later. *)
+ output_string c "\030";
+ output_string c (String.concat "\030" (Features.changingArchiveFormat ()));
+ output_string c "\n";
+ Umarshal.to_channel mpayload c (archive, hash, magic, properties);
+ close_out c))
-(* Remove the archieve under the root path [fspath] with archiveVersion [v] *)
+(* IMPORTANT! This val is here for smoother upgrades from versions <= 2.51.5
+ It can be removed when this compatibility is no longer required. *)
+let loadedCompatArchive = ref []
+
+(* Remove the archive under the root path [fspath] with archiveVersion [v] *)
let removeArchiveLocal ((fspath: Fspath.t), (v: archiveVersion)): unit Lwt.t =
- Lwt.return
- (let (name,_) = archiveName fspath v in
+ let f' name = Lwt.return (
let fspath = Util.fileInUnisonDir name in
debug (fun() ->
Util.msg "Removing archive %s\n" (System.fspathToDebugString fspath));
Util.convertUnixErrorsToFatal "removing archive" (fun () ->
try System.unlink fspath
with Unix.Unix_error (Unix.ENOENT, _, _) -> ()))
+ in
+ let ret = f' (fst (archiveName fspath v)) in
+ (* IMPORTANT! This code is for smoother upgrades from versions <= 2.51.5
+ It can be removed when this compatibility is no longer required. *)
+ if Safelist.exists (fun x -> x = fspath) !loadedCompatArchive then begin
+ loadedCompatArchive := Safelist.filter (fun x -> x <> fspath)
+ !loadedCompatArchive;
+ (try
+ ignore (f' (fst (archiveName251 fspath MainArch)))
+ with Util.Fatal _ -> ());
+ try
+ ignore (f' (fst (archiveName251 fspath FPCache)))
+ with Util.Fatal _ -> ()
+ end;
+ ret
(* [removeArchiveOnRoot root v] invokes [removeArchive fspath v] on the
server, where [fspath] is the path to root on the server *)
let removeArchiveOnRoot: Common.root -> archiveVersion -> unit Lwt.t =
- Remote.registerRootCmd "removeArchive" removeArchiveLocal
+ Remote.registerRootCmd "removeArchive" marchiveVersion Umarshal.unit removeArchiveLocal
(* [commitArchive (fspath, ())] commits the archive for [fspath] by changing
the filenames from ScratchArch-ones to a NewArch-ones *)
@@ -406,7 +640,15 @@ let commitArchiveLocal ((fspath: Fspath.t), ())
(* [commitArchiveOnRoot root v] invokes [commitArchive fspath v] on the
server, where [fspath] is the path to root on the server *)
let commitArchiveOnRoot: Common.root -> unit -> unit Lwt.t =
- Remote.registerRootCmd "commitArchive" commitArchiveLocal
+ Remote.registerRootCmd "commitArchive" Umarshal.unit Umarshal.unit commitArchiveLocal
+
+let getArchiveInfo f =
+ Util.convertUnixErrorsToTransient "querying file information"
+ (fun () ->
+ try
+ Some (System.stat f)
+ with Unix.Unix_error ((Unix.ENOENT | Unix.ENOTDIR), _, _) ->
+ None)
let archiveInfoCache = Hashtbl.create 7
(* [postCommitArchive (fspath, v)] finishes the committing protocol by
@@ -432,20 +674,27 @@ let postCommitArchiveLocal (fspath,())
let outFd =
System.open_out_gen
[Open_wronly; Open_creat; Open_trunc; Open_binary] 0o600 fto in
+ let close_on_error f =
+ try f () with e -> close_out_noerr outFd; raise e
+ in
+ close_on_error (fun () ->
System.chmod fto 0o600; (* In case the file already existed *)
let inFd = System.open_in_bin ffrom in
+ let close_on_error f =
+ try f () with e -> close_in_noerr inFd; raise e
+ in
+ close_on_error (fun () ->
Uutil.readWrite inFd outFd (fun _ -> ());
close_in inFd;
- close_out outFd
+ close_out outFd))
end;
let arcFspath = Util.fileInUnisonDir toname in
- let info = Fileinfo.get' arcFspath in
- Hashtbl.replace archiveInfoCache thisRoot info))
+ Hashtbl.replace archiveInfoCache thisRoot (getArchiveInfo arcFspath)))
(* [postCommitArchiveOnRoot root v] invokes [postCommitArchive fspath v] on
the server, where [fspath] is the path to root on the server *)
let postCommitArchiveOnRoot: Common.root -> unit -> unit Lwt.t =
- Remote.registerRootCmd "postCommitArchive" postCommitArchiveLocal
+ Remote.registerRootCmd "postCommitArchive" Umarshal.unit Umarshal.unit postCommitArchiveLocal
(*************************************************************************)
@@ -477,24 +726,74 @@ let setArchivePropsLocal (thisRoot: string) (props: Proplist.t) =
Hashtbl.replace archivePropCache thisRoot props
let fileUnchanged oldInfo newInfo =
- oldInfo.Fileinfo.typ = `FILE && newInfo.Fileinfo.typ = `FILE
- &&
- Props.same_time oldInfo.Fileinfo.desc newInfo.Fileinfo.desc
- &&
- Props.length oldInfo.Fileinfo.desc = Props.length newInfo.Fileinfo.desc
- &&
- match Fileinfo.stamp oldInfo, Fileinfo.stamp newInfo with
- Fileinfo.InodeStamp in1, Fileinfo.InodeStamp in2 -> in1 = in2
- | Fileinfo.CtimeStamp _, Fileinfo.CtimeStamp _ -> true
- | _ -> false
-
-let archiveUnchanged fspath newInfo =
- let (arcName, thisRoot) = archiveName fspath MainArch in
+ match oldInfo, newInfo with
+ | None, _ | _, None -> false
+ | Some o, Some n ->
+ o.Unix.LargeFile.st_kind = S_REG && n.Unix.LargeFile.st_kind = S_REG
+ &&
+ o.Unix.LargeFile.st_mtime = n.Unix.LargeFile.st_mtime
+ &&
+ o.Unix.LargeFile.st_size = n.Unix.LargeFile.st_size
+ &&
+ (o.Unix.LargeFile.st_ino = n.Unix.LargeFile.st_ino
+ ||
+ Prefs.read Fileinfo.ignoreInodeNumbers
+ ||
+ not (System.hasInodeNumbers ()))
+
+let archiveUnchanged thisRoot newInfo =
try
fileUnchanged (Hashtbl.find archiveInfoCache thisRoot) newInfo
with Not_found ->
false
+
+(*************************************************************************)
+(* Shared props data in archive *)
+(*************************************************************************)
+
+let debugpd = Util.debug "propsdata+"
+
+let propsDataKey = Proplist.register "props data" Props.Data.m
+
+let prunePropsdata archive =
+ (* Do propsdata-GC by keeping live props *)
+ let rec prunePropsdata = function
+ | ArchiveDir (props, children) ->
+ Props.Data.gcKeep props;
+ NameMap.iter (fun _ c -> prunePropsdata c) children
+ | ArchiveFile (props, _, _, _) ->
+ Props.Data.gcKeep props
+ | ArchiveSymlink _ -> ()
+ | NoArchive -> ()
+ in
+ let t0 = Unix.gettimeofday () in
+ debugpd (fun () -> Util.msg "Pruning shared props data...\n");
+ Props.Data.gcInit ();
+ prunePropsdata archive;
+ let pd = Props.Data.gcDone () in
+ debugpd (fun () ->
+ let t1 = Unix.gettimeofday () in
+ Util.msg "Shared props data pruning took %.3f milliseconds\n"
+ ((t1 -. t0) *. 1000.));
+ pd
+
+let externArchivePropsdata archive props =
+ match prunePropsdata archive with
+ | [] -> props
+ | pd -> Proplist.add propsDataKey pd props
+
+let internArchivePropsdata props =
+ let t0 = Unix.gettimeofday () in
+ debugpd (fun () -> Util.msg "Restoring shared props data...\n");
+ let data = try Proplist.find propsDataKey props with Not_found -> [] in
+ Props.Data.intern data;
+ debugpd (fun () ->
+ let t1 = Unix.gettimeofday () in
+ Util.msg "Shared props data restoring took %.3f milliseconds\n"
+ ((t1 -. t0) *. 1000.))
+
+
(*************************************************************************
DUMPING ARCHIVES
*************************************************************************)
@@ -523,6 +822,10 @@ let dumpArchiveLocal (fspath,()) =
debug (fun () -> Printf.eprintf "Dumping archive into `%s'\n"
(System.fspathToDebugString f));
let ch = System.open_out_gen [Open_wronly; Open_creat; Open_trunc] 0o600 f in
+ let close_on_error f =
+ try f () with e -> close_out_noerr ch; raise e
+ in
+ close_on_error (fun () ->
let (outfn,flushfn) = Format.get_formatter_output_functions () in
Format.set_formatter_out_channel ch;
Format.printf "Contents of archive for %s\n" root;
@@ -531,11 +834,11 @@ let dumpArchiveLocal (fspath,()) =
Format.print_flush();
Format.set_formatter_output_functions outfn flushfn;
flush ch;
- close_out ch;
+ close_out ch);
Lwt.return ()
let dumpArchiveOnRoot : Common.root -> unit -> unit Lwt.t =
- Remote.registerRootCmd "dumpArchive" dumpArchiveLocal
+ Remote.registerRootCmd "dumpArchive" Umarshal.unit Umarshal.unit dumpArchiveLocal
(*****************************************************************************)
(* ARCHIVE CASE CONVERSION *)
@@ -543,10 +846,10 @@ let dumpArchiveOnRoot : Common.root -> unit -> unit Lwt.t =
(* Stamp for marking unchange directories *)
let dirStampKey : Props.dirChangedStamp Proplist.key =
- Proplist.register "unchanged directory stamp"
+ Proplist.register "unchanged directory stamp" Props.mdirChangedStamp
(* Property containing a description of the archive case sensitivity mode *)
-let caseKey : string Proplist.key = Proplist.register "case mode"
+let caseKey : string Proplist.key = Proplist.register "case mode" Umarshal.string
(* Turn a case sensitive archive into a case insensitive archive.
Directory children are resorted and duplicates are removed.
@@ -579,7 +882,7 @@ let makeCaseSensitive thisRoot =
(getArchiveProps thisRoot)))
let makeCaseSensitiveOnRoot =
- Remote.registerRootCmd "makeCaseSensitive"
+ Remote.registerRootCmd "makeCaseSensitive" Umarshal.unit Umarshal.unit
(fun (fspath, ()) ->
makeCaseSensitive (thisRootsGlobalName fspath);
Lwt.return ())
@@ -664,6 +967,7 @@ let setArchiveData thisRoot fspath (arch, hash, magic, properties) info =
let properties = Proplist.add caseKey archMode properties in
setArchiveLocal thisRoot arch;
setArchivePropsLocal thisRoot properties;
+ internArchivePropsdata properties;
Hashtbl.replace archiveInfoCache thisRoot info;
if archMode <> curMode then populateCacheFromArchive fspath arch;
Lwt.return (Some (hash, magic))
@@ -672,13 +976,14 @@ let clearArchiveData thisRoot =
setArchiveLocal thisRoot NoArchive;
setArchivePropsLocal thisRoot
(Proplist.add caseKey (Case.ops ())#modeDesc Proplist.empty);
+ internArchivePropsdata Proplist.empty;
Hashtbl.remove archiveInfoCache thisRoot;
Lwt.return (Some (0, ""))
(* Load (main) root archive and cache it on the given server *)
let loadArchiveOnRoot: Common.root -> bool -> (int * string) option Lwt.t =
Remote.registerRootCmd
- "loadArchive"
+ "loadArchive" Umarshal.bool Umarshal.(option (prod2 int string id id))
(fun (fspath, optimistic) ->
let (arcName,thisRoot) = archiveName fspath MainArch in
let arcFspath = Util.fileInUnisonDir arcName in
@@ -700,38 +1005,59 @@ let loadArchiveOnRoot: Common.root -> bool -> (int * string) option Lwt.t =
then
Lwt.return None
else
- let (arcName,thisRoot) = archiveName fspath MainArch in
- let arcFspath = Util.fileInUnisonDir arcName in
- let info = Fileinfo.get' arcFspath in
- if archiveUnchanged fspath info then
+ let info = getArchiveInfo arcFspath in
+ if archiveUnchanged thisRoot info then
(* The archive is unchanged. So, we don't need to do
anything. *)
Lwt.return (Some (0, ""))
else begin
match loadArchiveLocal arcFspath thisRoot with
Some archData ->
- let info' = Fileinfo.get' arcFspath in
+ let info' = getArchiveInfo arcFspath in
if fileUnchanged info info' then
setArchiveData thisRoot fspath archData info
else
(* The archive was modified during loading. We fail. *)
Lwt.return None
| None ->
- (* No archive found *)
- Lwt.return None
+ (* No archive found, try 2.51 upgrade mode *)
+ (* IMPORTANT! This code is for smoother upgrades from
+ versions <= 2.51.5
+ It can be removed when this compatibility is no longer
+ required. *)
+ let (arcName, thisRoot) = archiveName251 fspath MainArch in
+ let arcFspath = Util.fileInUnisonDir arcName in
+ match loadArchiveLocal251 arcFspath thisRoot with
+ | Some archData ->
+ loadedCompatArchive := fspath :: !loadedCompatArchive;
+ setArchiveData thisRoot fspath archData
+ (getArchiveInfo arcFspath)
+ | None -> Lwt.return None
end
end else begin
match loadArchiveLocal arcFspath thisRoot with
Some archData ->
- setArchiveData thisRoot fspath archData (Fileinfo.get' arcFspath)
+ setArchiveData thisRoot fspath archData (getArchiveInfo arcFspath)
| None ->
- (* No archive found *)
- clearArchiveData thisRoot
+ (* No archive found, try 2.51 upgrade mode *)
+ (* IMPORTANT! This code is for smoother upgrades from
+ versions <= 2.51.5
+ It can be removed when this compatibility is no longer
+ required. *)
+ let (arcName, thisRoot) = archiveName251 fspath MainArch in
+ let arcFspath = Util.fileInUnisonDir arcName in
+ match loadArchiveLocal251 arcFspath thisRoot with
+ | Some archData ->
+ loadedCompatArchive := fspath :: !loadedCompatArchive;
+ setArchiveData thisRoot fspath archData (getArchiveInfo arcFspath)
+ | None -> clearArchiveData thisRoot
end)
let dumpArchives =
Prefs.createBool "dumparchives" false
- "*dump contents of archives just after loading"
+ ~category:`Expert
+ ~cli_only:true
+ "dump contents of archives just after loading"
("When this preference is set, Unison will create a file unison.dump "
^ "on each host, containing a text summary of the archive, immediately "
^ "after loading it.")
@@ -750,13 +1076,14 @@ let loadArchives (optimistic: bool) =
^ "OCaml version 3 and one with OCaml version 4.\n"
^ "\n"
^ "If this is not the case and you get this message repeatedly, please:\n"
- ^ " a) Send a bug report to unison-users@yahoogroups.com (you may need\n"
+ ^ " a) Send a bug report to unison-users@seas.upenn.edu (you may need\n"
^ " to join the group before you will be allowed to post).\n"
+ ^ " For information, see https://github.com/bcpierce00/unison/wiki\n"
^ " b) Move the archive files on each machine to some other directory\n"
^ " (in case they may be useful for debugging).\n"
^ " The archive files on this machine are in the directory\n"
^ (Printf.sprintf " %s\n"
- (System.fspathToPrintString Util.unisonDir))
+ Util.unisonDir)
^ " and have names of the form\n"
^ " arXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX\n"
^ " where the X's are hexadecimal numbers.\n"
@@ -775,11 +1102,11 @@ let lockArchiveLocal fspath =
None
else
Some (Printf.sprintf "The file %s on host %s should be deleted"
- (System.fspathToPrintString lockFile) (Os.myCanonicalHostName ()))
+ lockFile (Os.myCanonicalHostName ()))
let lockArchiveOnRoot: Common.root -> unit -> string option Lwt.t =
Remote.registerRootCmd
- "lockArchive" (fun (fspath, ()) -> Lwt.return (lockArchiveLocal fspath))
+ "lockArchive" Umarshal.unit Umarshal.(option string) (fun (fspath, ()) -> Lwt.return (lockArchiveLocal fspath))
let unlockArchiveLocal fspath =
Lock.release
@@ -787,12 +1114,13 @@ let unlockArchiveLocal fspath =
let unlockArchiveOnRoot: Common.root -> unit -> unit Lwt.t =
Remote.registerRootCmd
- "unlockArchive"
+ "unlockArchive" Umarshal.unit Umarshal.unit
(fun (fspath, ()) -> Lwt.return (unlockArchiveLocal fspath))
let ignorelocks =
Prefs.createBool "ignorelocks" false
- "!ignore locks left over from previous run (dangerous!)"
+ ~category:(`Advanced `General)
+ "ignore locks left over from previous run (dangerous!)"
("When this preference is set, Unison will ignore any lock files "
^ "that may have been left over from a previous run of Unison that "
^ "was interrupted while reading or writing archive files; by default, "
@@ -871,7 +1199,7 @@ let unlockArchives () =
let archivesExistOnRoot: Common.root -> unit -> (bool * bool) Lwt.t =
Remote.registerRootCmd
- "archivesExist"
+ "archivesExist" Umarshal.unit Umarshal.(prod2 bool bool id id)
(fun (fspath,rootsName) ->
let (oldname,_) = archiveName fspath MainArch in
let oldexists =
@@ -879,6 +1207,16 @@ let archivesExistOnRoot: Common.root -> unit -> (bool * bool) Lwt.t =
let (newname,_) = archiveName fspath NewArch in
let newexists =
System.file_exists (Util.fileInUnisonDir newname) in
+ let oldexists =
+ if oldexists || newexists then oldexists else
+ (* No archive found, try 2.51 upgrade mode *)
+ (* IMPORTANT! This code is for smoother upgrades from
+ versions <= 2.51.5
+ It can be removed when this compatibility is no longer
+ required. *)
+ let (oldname, _) = archiveName251 fspath MainArch in
+ System.file_exists (Util.fileInUnisonDir oldname)
+ in
Lwt.return (oldexists, newexists))
let forall = Safelist.for_all (fun x -> x)
@@ -959,9 +1297,6 @@ let doArchiveCrashRecovery () =
^ "between synchronizations. See the documentation for the UNISONLOCALHOSTNAME\n"
^ "environment variable for advice on how to correct this.\n"
^ "\n"
- ^ "Donations to the Unison project are gratefully accepted: \n"
- ^ "http://www.cis.upenn.edu/~bcpierce/unison\n"
- ^ "\n"
(* ^ "\nThe expected archive names were:\n" ^ expectedNames *) );
Lwt.return ()
end))
@@ -1038,7 +1373,7 @@ let translatePathLocal fspath path =
localPath
let translatePath =
- Remote.registerRootCmd "translatePath"
+ Remote.registerRootCmd "translatePath" Path.m Path.mlocal
(fun (fspath, path) -> Lwt.return (translatePathLocal fspath path))
(***********************************************************************
@@ -1047,7 +1382,8 @@ let translatePath =
let mountpoints =
Prefs.createStringList "mountpoint"
- "!abort if this path does not exist"
+ ~category:(`Advanced `General)
+ "abort if this path does not exist"
("Including the preference \\texttt{-mountpoint PATH} causes Unison to "
^ "double-check, at the end of update detection, that \\texttt{PATH} exists "
^ "and abort if it does not. This is useful when Unison is used to synchronize "
@@ -1134,7 +1470,8 @@ let rec getSubTree path tree =
let fastcheck =
Prefs.createBoolWithDefault "fastcheck"
- "!do fast update detection (true/false/default)"
+ ~category:(`Advanced `Syncprocess)
+ "do fast update detection (true/false/default)"
( "When this preference is set to \\verb|true|, \
Unison will use the modification time and length of a file as a
`pseudo inode number' \
@@ -1161,7 +1498,8 @@ let useFastChecking () =
Prefs.read fastcheck = `True
|| (Prefs.read fastcheck = `Default (*&& Util.osType = `Unix*))
-let immutable = Pred.create "immutable" ~advanced:true
+let immutable = Pred.create "immutable"
+ ~category:(`Advanced `Sync)
("This preference specifies paths for directories whose \
immediate children are all immutable files --- i.e., once a file has been \
created, its contents never changes. When scanning for updates, \
@@ -1169,13 +1507,15 @@ let immutable = Pred.create "immutable" ~advanced:true
this can speed update detection significantly (in particular, for mail \
directories).")
-let immutablenot = Pred.create "immutablenot" ~advanced:true
+let immutablenot = Pred.create "immutablenot"
+ ~category:(`Advanced `Sync)
("This preference overrides {\\tt immutable}.")
type scanInfo =
{ fastCheck : bool;
dirFastCheck : bool;
dirStamp : Props.dirChangedStamp;
+ rescanProps : bool;
archHash : string;
showStatus : bool }
@@ -1263,7 +1603,7 @@ let rec noChildChange childUpdates =
(* Check whether the directory contents is different from what is in
the archive *)
let directoryCheckContentUnchanged
- currfspath path info archDesc childUpdates scanInfo =
+ currfspath path info propsChanged archDesc childUpdates scanInfo =
if
noChildChange childUpdates
&&
@@ -1275,13 +1615,23 @@ let directoryCheckContentUnchanged
let inode =
match Fileinfo.stamp info with Fileinfo.InodeStamp i -> i | _ -> 0 in
Props.setDirChangeFlag archDesc scanInfo.dirStamp inode in
- let updated =
- updated || not (Props.same_time info.Fileinfo.desc archDesc) in
if updated then
debugverbose (fun()->
Util.msg "Contents of directory %s marked unchanged\n"
(Fspath.toDebugString (Fspath.concat currfspath path)));
- (Props.setTime archDesc (Props.time info.Fileinfo.desc), updated)
+ (* Only update the times in archive if there is nothing to propagate for
+ the dir itself. Otherwise, if propagation fails and times in archive
+ are updated anyway then the changes that failed to propagate may be
+ missed at the next scan. If there is something to propagate then all
+ archive changes must go through propagation. With the exception of
+ dirChangeFlag, which is safe to update without updating mtime. *)
+ if propsChanged then
+ (archDesc, updated)
+ else
+ let updated =
+ updated || not (Props.same_time info.Fileinfo.desc archDesc)
+ || not (Props.same_ctime info.desc archDesc) in
+ (Props.setTime archDesc info.Fileinfo.desc, updated)
end else begin
let (archDesc, updated) =
Props.setDirChangeFlag archDesc Props.changedDirStamp 0 in
@@ -1337,8 +1687,10 @@ let checkContentsChange
Fileinfo.InodeStamp inode ->
(Util.msg "archStamp is inode (%d)" inode;
Util.msg " / info.inode (%d)" info.Fileinfo.inode)
- | Fileinfo.CtimeStamp stamp ->
- (Util.msg "archStamp is ctime (%f)" stamp)
+ | Fileinfo.NoStamp ->
+ (Util.msg "archStamp is no-stamp")
+ | Fileinfo.RescanStamp ->
+ (Util.msg "archStamp is rescan-possibly-updated")
end;
Util.msg " / times: %f = %f... %b"
(Props.time archDesc) (Props.time info.Fileinfo.desc)
@@ -1355,7 +1707,19 @@ let checkContentsChange
in
if dataClearlyUnchanged && ressClearlyUnchanged then begin
Xferhint.insertEntry currfspath path archFp;
- None, checkPropChange info.Fileinfo.desc archive archDesc
+ let propsUpdates = checkPropChange info.Fileinfo.desc archive archDesc in
+ let propsChanged = propsUpdates <> NoUpdates in
+ (* Only update the archive if there is nothing to propagate. Otherwise,
+ if propagation fails and times in archive are updated anyway then the
+ changes that failed to propagate may be missed at the next scan. *)
+ let optArch =
+ if propsChanged || Props.same_ctime info.Fileinfo.desc archDesc then
+ None
+ else
+ let newprops = Props.setTime archDesc info.Fileinfo.desc in
+ Some (ArchiveFile (newprops, archFp, archStamp, archRess))
+ in
+ optArch, propsUpdates
end else begin
debugverbose (fun() -> Util.msg " Double-check possibly updated file\n");
showStatusAddLength scanInfo info;
@@ -1367,12 +1731,20 @@ let checkContentsChange
(Os.fullfingerprint_to_string archFp)
(Os.fullfingerprint_to_string newFp));
if archFp = newFp then begin
- let newprops = Props.setTime archDesc (Props.time newDesc) in
+ let propsUpdates = checkPropChange newDesc archive archDesc in
+ let propsChanged = propsUpdates <> NoUpdates in
+ (* Only update the archive if there is nothing to propagate. Otherwise,
+ if propagation fails and times in archive are updated anyway then the
+ changes that failed to propagate may be missed at the next scan. *)
+ begin if propsChanged then
+ None
+ else
+ let newprops = Props.setTime archDesc newDesc in
let newarch = ArchiveFile (newprops, archFp, newStamp, newRess) in
debugverbose (fun() ->
Util.msg " Contents match: update archive with new time...%f\n"
(Props.time newprops));
- Some newarch, checkPropChange newDesc archive archDesc
+ Some newarch end, propsUpdates
end else begin
debug (fun() -> Util.msg " Updated file\n");
(* [BCP 5/2011] We might add a sanity check here: if the file contents
@@ -1593,7 +1965,13 @@ and buildUpdateRec archive currfspath path scanInfo =
debug (fun() ->
Util.msg "buildUpdateRec: %s\n"
(Fspath.toDebugString (Fspath.concat currfspath path)));
- let info = Fileinfo.get true currfspath path in
+ let archProps =
+ match scanInfo.fastCheck, scanInfo.rescanProps, archive with
+ | true, false, ArchiveFile (archDesc, _, _, _) -> Some archDesc
+ | true, false, ArchiveDir (archDesc, _) -> Some archDesc
+ | _ -> None
+ in
+ let info = Fileinfo.get ?archProps true currfspath path in
match (info.Fileinfo.typ, archive) with
(`ABSENT, NoArchive) ->
debug (fun() -> Util.msg " buildUpdate -> Absent and no archive\n");
@@ -1666,8 +2044,9 @@ and buildUpdateRec archive currfspath path scanInfo =
(These are files or directories which used not to be
ignored and are now ignored.) *)
if hasIgnoredChildren then (archDesc, true) else
+ let propsChanged = permchange <> PropsSame in
directoryCheckContentUnchanged
- currfspath path info archDesc childUpdates scanInfo in
+ currfspath path info propsChanged archDesc childUpdates scanInfo in
(begin match newChildren with
Some ch ->
Some (ArchiveDir (archDesc, ch))
@@ -1804,7 +2183,13 @@ let rec buildUpdate archive fspath fullpath here path pathTree scanInfo =
end,
ui, here, [])
| Some(name, path') ->
- let info = Fileinfo.get true fspath here in
+ let archProps =
+ match scanInfo.fastCheck, scanInfo.rescanProps, archive with
+ | true, false, ArchiveFile (archDesc, _, _, _) -> Some archDesc
+ | true, false, ArchiveDir (archDesc, _) -> Some archDesc
+ | _ -> None
+ in
+ let info = Fileinfo.get ?archProps true fspath here in
if info.Fileinfo.typ <> `DIRECTORY && info.Fileinfo.typ <> `ABSENT then
let error =
if Path.isEmpty here then
@@ -1893,14 +2278,14 @@ let updatePredicates =
("follow", Path.followPred)]
let predKey : (string * string list) list Proplist.key =
- Proplist.register "update predicates"
-let rsrcKey : bool Proplist.key = Proplist.register "rsrc pref"
+ Proplist.register "update predicates" Umarshal.(list (prod2 string (list string) id id))
+let rsrcKey : bool Proplist.key = Proplist.register "rsrc pref" Umarshal.bool
-let checkNoUpdatePredicateChange thisRoot =
+let checkNoUpdatePredicateChange thisRoot rescanProps =
let props = getArchiveProps thisRoot in
let oldPreds = try Proplist.find predKey props with Not_found -> [] in
let newPreds =
- List.map (fun (nm, p) -> (nm, Pred.extern p)) updatePredicates in
+ Safelist.map (fun (nm, p) -> (nm, Pred.extern p)) updatePredicates in
(*
List.iter
(fun (nm, l) ->
@@ -1913,7 +2298,8 @@ Format.eprintf "==> %b@." (oldPreds = newPreds);
try Some (Proplist.find rsrcKey props) with Not_found -> None in
let newRsrc = Prefs.read Osx.rsrc in
try
- if oldPreds <> newPreds || oldRsrc <> Some newRsrc then raise Not_found;
+ if oldPreds <> newPreds || oldRsrc <> Some newRsrc || rescanProps then
+ raise Not_found;
Proplist.find dirStampKey props
with Not_found ->
let stamp = Props.freshDirStamp () in
@@ -1923,6 +2309,50 @@ Format.eprintf "==> %b@." (oldPreds = newPreds);
(Proplist.add rsrcKey newRsrc props)));
stamp
+(* All the predicates that may change the set of props scanned during
+ update detection *)
+let propsPredicates =
+ [ ("xattrignore", Props.xattrIgnorePred, Props.xattrEnabled);
+ ("xattrignorenot", Props.xattrIgnorenotPred, Props.xattrEnabled);
+ ]
+
+let pred2Key : (string * string list) list Proplist.key =
+ Proplist.register "props predicates" Umarshal.(list (prod2 string (list string) id id))
+let xattrsKey : bool Proplist.key = Proplist.register "xattrs pref" Umarshal.bool
+let aclKey : bool Proplist.key = Proplist.register "acl pref" Umarshal.bool
+
+let mustRescanProps thisRoot =
+ let props = getArchiveProps thisRoot in
+ let oldPreds = try Proplist.find pred2Key props with Not_found -> [] in
+ let newPreds =
+ Safelist.filterMap (fun (nm, p, c) ->
+ if c () then Some (nm, Pred.extern p) else None) propsPredicates in
+ let oldXattrs =
+ try Some (Proplist.find xattrsKey props) with Not_found -> None in
+ let newXattrs =
+ if Props.xattrEnabled () then Some (Prefs.read Props.syncXattrs) else None in
+ let oldACL =
+ try Some (Proplist.find aclKey props) with Not_found -> None in
+ let newACL =
+ if Props.aclEnabled () then Some (Prefs.read Props.syncACL) else None in
+ if oldPreds = newPreds && oldXattrs = newXattrs && oldACL = newACL then
+ false
+ else begin
+ let props =
+ match newACL with
+ | Some x -> Proplist.add aclKey x props
+ | None -> props in
+ let props =
+ match newXattrs with
+ | Some x -> Proplist.add xattrsKey x props
+ | None -> props in
+ let props =
+ if newPreds <> [] then Proplist.add pred2Key newPreds props
+ else props in
+ let () = setArchivePropsLocal thisRoot props in
+ newXattrs = Some true || newACL = Some true
+ end
+
(* This contains the list of synchronized paths and the directory stamps
used by the previous update detection, when a watcher process is used.
This make it possible to know when the state of the watcher process
@@ -1946,7 +2376,8 @@ let findLocal wantWatcher fspath pathList subpaths :
deleted. --BCP 2006 *)
let (arcName,thisRoot) = archiveName fspath MainArch in
let archive = getArchive thisRoot in
- let dirStamp = checkNoUpdatePredicateChange thisRoot in
+ let rescanProps = mustRescanProps thisRoot in
+ let dirStamp = checkNoUpdatePredicateChange thisRoot rescanProps in
(*
let t1 = Unix.gettimeofday () in
*)
@@ -1956,7 +2387,7 @@ let t1 = Unix.gettimeofday () in
as Windows does not update directory modification times
on FAT filesystems. *)
dirFastCheck = useFastChecking () && Util.osType = `Unix;
- dirStamp = dirStamp; archHash = archiveHash fspath;
+ dirStamp; rescanProps; archHash = archiveHash fspath;
showStatus = not !Trace.runningasserver }
in
let (cacheFilename, _) = archiveName fspath FPCache in
@@ -1971,7 +2402,8 @@ let t1 = Unix.gettimeofday () in
in
let paths =
match subpaths with
- Some (unsynchronizedPaths, blacklistedPaths) when unchangedOptions ->
+ Some (unsynchronizedPaths, blacklistedPaths) when unchangedOptions
+ && Fswatchold.running scanInfo.archHash ->
let (>>) x f = f x in
let paths =
Fswatchold.getChanges scanInfo.archHash
@@ -2039,13 +2471,29 @@ Format.eprintf "Update detection: %f@." (t2 -. t1);
abortIfAnyMountpointsAreMissing fspath;
updates
+(* Conversion functions for 2.51-compatible return type:
+ (Path.local * Common.updateItem * Props.t list) list *)
+let convV0 = Remote.makeConvV0FunRet
+ (fun r -> Safelist.map
+ (fun (a, b, c) -> a, Common.ui_to_compat251 b, Safelist.map Props.to_compat251 c) r)
+ (fun r -> Safelist.map
+ (fun (a, b, c) -> a, Common.ui_of_compat251 b, Safelist.map Props.of_compat251 c) r)
+
let findOnRoot =
Remote.registerRootCmd
- "find"
+ "find" ~convV0
+ Umarshal.(prod3 bool (list Path.m) (option (prod2 (list Path.m) (list Path.m) id id)) id id)
+ Umarshal.(list (prod3 Path.mlocal Common.mupdateItem (list Props.m) id id))
(fun (fspath, (wantWatcher, pathList, subpaths)) ->
Lwt.return (findLocal wantWatcher fspath pathList subpaths))
-let findUpdatesOnPaths ?wantWatcher pathList subpaths =
+let mergePropsdataOnRoot =
+ Remote.registerRootCmd "propsdata" Props.Data.m Props.Data.m
+ (fun (fspath, propsdata) ->
+ Props.Data.merge propsdata;
+ Lwt.return (Props.Data.extern `New))
+
+let findUpdatesOnPaths ?(wantWatcher=false) pathList subpaths =
Lwt_unix.run
(loadArchives true >>= (fun (ok, checksums) ->
begin if ok then Lwt.return checksums else begin
@@ -2068,7 +2516,7 @@ let findUpdatesOnPaths ?wantWatcher pathList subpaths =
let t = Trace.startTimer "Collecting changes" in
Globals.allRootsMapWithWaitingAction (fun r ->
debug (fun() -> Util.msg "findOnRoot %s\n" (root2string r));
- findOnRoot r (wantWatcher <> None, pathList, subpaths))
+ findOnRoot r (wantWatcher, pathList, subpaths))
(fun (host, _) ->
begin match host with
Remote _ -> Uutil.showUpdateStatus "";
@@ -2076,6 +2524,16 @@ let findUpdatesOnPaths ?wantWatcher pathList subpaths =
| _ -> ()
end)
>>= (fun updates ->
+ begin Globals.allRootsIter (fun r ->
+ match r with
+ | (Local, _) -> Lwt.return ()
+ | (Remote _, _) when not (Props.Data.enabled ()) -> Lwt.return ()
+ | (Remote _, _) -> begin
+ mergePropsdataOnRoot r (Props.Data.extern `New) >>= fun propsdata ->
+ Props.Data.merge propsdata;
+ Lwt.return ()
+ end)
+ end >>= fun () ->
Trace.showTimer t;
let result =
Safelist.map
@@ -2121,7 +2579,7 @@ let findUpdates ?wantWatcher subpaths =
(*****************************************************************************)
(* To prepare for committing, write to Scratch Archive *)
-let prepareCommitLocal (fspath, magic) =
+let prepareCommitLocal compatMode (fspath, magic) =
let (newName, root) = archiveName fspath ScratchArch in
let archive = getArchive root in
(**
@@ -2131,14 +2589,29 @@ let prepareCommitLocal (fspath, magic) =
showArchive archive;
Format.print_flush();
**)
- let archiveHash = checkArchive true [] archive 0 in
+ let archiveHash =
+ if not compatMode then checkArchive true [] archive 0
+ else checkArchive251 true [] (to_compat251 archive) 0 in
let props = getArchiveProps root in
+ let props = externArchivePropsdata archive props in
storeArchiveLocal
(Util.fileInUnisonDir newName) root archive archiveHash magic props;
Lwt.return (Some archiveHash)
-let prepareCommitOnRoot
- = Remote.registerRootCmd "prepareCommit" prepareCommitLocal
+let prepareCommitOnRoot =
+ Remote.registerRootCmdWithConnection "prepareCommit"
+ Umarshal.(prod2 Fspath.m string id id) Umarshal.(option int)
+ (fun conn (fspath, magic) ->
+ let compatMode = Remote.connectionVersion conn = 0 in
+ prepareCommitLocal compatMode (fspath, magic))
+
+let prepareCommitOnRoots magic =
+ match Globals.rootsInCanonicalOrder () with
+ | [(Local, _); (Local, _)] ->
+ Globals.allRootsMap (fun r -> prepareCommitLocal false (snd r, magic))
+ | [(Local, _); (Remote _, _) as r'] ->
+ Globals.allRootsMap (fun r -> prepareCommitOnRoot r r' (snd r, magic))
+ | _ -> assert false
(* To really commit, first prepare (write to scratch arch.), then make sure
the checksum on all archives are equal, finally flip scratch to main. In
@@ -2153,7 +2626,7 @@ let commitUpdates () =
Format.sprintf "%s\000%.0f.%d"
((Case.ops ())#modeDesc) (Unix.gettimeofday ()) (Unix.getpid ())
in
- Globals.allRootsMap (fun r -> prepareCommitOnRoot r magic)
+ prepareCommitOnRoots magic
>>= (fun checksums ->
if archivesIdentical checksums then begin
(* Move scratch archives to new *)
@@ -2291,9 +2764,16 @@ let markEqualLocal fspath paths =
archive := arch);
setArchiveLocal root !archive
+let convV0 =
+ let to_compat251 = Tree.map (fun nm -> nm) Common.uc_to_compat251
+ and of_compat251 = Tree.map (fun nm -> nm) Common.uc_of_compat251 in
+ Remote.makeConvV0FunArg
+ (fun (fspath, paths) -> (fspath, to_compat251 paths))
+ (fun (fspath, paths) -> (fspath, of_compat251 paths))
+
let markEqualOnRoot =
Remote.registerRootCmd
- "markEqual"
+ "markEqual" ~convV0 (Tree.m Name.m Common.mupdateContent) Umarshal.unit
(fun (fspath, paths) -> markEqualLocal fspath paths; Lwt.return ())
let markEqual equals =
@@ -2318,9 +2798,14 @@ let replaceArchiveLocal fspath path newArch =
updatePathInArchive archive fspath Path.empty path (fun _ _ -> newArch) in
setArchiveLocal root archive
+let convV0 = Remote.makeConvV0FunArg
+ (fun (fspath, (pathTo, arch)) -> (fspath, (pathTo, to_compat251 arch)))
+ (fun (fspath, (pathTo, arch)) -> (fspath, (pathTo, of_compat251 arch)))
+
let replaceArchiveOnRoot =
Remote.registerRootCmd
- "replaceArchive"
+ "replaceArchive" ~convV0
+ Umarshal.(prod2 Path.m marchive id id) Umarshal.unit
(fun (fspath, (pathTo, arch)) ->
replaceArchiveLocal fspath pathTo arch;
Lwt.return ())
@@ -2395,8 +2880,7 @@ let fastCheckMiss path desc ress oldDesc oldRess =
let doMarkPossiblyUpdated arch =
match arch with
ArchiveFile (desc, fp, stamp, ress) ->
- (* It would be cleaner to have a special stamp for this *)
- ArchiveFile (desc, fp, Fileinfo.InodeStamp (-1), ress)
+ ArchiveFile (desc, fp, Fileinfo.RescanStamp, ress)
| _ ->
(* Should not happen, actually. But this is hard to test... *)
arch
@@ -2496,8 +2980,8 @@ let checkNoUpdates fspath pathInArchive ui =
(* ...and check that this is a good description of what's out in the world *)
let scanInfo =
{ fastCheck = false; dirFastCheck = false;
- dirStamp = Props.changedDirStamp; archHash = "" (* Not used *);
- showStatus = false } in
+ dirStamp = Props.changedDirStamp; rescanProps = true;
+ archHash = "" (* Not used *); showStatus = false } in
let (_, uiNew) = buildUpdateRec archive fspath localPath scanInfo in
markPossiblyUpdatedRec fspath pathInArchive uiNew;
explainUpdate pathInArchive uiNew;
@@ -2595,5 +3079,5 @@ let rec iterFiles fspath path arch f =
(* Hook for filesystem auto-detection (not implemented yet) *)
let inspectFilesystem =
Remote.registerRootCmd
- "inspectFilesystem"
+ "inspectFilesystem" Umarshal.unit Proplist.m
(fun _ -> Lwt.return Proplist.empty)
diff --git a/src/update.mli b/src/update.mli
index 0456e3f..efe8121 100644
--- a/src/update.mli
+++ b/src/update.mli
@@ -3,12 +3,23 @@
module NameMap : MyMap.S with type key = Name.t
+type archive251 =
+ ArchiveDir of Props.t251 * archive251 NameMap.t
+ | ArchiveFile of Props.t251 * Os.fullfingerprint * Fileinfo.stamp251 * Osx.ressStamp
+ | ArchiveSymlink of string
+ | NoArchive
+
type archive =
ArchiveDir of Props.t * archive NameMap.t
| ArchiveFile of Props.t * Os.fullfingerprint * Fileinfo.stamp * Osx.ressStamp
| ArchiveSymlink of string
| NoArchive
+val marchive : archive Umarshal.t
+
+val to_compat251 : archive -> archive251
+val of_compat251 : archive251 -> archive
+
(* Calculate a canonical name for the set of roots to be synchronized. This
will be used in constructing the archive name for each root. Note, all
the roots in this canonical name will contain hostnames, even local
@@ -22,9 +33,9 @@ val getRootsName : unit -> string
paths known not to be synchronized and a list of paths not to
check. Returns structures describing dirty files/dirs (1 per path
given in the -path preference). An option controls whether we
- would like to use the external filesytem monitoring process. *)
+ would like to use the external filesystem monitoring process. *)
val findUpdates :
- ?wantWatcher:unit ->
+ ?wantWatcher:bool ->
(Path.t list * Path.t list) option ->
((Path.local * Common.updateItem * Props.t list) *
(Path.local * Common.updateItem * Props.t list)) list
diff --git a/src/uutil.ml b/src/uutil.ml
index c5f20b7..5c0d96b 100644
--- a/src/uutil.ml
+++ b/src/uutil.ml
@@ -34,7 +34,7 @@ let myNameAndVersion = myName ^ " " ^ myVersion
let hash2 x y = (17 * x + 257 * y) land 0x3FFFFFFF
-external hash_param : int -> int -> 'a -> int = "unsn_hash_univ_param" "noalloc"
+external hash_param : int -> int -> 'a -> int = "unsn_hash_univ_param" [@@noalloc]
let hash x = hash_param 10 100 x
@@ -44,6 +44,7 @@ let hash x = hash_param 10 100 x
module type FILESIZE = sig
type t
+ val m : t Umarshal.t
val zero : t
val dummy : t
val add : t -> t -> t
@@ -62,6 +63,7 @@ end
module Filesize : FILESIZE = struct
type t = int64
+ let m = Umarshal.int64
let zero = 0L
let dummy = -1L
let add = Int64.add
@@ -89,6 +91,7 @@ end
module File =
struct
type t = int
+ let m = Umarshal.int
let dummy = -1
let ofLine l = l
let toLine l = assert (l <> dummy); l
diff --git a/src/uutil.mli b/src/uutil.mli
index acc2657..a2c16e7 100644
--- a/src/uutil.mli
+++ b/src/uutil.mli
@@ -18,6 +18,7 @@ val hash : 'a -> int
module type FILESIZE = sig
type t
+ val m : t Umarshal.t
val zero : t
val dummy : t
val add : t -> t -> t
@@ -41,6 +42,7 @@ module Filesize : FILESIZE
module File :
sig
type t
+ val m : t Umarshal.t
val ofLine : int -> t
val toLine : t -> int
val toString : t -> string
diff --git a/src/xferhint.ml b/src/xferhint.ml
index c6e5dc2..876573f 100644
--- a/src/xferhint.ml
+++ b/src/xferhint.ml
@@ -20,11 +20,12 @@ let debug = Trace.debug "xferhint"
let xferbycopying =
Prefs.createBool "xferbycopying" true
- "!optimize transfers using local copies"
+ ~category:(`Advanced `Remote)
+ "optimize transfers using local copies"
("When this preference is set, Unison will try to avoid transferring "
^ "file contents across the network by recognizing when a file with the "
^ "required contents already exists in the target replica. This usually "
- ^ "allows file moves to be propagated very quickly. The default value is"
+ ^ "allows file moves to be propagated very quickly. The default value is "
^ "\\texttt{true}. ")
module FPMap =
diff --git a/tests/fstest/fstest.1 b/tests/fstest/fstest.1
deleted file mode 100644
index 4cdb400..0000000
--- a/tests/fstest/fstest.1
+++ /dev/null
@@ -1,79 +0,0 @@
-.\"Modified from man(1) of FreeBSD, the NetBSD mdoc.template, and mdoc.samples.
-.\"See Also:
-.\"man mdoc.samples for a complete listing of options
-.\"man mdoc for the short list of editing options
-.\"/usr/share/misc/mdoc.template
-.Dd 27/06/08 \" DATE
-.Dt fstest 1 \" Program name and manual section number
-.Os Darwin
-.Sh NAME \" Section Header - required - don't modify
-.Nm fstest,
-.\" The following lines are read in generating the apropos(man -k) database. Use only key
-.\" words here as the database is built based on the words here and in the .ND line.
-.Nm Other_name_for_same_program(),
-.Nm Yet another name for the same program.
-.\" Use .Nm macro to designate other names for the documented program.
-.Nd This line parsed for whatis database.
-.Sh SYNOPSIS \" Section Header - required - don't modify
-.Nm
-.Op Fl abcd \" [-abcd]
-.Op Fl a Ar path \" [-a path]
-.Op Ar file \" [file]
-.Op Ar \" [file ...]
-.Ar arg0 \" Underlined argument - use .Ar anywhere to underline
-arg2 ... \" Arguments
-.Sh DESCRIPTION \" Section Header - required - don't modify
-Use the .Nm macro to refer to your program throughout the man page like such:
-.Nm
-Underlining is accomplished with the .Ar macro like this:
-.Ar underlined text .
-.Pp \" Inserts a space
-A list of items with descriptions:
-.Bl -tag -width -indent \" Begins a tagged list
-.It item a \" Each item preceded by .It macro
-Description of item a
-.It item b
-Description of item b
-.El \" Ends the list
-.Pp
-A list of flags and their descriptions:
-.Bl -tag -width -indent \" Differs from above in tag removed
-.It Fl a \"-a flag as a list item
-Description of -a flag
-.It Fl b
-Description of -b flag
-.El \" Ends the list
-.Pp
-.\" .Sh ENVIRONMENT \" May not be needed
-.\" .Bl -tag -width "ENV_VAR_1" -indent \" ENV_VAR_1 is width of the string ENV_VAR_1
-.\" .It Ev ENV_VAR_1
-.\" Description of ENV_VAR_1
-.\" .It Ev ENV_VAR_2
-.\" Description of ENV_VAR_2
-.\" .El
-.Sh FILES \" File used or created by the topic of the man page
-.Bl -tag -width "/Users/joeuser/Library/really_long_file_name" -compact
-.It Pa /usr/share/file_name
-FILE_1 description
-.It Pa /Users/joeuser/Library/really_long_file_name
-FILE_2 description
-.El \" Ends the list
-.\" .Sh DIAGNOSTICS \" May not be needed
-.\" .Bl -diag
-.\" .It Diagnostic Tag
-.\" Diagnostic informtion here.
-.\" .It Diagnostic Tag
-.\" Diagnostic informtion here.
-.\" .El
-.Sh SEE ALSO
-.\" List links in ascending order by section, alphabetically within a section.
-.\" Please do not reference files that do not exist without filing a bug report
-.Xr a 1 ,
-.Xr b 1 ,
-.Xr c 1 ,
-.Xr a 2 ,
-.Xr b 2 ,
-.Xr a 3 ,
-.Xr b 3
-.\" .Sh BUGS \" Document known, unremedied bugs
-.\" .Sh HISTORY \" Document history if command behaves in a unique manner
\ No newline at end of file
diff --git a/tests/fstest/fstest.m b/tests/fstest/fstest.m
deleted file mode 100644
index ffd1a56..0000000
--- a/tests/fstest/fstest.m
+++ /dev/null
@@ -1,72 +0,0 @@
-#import <Foundation/Foundation.h>
-#include <CoreServices/CoreServices.h>
-
-void myCallbackFunction(
- ConstFSEventStreamRef streamRef,
- void *clientCallBackInfo,
- size_t numEvents,
- void *eventPaths,
- const FSEventStreamEventFlags eventFlags[],
- const FSEventStreamEventId eventIds[])
-{
- int i;
- char **paths = eventPaths;
-
- // printf("Callback called\n");
- for (i=0; i<numEvents; i++) {
- /* flags are unsigned long, IDs are uint64_t
- printf("Change %llu in %s, flags %lu\n", eventIds[i], paths[i], eventFlags[i]); */
- if (eventFlags[i] == kFSEventStreamEventFlagMustScanSubDirs) {
- printf("*%s\n",paths[i]);
- } else {
- printf(".%s\n",paths[i]);
- }
- }
-}
-
-
-int main (int argc, const char * argv[]) {
- NSAutoreleasePool * pool = [[NSAutoreleasePool alloc] init];
- int i;
- CFMutableArrayRef pathsToWatch;
-
- if (argc == 1) {
- exit(0);
- }
-
- /* Define variables and create a CFArray object containing
- CFString objects containing paths to watch.
-
- There may be a simpler or nicer way to do this than using a mutable array, but I don't know it.
- */
-
- pathsToWatch = CFArrayCreateMutable(NULL, argc - 1, &kCFTypeArrayCallBacks);
-
- for (i=1; i<argc; i++) {
- CFArrayAppendValue(pathsToWatch, CFStringCreateWithCString(NULL, argv[i], kCFStringEncodingUTF8));
- }
-
- void *callbackInfo = NULL; // could put stream-specific data here.
- FSEventStreamRef stream;
- CFAbsoluteTime latency = 1.0; /* Latency in seconds */
-
- /* Create the stream, passing in a callback */
- stream = FSEventStreamCreate(NULL,
- &myCallbackFunction,
- callbackInfo,
- pathsToWatch,
- kFSEventStreamEventIdSinceNow, /* Or a previous event ID */
- latency,
- kFSEventStreamCreateFlagNone /* Flags explained in reference */
- );
-
- /* Create the stream before calling this. */
- FSEventStreamScheduleWithRunLoop(stream, CFRunLoopGetCurrent(), kCFRunLoopDefaultMode);
-
- FSEventStreamStart(stream);
-
- CFRunLoopRun();
-
- [pool drain];
- return 0;
-}
diff --git a/tests/fstest/fstest.xcodeproj/project.pbxproj b/tests/fstest/fstest.xcodeproj/project.pbxproj
deleted file mode 100644
index bbe32a7..0000000
--- a/tests/fstest/fstest.xcodeproj/project.pbxproj
+++ /dev/null
@@ -1,229 +0,0 @@
-// !$*UTF8*$!
-{
- archiveVersion = 1;
- classes = {
- };
- objectVersion = 47;
- objects = {
-
-/* Begin PBXBuildFile section */
- 2A7DF5020E157F9600A8190E /* CoreServices.framework in Frameworks */ = {isa = PBXBuildFile; fileRef = 2A7DF5010E157F9600A8190E /* CoreServices.framework */; };
- 8DD76F9A0486AA7600D96B5E /* fstest.m in Sources */ = {isa = PBXBuildFile; fileRef = 08FB7796FE84155DC02AAC07 /* fstest.m */; settings = {ATTRIBUTES = (); }; };
- 8DD76F9C0486AA7600D96B5E /* Foundation.framework in Frameworks */ = {isa = PBXBuildFile; fileRef = 08FB779EFE84155DC02AAC07 /* Foundation.framework */; };
- 8DD76F9F0486AA7600D96B5E /* fstest.1 in CopyFiles */ = {isa = PBXBuildFile; fileRef = C6859EA3029092ED04C91782 /* fstest.1 */; };
-/* End PBXBuildFile section */
-
-/* Begin PBXCopyFilesBuildPhase section */
- 8DD76F9E0486AA7600D96B5E /* CopyFiles */ = {
- isa = PBXCopyFilesBuildPhase;
- buildActionMask = 8;
- dstPath = /usr/share/man/man1/;
- dstSubfolderSpec = 0;
- files = (
- 8DD76F9F0486AA7600D96B5E /* fstest.1 in CopyFiles */,
- );
- runOnlyForDeploymentPostprocessing = 1;
- };
-/* End PBXCopyFilesBuildPhase section */
-
-/* Begin PBXFileReference section */
- 08FB7796FE84155DC02AAC07 /* fstest.m */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.objc; path = fstest.m; sourceTree = "<group>"; };
- 08FB779EFE84155DC02AAC07 /* Foundation.framework */ = {isa = PBXFileReference; lastKnownFileType = wrapper.framework; name = Foundation.framework; path = /System/Library/Frameworks/Foundation.framework; sourceTree = "<absolute>"; };
- 2A7DF5010E157F9600A8190E /* CoreServices.framework */ = {isa = PBXFileReference; lastKnownFileType = wrapper.framework; name = CoreServices.framework; path = /System/Library/Frameworks/CoreServices.framework; sourceTree = "<absolute>"; };
- 32A70AAB03705E1F00C91783 /* fstest_Prefix.pch */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.h; path = fstest_Prefix.pch; sourceTree = "<group>"; };
- 8DD76FA10486AA7600D96B5E /* fstest */ = {isa = PBXFileReference; explicitFileType = "compiled.mach-o.executable"; includeInIndex = 0; path = fstest; sourceTree = BUILT_PRODUCTS_DIR; };
- C6859EA3029092ED04C91782 /* fstest.1 */ = {isa = PBXFileReference; lastKnownFileType = text.man; path = fstest.1; sourceTree = "<group>"; };
-/* End PBXFileReference section */
-
-/* Begin PBXFrameworksBuildPhase section */
- 8DD76F9B0486AA7600D96B5E /* Frameworks */ = {
- isa = PBXFrameworksBuildPhase;
- buildActionMask = 2147483647;
- files = (
- 8DD76F9C0486AA7600D96B5E /* Foundation.framework in Frameworks */,
- 2A7DF5020E157F9600A8190E /* CoreServices.framework in Frameworks */,
- );
- runOnlyForDeploymentPostprocessing = 0;
- };
-/* End PBXFrameworksBuildPhase section */
-
-/* Begin PBXGroup section */
- 08FB7794FE84155DC02AAC07 /* fstest */ = {
- isa = PBXGroup;
- children = (
- 08FB7795FE84155DC02AAC07 /* Source */,
- C6859EA2029092E104C91782 /* Documentation */,
- 08FB779DFE84155DC02AAC07 /* External Frameworks and Libraries */,
- 1AB674ADFE9D54B511CA2CBB /* Products */,
- );
- name = fstest;
- sourceTree = "<group>";
- };
- 08FB7795FE84155DC02AAC07 /* Source */ = {
- isa = PBXGroup;
- children = (
- 32A70AAB03705E1F00C91783 /* fstest_Prefix.pch */,
- 08FB7796FE84155DC02AAC07 /* fstest.m */,
- );
- name = Source;
- sourceTree = "<group>";
- };
- 08FB779DFE84155DC02AAC07 /* External Frameworks and Libraries */ = {
- isa = PBXGroup;
- children = (
- 2A7DF5010E157F9600A8190E /* CoreServices.framework */,
- 08FB779EFE84155DC02AAC07 /* Foundation.framework */,
- );
- name = "External Frameworks and Libraries";
- sourceTree = "<group>";
- };
- 1AB674ADFE9D54B511CA2CBB /* Products */ = {
- isa = PBXGroup;
- children = (
- 8DD76FA10486AA7600D96B5E /* fstest */,
- );
- name = Products;
- sourceTree = "<group>";
- };
- C6859EA2029092E104C91782 /* Documentation */ = {
- isa = PBXGroup;
- children = (
- C6859EA3029092ED04C91782 /* fstest.1 */,
- );
- name = Documentation;
- sourceTree = "<group>";
- };
-/* End PBXGroup section */
-
-/* Begin PBXNativeTarget section */
- 8DD76F960486AA7600D96B5E /* fstest */ = {
- isa = PBXNativeTarget;
- buildConfigurationList = 1DEB927408733DD40010E9CD /* Build configuration list for PBXNativeTarget "fstest" */;
- buildPhases = (
- 8DD76F990486AA7600D96B5E /* Sources */,
- 8DD76F9B0486AA7600D96B5E /* Frameworks */,
- 8DD76F9E0486AA7600D96B5E /* CopyFiles */,
- );
- buildRules = (
- );
- dependencies = (
- );
- name = fstest;
- productInstallPath = "$(HOME)/bin";
- productName = fstest;
- productReference = 8DD76FA10486AA7600D96B5E /* fstest */;
- productType = "com.apple.product-type.tool";
- };
-/* End PBXNativeTarget section */
-
-/* Begin PBXProject section */
- 08FB7793FE84155DC02AAC07 /* Project object */ = {
- isa = PBXProject;
- attributes = {
- LastUpgradeCheck = 0720;
- };
- buildConfigurationList = 1DEB927808733DD40010E9CD /* Build configuration list for PBXProject "fstest" */;
- compatibilityVersion = "Xcode 6.3";
- developmentRegion = English;
- hasScannedForEncodings = 1;
- knownRegions = (
- en,
- );
- mainGroup = 08FB7794FE84155DC02AAC07 /* fstest */;
- projectDirPath = "";
- projectRoot = "";
- targets = (
- 8DD76F960486AA7600D96B5E /* fstest */,
- );
- };
-/* End PBXProject section */
-
-/* Begin PBXSourcesBuildPhase section */
- 8DD76F990486AA7600D96B5E /* Sources */ = {
- isa = PBXSourcesBuildPhase;
- buildActionMask = 2147483647;
- files = (
- 8DD76F9A0486AA7600D96B5E /* fstest.m in Sources */,
- );
- runOnlyForDeploymentPostprocessing = 0;
- };
-/* End PBXSourcesBuildPhase section */
-
-/* Begin XCBuildConfiguration section */
- 1DEB927508733DD40010E9CD /* Debug */ = {
- isa = XCBuildConfiguration;
- buildSettings = {
- COPY_PHASE_STRIP = NO;
- GCC_DYNAMIC_NO_PIC = NO;
- GCC_ENABLE_FIX_AND_CONTINUE = YES;
- GCC_MODEL_TUNING = G5;
- GCC_OPTIMIZATION_LEVEL = 0;
- GCC_PRECOMPILE_PREFIX_HEADER = YES;
- GCC_PREFIX_HEADER = fstest_Prefix.pch;
- INSTALL_PATH = /usr/local/bin;
- PRODUCT_NAME = fstest;
- ZERO_LINK = YES;
- };
- name = Debug;
- };
- 1DEB927608733DD40010E9CD /* Release */ = {
- isa = XCBuildConfiguration;
- buildSettings = {
- DEBUG_INFORMATION_FORMAT = "dwarf-with-dsym";
- GCC_MODEL_TUNING = G5;
- GCC_PRECOMPILE_PREFIX_HEADER = YES;
- GCC_PREFIX_HEADER = fstest_Prefix.pch;
- INSTALL_PATH = /usr/local/bin;
- PRODUCT_NAME = fstest;
- };
- name = Release;
- };
- 1DEB927908733DD40010E9CD /* Debug */ = {
- isa = XCBuildConfiguration;
- buildSettings = {
- ENABLE_TESTABILITY = YES;
- GCC_WARN_ABOUT_RETURN_TYPE = YES;
- GCC_WARN_UNUSED_VARIABLE = YES;
- MACOSX_DEPLOYMENT_TARGET = 10.6;
- ONLY_ACTIVE_ARCH = YES;
- PREBINDING = NO;
- SDKROOT = macosx;
- };
- name = Debug;
- };
- 1DEB927A08733DD40010E9CD /* Release */ = {
- isa = XCBuildConfiguration;
- buildSettings = {
- GCC_WARN_ABOUT_RETURN_TYPE = YES;
- GCC_WARN_UNUSED_VARIABLE = YES;
- MACOSX_DEPLOYMENT_TARGET = 10.6;
- PREBINDING = NO;
- SDKROOT = macosx;
- };
- name = Release;
- };
-/* End XCBuildConfiguration section */
-
-/* Begin XCConfigurationList section */
- 1DEB927408733DD40010E9CD /* Build configuration list for PBXNativeTarget "fstest" */ = {
- isa = XCConfigurationList;
- buildConfigurations = (
- 1DEB927508733DD40010E9CD /* Debug */,
- 1DEB927608733DD40010E9CD /* Release */,
- );
- defaultConfigurationIsVisible = 0;
- defaultConfigurationName = Release;
- };
- 1DEB927808733DD40010E9CD /* Build configuration list for PBXProject "fstest" */ = {
- isa = XCConfigurationList;
- buildConfigurations = (
- 1DEB927908733DD40010E9CD /* Debug */,
- 1DEB927A08733DD40010E9CD /* Release */,
- );
- defaultConfigurationIsVisible = 0;
- defaultConfigurationName = Release;
- };
-/* End XCConfigurationList section */
- };
- rootObject = 08FB7793FE84155DC02AAC07 /* Project object */;
-}
diff --git a/tests/fstest/fstest_Prefix.pch b/tests/fstest/fstest_Prefix.pch
deleted file mode 100644
index d3af66c..0000000
--- a/tests/fstest/fstest_Prefix.pch
+++ /dev/null
@@ -1,7 +0,0 @@
-//
-// Prefix header for all source files of the 'fstest' target in the 'fstest' project.
-//
-
-#ifdef __OBJC__
- #import <Foundation/Foundation.h>
-#endif
diff --git a/unison.opam b/unison.opam
index 172c81d..bd74d2a 100644
--- a/unison.opam
+++ b/unison.opam
@@ -1,5 +1,5 @@
opam-version: "2.0"
-maintainer: "juergen@hoetzel.info"
+maintainer: "unison-hackers@lists.seas.upenn.edu"
authors: [
"Trevor Jim"
"Benjamin C. Pierce"
@@ -11,9 +11,9 @@ bug-reports: "https://github.com/bcpierce00/unison/issues"
dev-repo: "git://github.com/bcpierce00/unison.git"
build: ["dune" "build" "-p" name "-j" jobs]
depends: [
- "ocaml" {>= "4.03"}
+ "ocaml" {>= "4.08"}
"dune" {>= "2.3"}
- "lablgtk" {>= "2.18.6"}
+ "lablgtk3" {>= "3.1.0"}
]
synopsis: "File-synchronization tool for Unix and Windows"
description: """