Initial comit - Clone

.git-blame-ignore-revs

@@ -0,0 +1,11 @@
+# Use `git config blame.ignoreRevsFile .git-blame-ignore-revs`
+# to make git blame ignore commits in this file
+
+#First ocamlformat commit:
+a1f95e70a530ea60ee4a13715eb52f06a7a02710
+
+#ocamlformat sosa_(array|num)
+da7c849491f10f9c723b0bf6020a87026ca3f7ec
+
+#Switch to standard ocaml syntax and use jbuilder:
+94c6b620af7d225505102554faea1a1d262e3272

.gitattributes

@@ -0,0 +1,28 @@
+# Set the default behavior, in case people don't have core.autocrlf set.
+# Explicitly declare text files you want to always be normalized and converted
+# to native line endings on checkout.
+*.bat text eol=crlf
+*.config text
+*.cgi text
+*.css text
+*.gw text
+*.gwf text
+*.htm text
+*.html text
+*.in text
+*.iss text eol=crlf
+*.js text
+*.md text
+*.ml text
+*.mli text
+*.opam text
+*.sh text
+*.txt text
+*.1 text
+
+# Denote all files that are truly binary and should not be modified.
+*.bmp binary
+*.ico binary
+*.icns binary
+*.jpg binary
+*.png binary

.github/ISSUE_TEMPLATE/bug_report.md

@@ -0,0 +1,29 @@
+---
+name: Bug report
+about: Create a report
+title: "[BUG]"
+labels: bug
+assignees: ''
+---
+
+**Describe the bug / Description du bogue**
+
+A clear and concise description of what the bug is and how to reproduce it.
+Adding a failing unit test showing the error would be appreciate.
+Do not hesitate to add screenshots.
+
+Une définition claire et concise du bogue, ainsi que la description de la
+manière de le reproduire.
+Des screenshots peuvent aider à la compréhension du problème.
+
+**Expected behavior / Comportement attendu**
+
+A clear and concise description of what you expected to happen.
+
+Une définition claire et concise de ce qui était attendu.
+
+**Versions**
+
+Version of packages used to reproduce the bug.
+
+Les versions des paquets utilisés pour reproduire le bug.

.github/ISSUE_TEMPLATE/feature_request.md

@@ -0,0 +1,17 @@
+---
+name: Feature request
+about: Suggest an idea
+title: "[FEATURE REQUEST]"
+labels: enhancement
+assignees: ''
+
+---
+
+**Is your feature request related to a problem? Please describe.**
+A clear and concise description of what the problem is. Ex. I'm always frustrated when [...]
+
+**Describe the solution you'd like**
+A clear and concise description of what you want to happen.
+
+**Describe alternatives you've considered**
+A clear and concise description of any alternative solutions or features you've considered.

.github/ISSUE_TEMPLATE/other.md

@@ -0,0 +1,7 @@
+---
+name: Other
+about: Anything that is neither a bug report nor a feature request
+title: ''
+labels: ''
+assignees: ''
+---

.github/dependabot.yml

@@ -0,0 +1,14 @@
+version: 2
+updates:
+  - package-ecosystem: "docker"
+    directory: "docker/"
+    schedule:
+      interval: "daily"
+  - package-ecosystem: "gitsubmodule"
+    directory: "/"
+    schedule:
+      interval: "daily"
+  - package-ecosystem: "github-actions"
+    directory: ".github/workflows/"
+    schedule:
+      interval: "daily"

.github/workflows/ci.yml

@@ -0,0 +1,44 @@
+name: build
+on:
+  pull_request:
+    branches:
+      - master
+  push:
+    branches:
+      - master
+jobs:
+  build:
+    strategy:
+      fail-fast: false
+      matrix:
+        os:
+          - macos-latest
+          - ubuntu-latest
+          - windows-latest
+        ocaml-compiler:
+          - 4.14.x
+        include:
+          - os: ubuntu-latest
+            ocaml-version: 4.08.0
+          - os: ubuntu-latest
+            ocaml-version: 5.1.x
+    runs-on: ${{ matrix.os }}
+    steps:
+      - name: Checkout code
+        uses: actions/checkout@v3
+      - name: Use Ocaml ${{ matrix.ocaml-compiler }}
+        uses: ocaml/setup-ocaml@v2
+        with:
+          ocaml-compiler: ${{ matrix.ocaml-compiler }}
+      - name: Setup GeneWeb dependencies + ocamlformat
+        run: |
+          opam pin add . -y --no-action
+          opam depext -y geneweb
+          opam install -y ./*.opam --deps-only --with-test
+          opam pin ocamlformat 0.24.1
+      - name: Make ocamlformat > build > distrib
+        run: |
+          opam exec -- ocaml ./configure.ml --release
+          opam exec -- make build distrib
+      - name: Make CI tests
+        run: opam exec -- make ci

.github/workflows/doc.yml

@@ -0,0 +1,29 @@
+name: deploy-doc
+on:
+  push:
+    branches:
+      - master
+jobs:
+  build-and-deploy:
+    runs-on: ubuntu-latest
+    steps:
+      - name: checkout-code
+        uses: actions/checkout@v3
+      - name: setup-ocaml
+        uses: ocaml/setup-ocaml@v2
+        with:
+          ocaml-compiler: 4.14.0
+      - name: setup
+        run: |
+             opam pin add . -y --no-action
+             opam depext -y geneweb
+             opam install -y ./*.opam --deps-only --with-doc
+      - name: build
+        run: |
+             opam exec -- ocaml ./configure.ml
+             opam exec -- make doc
+      - name: deploy
+        uses: JamesIves/github-pages-deploy-action@v4
+        with:
+          branch: gh-pages # The branch the action should deploy to.
+          folder: _build/default/_doc/_html # The folder the action should deploy.

.github/workflows/docker.yml

@@ -0,0 +1,76 @@
+name: Build Docker image
+
+on:
+  # Allow manual runs.
+  workflow_dispatch:
+  push:
+    branches:
+      - master
+    paths-ignore:
+      - '**/*.md'
+  pull_request:
+    paths-ignore:
+      - '**/*.md'
+
+env:
+  PLATFORMS: linux/arm64/v8,linux/amd64
+  IMAGE_NAME: "geneweb"
+  PUSH_IMAGE: ${{ github.ref == 'refs/heads/master' }}
+
+jobs:
+
+  build-images:
+    runs-on: ubuntu-latest
+
+    steps:
+      - uses: actions/checkout@v3
+        with:
+          submodules: 'true'
+
+      - name: Generate date stamp
+        run: echo "DATESTAMP=$(date +"%Y.%m.%d")" >> $GITHUB_ENV
+
+      - name: Generate Docker image metadata
+        id: docker-meta
+        uses: docker/metadata-action@v4
+        with:
+          images: |
+            ghcr.io/${{ github.repository_owner }}/${{ env.IMAGE_NAME }}
+          #   ${{ secrets.DOCKERHUB_USERNAME }}/${{ env.IMAGE_NAME }}
+          tags: |
+            type=edge,branch=master
+            type=raw,${{ env.DATESTAMP }}
+            type=ref,event=tag
+            type=sha,prefix=,format=short
+
+      - name: Setup QEMU
+        uses: docker/setup-qemu-action@v2
+
+      - name: Setup Docker BuildKit
+        uses: docker/setup-buildx-action@v2
+
+      # - name: Login to DockerHub
+      #   if: ${{ env.PUSH_IMAGE == 'true' }}
+      #   uses: docker/login-action@v2 
+      #   with:
+      #     username: ${{ secrets.DOCKERHUB_USERNAME }}
+      #     password: ${{ secrets.DOCKERHUB_TOKEN }}
+
+      - name: Login to GitHub Container Registry
+        if: ${{ env.PUSH_IMAGE == 'true' }}
+        uses: docker/login-action@v2 
+        with:
+          registry: ghcr.io
+          username: ${{ github.repository_owner }}
+          password: ${{ github.token }}
+
+      - name: Build and push ${{ env.IMAGE_NAME }} Docker image
+        uses: docker/build-push-action@v3
+        with:
+          target: container
+          context: docker/
+          file: docker/Dockerfile
+          platforms: ${{ env.PLATFORMS }}
+          push: ${{ env.PUSH_IMAGE }}
+          tags: ${{ steps.docker-meta.outputs.tags }}
+          labels: ${{ steps.docker-meta.outputs.labels }}

.github/workflows/release.yml

@@ -0,0 +1,69 @@
+name: release
+
+on:
+  push:
+    tags:
+      - v**
+
+jobs:
+
+  release:
+
+    strategy:
+
+      fail-fast: false
+
+      matrix:
+
+        include:
+          - os: macos-latest
+            ocaml-version: 4.14.0
+            geneweb-archive: geneweb-macos.zip
+          - os: ubuntu-latest
+            ocaml-version: 4.14.0
+            geneweb-archive: geneweb-linux.zip
+          - os: windows-latest
+            ocaml-version: 4.14.0
+            geneweb-archive: geneweb-windows.zip
+
+    runs-on: ${{ matrix.os }}
+
+    steps:
+
+      - name: checkout
+        uses: actions/checkout@v3
+
+      - name: setup-ocaml
+        uses: ocaml/setup-ocaml@v2
+        with:
+          ocaml-compiler: ${{ matrix.ocaml-version }}
+
+      - name: setup
+        run: |
+          opam install dune ocamlformat.0.24.1
+          opam exec -- dune build @fmt
+          opam pin add . -y --no-action
+          opam depext -y geneweb
+          opam install -y ./*.opam --deps-only --with-test
+
+      # Build the distribution
+      - name: Build the distribution
+        run: |
+          opam exec -- ocaml ./configure.ml --sosa-legacy --gwdb-legacy --release
+          opam exec -- make distrib
+
+      # Archive distribution for release
+      - name: Archive Release
+        uses: thedoctor0/zip-release@0.7.1
+        with:
+          type: zip
+          filename: ${{ matrix.geneweb-archive }}
+          directory: distribution
+
+      # Upload the distribution
+      - name: Upload distribution to release
+        uses: svenstaro/upload-release-action@v2
+        with:
+          repo_token: ${{ secrets.GITHUB_TOKEN }}
+          file: distribution/${{ matrix.geneweb-archive }}
+          tag: ${{ github.ref }}

.gitignore

@@ -0,0 +1,45 @@
+.merlin
+
+distribution
+
+Makefile.config
+Makefile.local
+
+# Generated from dune.in files
+benchmark/dune
+bin/cache_files/dune
+bin/connex/dune
+bin/consang/dune
+bin/fixbase/dune
+bin/ged2gwb/dune
+bin/gwb2ged/dune
+bin/gwc/dune
+bin/gwd/dune
+bin/gwdiff/dune
+bin/gwgc/dune
+bin/gwrepl/.depend
+bin/gwrepl/dune
+bin/gwu/dune
+bin/setup/dune
+bin/update_nldb/dune
+lib/core/dune
+lib/dune
+lib/gwdb/dune
+lib/util/dune
+plugins/welcome/dune
+test/dune
+
+dune-workspace
+
+# Generated by jbuilder
+_build/
+*.exe
+*.bc
+*.install
+
+# generated by Makefile
+hd/etc/version.txt
+lib/version.ml
+lib/gwlib.ml
+*~
+/_opam

.ocamlformat

@@ -0,0 +1,2 @@
+profile = default
+version = 0.24.1

.ocamlformat-ignore

@@ -0,0 +1,7 @@
+plugins/forum/plugin_forum.cppo.ml
+bin/ged2gwb/ged2gwb.ml
+bin/gwd/gwd.ml
+bin/gwd/gwdLog.ml
+bin/gwd/request.ml
+bin/setup/setup.ml
+lib/util/mutil.ml

CONTRIBUTING.md

@@ -0,0 +1,37 @@
+# Contributing
+
+When contributing to this repository, please first discuss the change
+you wish to make via issue, email, or any other method with the owners
+of this repository before making a change.
+
+## Pull request validation
+
+When proposing a PR:
+
+- Describe what problem it solves, what side effects come with it.
+- Describe how to test the PR.
+- Adding some screenshots will help.
+- Add some documentation if relevant.
+- Add some unit tests if relevant.
+- Add some benchmarks if relevant.
+- Add some comments around blocks/functions if relevant.
+- Format your code with ocamlformat (use `make fmt`).
+
+Some reasons why a PR could be refused:
+
+- PR is not meeting one of the previous points.
+- PR is not meeting
+  [milestones](https://github.com/geneweb/geneweb/milestones) goals.
+- PR is conflicting with another PR, and the latter is being preferred.
+- PR slows down GeneWeb, or it obviously does too many
+  computations for the task being accomplished. It needs to be
+  optimized.
+- PR is using copy-n-paste programming. It needs to be factorized.
+- PR contains commented code: remove it.
+- PR adds new features or changes the behavior of GeneWeb without
+  having been approved by the current project owners first.
+- PR is too big and needs to be split into many smaller ones.
+- PR is not formatted with ocamlformat.
+
+If a PR stays in a stale/WIP/POC state for too long, it may be closed
+at any time.

INSTALL

@@ -0,0 +1,59 @@
+INSTALLATIONS INSTRUCTIONS IN UNIX or MACOSX MACHINES
+
+For the compilation, you need the Objective Caml compiler installed
+in your computer. The compilation works for several versions of ocaml.
+You also need the preprocessor camlp5.
+
+They freely distributed at address:
+     http://caml.inria.fr/ocaml/
+     http://pauillac.inria.fr/~ddr/camlp5/
+
+1- In the top directory, do:
+      ./configure
+
+2- Do:
+      make
+
+   If your platform does not have the command ocamlopt, the
+   executables will be slower.
+
+3- Do:
+      make distrib
+
+   This creates a directory "distribution" where all executables programs
+   and documentation are copied.
+
+   This can constitute a "distribution" directory if you want to distribute
+   executables.
+
+4- To use GeneWeb, move the directory "distribution" to another place, or
+   rename it.
+   On macOSX, do:
+   	   make install
+   This will install the distribution folder on your Desktop and rename it "GeneWeb-7.00-Mac" 
+   (or another name of your choice).
+
+   Go to this directory and launch the commands "./gwd" and possibly "./gwsetup".
+   On macOSX, geneweb.command will kill previous instances, launch both gwd and gwsetup 
+   and minimize the window.
+
+   The reason why it is much better to move this directory is that "make clean"
+   deletes it, and another "make distrib" overwrites it. If you created
+   genealogic databases inside, they would be deleted.
+
+
+INSTALLATIONS INSTRUCTIONS IN WINDOWS NT/95/98
+
+You need:
+
+- The Cygnus GNU-Win32 development tool, free (search in the Web)
+
+- The Microsoft Visual C++ compiler.
+
+- The Microsoft Assembler masm.
+
+- The Objective Caml compiler.
+
+- The Camlp5 preprocessor.
+
+Follow the same instructions above than for the Unix installation.

LICENSE

@@ -0,0 +1,340 @@
+		    GNU GENERAL PUBLIC LICENSE
+		       Version 2, June 1991
+
+ Copyright (C) 1989, 1991 Free Software Foundation, Inc.
+                       59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
+ Everyone is permitted to copy and distribute verbatim copies
+ of this license document, but changing it is not allowed.
+
+			    Preamble
+
+  The licenses for most software are designed to take away your
+freedom to share and change it.  By contrast, the GNU General Public
+License is intended to guarantee your freedom to share and change free
+software--to make sure the software is free for all its users.  This
+General Public License applies to most of the Free Software
+Foundation's software and to any other program whose authors commit to
+using it.  (Some other Free Software Foundation software is covered by
+the GNU Library General Public License instead.)  You can apply it to
+your programs, too.
+
+  When we speak of free software, we are referring to freedom, not
+price.  Our General Public Licenses are designed to make sure that you
+have the freedom to distribute copies of free software (and charge for
+this service if you wish), that you receive source code or can get it
+if you want it, that you can change the software or use pieces of it
+in new free programs; and that you know you can do these things.
+
+  To protect your rights, we need to make restrictions that forbid
+anyone to deny you these rights or to ask you to surrender the rights.
+These restrictions translate to certain responsibilities for you if you
+distribute copies of the software, or if you modify it.
+
+  For example, if you distribute copies of such a program, whether
+gratis or for a fee, you must give the recipients all the rights that
+you have.  You must make sure that they, too, receive or can get the
+source code.  And you must show them these terms so they know their
+rights.
+
+  We protect your rights with two steps: (1) copyright the software, and
+(2) offer you this license which gives you legal permission to copy,
+distribute and/or modify the software.
+
+  Also, for each author's protection and ours, we want to make certain
+that everyone understands that there is no warranty for this free
+software.  If the software is modified by someone else and passed on, we
+want its recipients to know that what they have is not the original, so
+that any problems introduced by others will not reflect on the original
+authors' reputations.
+
+  Finally, any free program is threatened constantly by software
+patents.  We wish to avoid the danger that redistributors of a free
+program will individually obtain patent licenses, in effect making the
+program proprietary.  To prevent this, we have made it clear that any
+patent must be licensed for everyone's free use or not licensed at all.
+
+  The precise terms and conditions for copying, distribution and
+modification follow.
+
+		    GNU GENERAL PUBLIC LICENSE
+   TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION
+
+  0. This License applies to any program or other work which contains
+a notice placed by the copyright holder saying it may be distributed
+under the terms of this General Public License.  The "Program", below,
+refers to any such program or work, and a "work based on the Program"
+means either the Program or any derivative work under copyright law:
+that is to say, a work containing the Program or a portion of it,
+either verbatim or with modifications and/or translated into another
+language.  (Hereinafter, translation is included without limitation in
+the term "modification".)  Each licensee is addressed as "you".
+
+Activities other than copying, distribution and modification are not
+covered by this License; they are outside its scope.  The act of
+running the Program is not restricted, and the output from the Program
+is covered only if its contents constitute a work based on the
+Program (independent of having been made by running the Program).
+Whether that is true depends on what the Program does.
+
+  1. You may copy and distribute verbatim copies of the Program's
+source code as you receive it, in any medium, provided that you
+conspicuously and appropriately publish on each copy an appropriate
+copyright notice and disclaimer of warranty; keep intact all the
+notices that refer to this License and to the absence of any warranty;
+and give any other recipients of the Program a copy of this License
+along with the Program.
+
+You may charge a fee for the physical act of transferring a copy, and
+you may at your option offer warranty protection in exchange for a fee.
+
+  2. You may modify your copy or copies of the Program or any portion
+of it, thus forming a work based on the Program, and copy and
+distribute such modifications or work under the terms of Section 1
+above, provided that you also meet all of these conditions:
+
+    a) You must cause the modified files to carry prominent notices
+    stating that you changed the files and the date of any change.
+
+    b) You must cause any work that you distribute or publish, that in
+    whole or in part contains or is derived from the Program or any
+    part thereof, to be licensed as a whole at no charge to all third
+    parties under the terms of this License.
+
+    c) If the modified program normally reads commands interactively
+    when run, you must cause it, when started running for such
+    interactive use in the most ordinary way, to print or display an
+    announcement including an appropriate copyright notice and a
+    notice that there is no warranty (or else, saying that you provide
+    a warranty) and that users may redistribute the program under
+    these conditions, and telling the user how to view a copy of this
+    License.  (Exception: if the Program itself is interactive but
+    does not normally print such an announcement, your work based on
+    the Program is not required to print an announcement.)
+
+These requirements apply to the modified work as a whole.  If
+identifiable sections of that work are not derived from the Program,
+and can be reasonably considered independent and separate works in
+themselves, then this License, and its terms, do not apply to those
+sections when you distribute them as separate works.  But when you
+distribute the same sections as part of a whole which is a work based
+on the Program, the distribution of the whole must be on the terms of
+this License, whose permissions for other licensees extend to the
+entire whole, and thus to each and every part regardless of who wrote it.
+
+Thus, it is not the intent of this section to claim rights or contest
+your rights to work written entirely by you; rather, the intent is to
+exercise the right to control the distribution of derivative or
+collective works based on the Program.
+
+In addition, mere aggregation of another work not based on the Program
+with the Program (or with a work based on the Program) on a volume of
+a storage or distribution medium does not bring the other work under
+the scope of this License.
+
+  3. You may copy and distribute the Program (or a work based on it,
+under Section 2) in object code or executable form under the terms of
+Sections 1 and 2 above provided that you also do one of the following:
+
+    a) Accompany it with the complete corresponding machine-readable
+    source code, which must be distributed under the terms of Sections
+    1 and 2 above on a medium customarily used for software interchange; or,
+
+    b) Accompany it with a written offer, valid for at least three
+    years, to give any third party, for a charge no more than your
+    cost of physically performing source distribution, a complete
+    machine-readable copy of the corresponding source code, to be
+    distributed under the terms of Sections 1 and 2 above on a medium
+    customarily used for software interchange; or,
+
+    c) Accompany it with the information you received as to the offer
+    to distribute corresponding source code.  (This alternative is
+    allowed only for noncommercial distribution and only if you
+    received the program in object code or executable form with such
+    an offer, in accord with Subsection b above.)
+
+The source code for a work means the preferred form of the work for
+making modifications to it.  For an executable work, complete source
+code means all the source code for all modules it contains, plus any
+associated interface definition files, plus the scripts used to
+control compilation and installation of the executable.  However, as a
+special exception, the source code distributed need not include
+anything that is normally distributed (in either source or binary
+form) with the major components (compiler, kernel, and so on) of the
+operating system on which the executable runs, unless that component
+itself accompanies the executable.
+
+If distribution of executable or object code is made by offering
+access to copy from a designated place, then offering equivalent
+access to copy the source code from the same place counts as
+distribution of the source code, even though third parties are not
+compelled to copy the source along with the object code.
+
+  4. You may not copy, modify, sublicense, or distribute the Program
+except as expressly provided under this License.  Any attempt
+otherwise to copy, modify, sublicense or distribute the Program is
+void, and will automatically terminate your rights under this License.
+However, parties who have received copies, or rights, from you under
+this License will not have their licenses terminated so long as such
+parties remain in full compliance.
+
+  5. You are not required to accept this License, since you have not
+signed it.  However, nothing else grants you permission to modify or
+distribute the Program or its derivative works.  These actions are
+prohibited by law if you do not accept this License.  Therefore, by
+modifying or distributing the Program (or any work based on the
+Program), you indicate your acceptance of this License to do so, and
+all its terms and conditions for copying, distributing or modifying
+the Program or works based on it.
+
+  6. Each time you redistribute the Program (or any work based on the
+Program), the recipient automatically receives a license from the
+original licensor to copy, distribute or modify the Program subject to
+these terms and conditions.  You may not impose any further
+restrictions on the recipients' exercise of the rights granted herein.
+You are not responsible for enforcing compliance by third parties to
+this License.
+
+  7. If, as a consequence of a court judgment or allegation of patent
+infringement or for any other reason (not limited to patent issues),
+conditions are imposed on you (whether by court order, agreement or
+otherwise) that contradict the conditions of this License, they do not
+excuse you from the conditions of this License.  If you cannot
+distribute so as to satisfy simultaneously your obligations under this
+License and any other pertinent obligations, then as a consequence you
+may not distribute the Program at all.  For example, if a patent
+license would not permit royalty-free redistribution of the Program by
+all those who receive copies directly or indirectly through you, then
+the only way you could satisfy both it and this License would be to
+refrain entirely from distribution of the Program.
+
+If any portion of this section is held invalid or unenforceable under
+any particular circumstance, the balance of the section is intended to
+apply and the section as a whole is intended to apply in other
+circumstances.
+
+It is not the purpose of this section to induce you to infringe any
+patents or other property right claims or to contest validity of any
+such claims; this section has the sole purpose of protecting the
+integrity of the free software distribution system, which is
+implemented by public license practices.  Many people have made
+generous contributions to the wide range of software distributed
+through that system in reliance on consistent application of that
+system; it is up to the author/donor to decide if he or she is willing
+to distribute software through any other system and a licensee cannot
+impose that choice.
+
+This section is intended to make thoroughly clear what is believed to
+be a consequence of the rest of this License.
+
+  8. If the distribution and/or use of the Program is restricted in
+certain countries either by patents or by copyrighted interfaces, the
+original copyright holder who places the Program under this License
+may add an explicit geographical distribution limitation excluding
+those countries, so that distribution is permitted only in or among
+countries not thus excluded.  In such case, this License incorporates
+the limitation as if written in the body of this License.
+
+  9. The Free Software Foundation may publish revised and/or new versions
+of the General Public License from time to time.  Such new versions will
+be similar in spirit to the present version, but may differ in detail to
+address new problems or concerns.
+
+Each version is given a distinguishing version number.  If the Program
+specifies a version number of this License which applies to it and "any
+later version", you have the option of following the terms and conditions
+either of that version or of any later version published by the Free
+Software Foundation.  If the Program does not specify a version number of
+this License, you may choose any version ever published by the Free Software
+Foundation.
+
+  10. If you wish to incorporate parts of the Program into other free
+programs whose distribution conditions are different, write to the author
+to ask for permission.  For software which is copyrighted by the Free
+Software Foundation, write to the Free Software Foundation; we sometimes
+make exceptions for this.  Our decision will be guided by the two goals
+of preserving the free status of all derivatives of our free software and
+of promoting the sharing and reuse of software generally.
+
+			    NO WARRANTY
+
+  11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY
+FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW.  EXCEPT WHEN
+OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES
+PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED
+OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
+MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE.  THE ENTIRE RISK AS
+TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU.  SHOULD THE
+PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING,
+REPAIR OR CORRECTION.
+
+  12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING
+WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR
+REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES,
+INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING
+OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED
+TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY
+YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER
+PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE
+POSSIBILITY OF SUCH DAMAGES.
+
+		     END OF TERMS AND CONDITIONS
+
+	    How to Apply These Terms to Your New Programs
+
+  If you develop a new program, and you want it to be of the greatest
+possible use to the public, the best way to achieve this is to make it
+free software which everyone can redistribute and change under these terms.
+
+  To do so, attach the following notices to the program.  It is safest
+to attach them to the start of each source file to most effectively
+convey the exclusion of warranty; and each file should have at least
+the "copyright" line and a pointer to where the full notice is found.
+
+    <one line to give the program's name and a brief idea of what it does.>
+    Copyright (C) 19yy  <name of author>
+
+    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 2 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, write to the Free Software
+    Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
+
+
+Also add information on how to contact you by electronic and paper mail.
+
+If the program is interactive, make it output a short notice like this
+when it starts in an interactive mode:
+
+    Gnomovision version 69, Copyright (C) 19yy name of author
+    Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'.
+    This is free software, and you are welcome to redistribute it
+    under certain conditions; type `show c' for details.
+
+The hypothetical commands `show w' and `show c' should show the appropriate
+parts of the General Public License.  Of course, the commands you use may
+be called something other than `show w' and `show c'; they could even be
+mouse-clicks or menu items--whatever suits your program.
+
+You should also get your employer (if you work as a programmer) or your
+school, if any, to sign a "copyright disclaimer" for the program, if
+necessary.  Here is a sample; alter the names:
+
+  Yoyodyne, Inc., hereby disclaims all copyright interest in the program
+  `Gnomovision' (which makes passes at compilers) written by James Hacker.
+
+  <signature of Ty Coon>, 1 April 1989
+  Ty Coon, President of Vice
+
+This General Public License does not permit incorporating your program into
+proprietary programs.  If your program is a subroutine library, you may
+consider it more useful to permit linking proprietary applications with the
+library.  If this is what you want to do, use the GNU Library General
+Public License instead of this License.

Makefile

@@ -0,0 +1,260 @@
+ifneq ($(MAKECMDGOALS),ci)
+Makefile.config: configure.ml
+	@if [ -e "$@" ]; then \
+	  echo "configure file has changed. Please rerun ocaml ./configure.ml"; exit 1; \
+	else \
+	  echo "Please run ocaml ./configure.ml first"; exit 1; \
+	fi
+include Makefile.config
+endif
+
+-include Makefile.local
+
+# Variables for packagers.
+DISTRIB_DIR=distribution
+BUILD_DIR=_build/default
+BUILD_DISTRIB_DIR=$(BUILD_DIR)/bin/
+ODOC_DIR=$(BUILD_DIR)/_doc/_html
+
+# [BEGIN] Generated files section
+
+CPPO_D=$(GWDB_D) $(OS_D) $(SYSLOG_D) $(SOSA_D)
+
+ifeq ($(DUNE_PROFILE),dev)
+    CPPO_D+= -D DEBUG
+endif
+
+%/dune: %/dune.in Makefile.config
+	@printf "Generating $@…" \
+	&& cat $< \
+	| cppo -n $(CPPO_D) \
+	| sed \
+	-e "s/%%%CPPO_D%%%/$(CPPO_D)/g" \
+	-e "s/%%%SOSA_PKG%%%/$(SOSA_PKG)/g" \
+	-e "s/%%%GWDB_PKG%%%/$(GWDB_PKG)/g" \
+	-e "s/%%%SYSLOG_PKG%%%/$(SYSLOG_PKG)/g" \
+	-e "s/%%%DUNE_DIRS_EXCLUDE%%%/$(DUNE_DIRS_EXCLUDE)/g" \
+	> $@ \
+	&& printf " Done.\n"
+
+bin/gwrepl/.depend:
+	@printf "Generating $@…"
+	@pwd > $@
+	@dune top bin/gwrepl >> $@
+	@printf " Done.\n"
+
+dune-workspace: dune-workspace.in Makefile.config
+	@cat $< | sed  -e "s/%%%DUNE_PROFILE%%%/$(DUNE_PROFILE)/g" > $@
+
+COMPIL_DATE := $(shell date +'%Y-%m-%d')
+COMMIT_DATE := $(shell git show -s --date=short --pretty=format:'%cd')
+COMMIT_ID := $(shell git rev-parse --short HEAD)
+COMMIT_MSG := $(shell git log -1 --pretty="%s%n%n%b" | sed 's/"/\\"/g')
+BRANCH := $(shell git rev-parse --abbrev-ref HEAD)
+VERSION := $(shell awk -F\" '/er =/ {print $$2}' lib/version.txt)
+SOURCE := $(shell git remote get-url origin | sed -n 's|^.*m/\([^/]\+/[^/.]\+\)\(.git\)\?|\1|p')
+OCAMLV := $(shell ocaml --version)
+
+lib/version.ml:
+	@cp lib/version.txt $@
+	@printf "let branch = \"$(BRANCH)\"\n" >> $@
+	@printf "let src = \"$(SOURCE)\"\n" >> $@
+	@printf "let commit_id = \"$(COMMIT_ID)\"\n" >> $@
+	@printf "let commit_date = \"$(COMMIT_DATE)\"\n" >> $@
+	@printf "let compil_date = \"$(COMPIL_DATE)\"\n" >> $@
+	@printf "Generating $@… Done.\n"
+.PHONY: lib/version.ml
+
+info:
+	@printf "Building \033[1;37mGeneweb $(VERSION)\033[0m with $(OCAMLV).\n\n"
+	@printf "Repository \033[1;37m$(SOURCE)\033[0m. Branch \033[1;37m$(BRANCH)\033[0m.\n\n"
+	@printf "Last commit \033[1;37m$(COMMIT_ID)\033[0m with message “\033[1;37m%s\033[0m”.\n" '$(subst ','\'',$(COMMIT_MSG))'
+	@printf "\n\033[1;37mGenerating configuration files\033[0m\n"
+
+GENERATED_FILES_DEP = \
+	dune-workspace \
+	lib/version.ml \
+	lib/dune \
+	lib/gwdb/dune \
+	lib/core/dune \
+	lib/util/dune \
+	benchmark/dune \
+	bin/connex/dune \
+	bin/cache_files/dune \
+	bin/consang/dune \
+	bin/fixbase/dune \
+	bin/ged2gwb/dune \
+	bin/gwb2ged/dune \
+	bin/gwc/dune \
+	bin/gwd/dune \
+	bin/gwdiff/dune \
+	bin/gwgc/dune \
+	bin/gwrepl/dune \
+	bin/gwrepl/.depend \
+	bin/gwu/dune \
+	bin/setup/dune \
+	bin/update_nldb/dune \
+	test/dune \
+
+generated: $(GENERATED_FILES_DEP)
+
+install uninstall build distrib: info $(GENERATED_FILES_DEP)
+
+fmt:
+	$(RM) -r $(DISTRIB_DIR)
+	dune build @fmt --auto-promote
+
+# [BEGIN] Installation / Distribution section
+
+build: ## Build the geneweb package (libraries and binaries)
+build:
+ifneq ($(OS_TYPE),Win)
+	@printf "\n\033[1;37mOcamlformat\033[0m\n"
+	dune build @fmt --auto-promote
+endif
+	@printf "\n\033[1;37mBuilding executables\033[0m\n"
+	dune build -p geneweb --profile $(DUNE_PROFILE)
+
+install: ## Install geneweb using dune
+install:
+	dune build @install --profile $(DUNE_PROFILE)
+	dune install
+
+uninstall: ## Uninstall geneweb using dune
+uninstall:
+	dune build @install --profile $(DUNE_PROFILE)
+	dune uninstall
+
+distrib: build ## Build the project and copy what is necessary for distribution
+distrib:
+	$(RM) -r $(DISTRIB_DIR)
+	@printf "\n\033[1;37mCreating distribution directory\033[0m\n"
+	mkdir $(DISTRIB_DIR)
+	mkdir -p $(DISTRIB_DIR)/bases
+	cp CHANGES $(DISTRIB_DIR)/CHANGES.txt
+	cp LICENSE $(DISTRIB_DIR)/LICENSE.txt
+	cp etc/README.txt $(DISTRIB_DIR)/.
+	cp etc/LISEZMOI.txt $(DISTRIB_DIR)/.
+	cp etc/START.htm $(DISTRIB_DIR)/.
+ifeq ($(OS_TYPE),Win)
+	cp etc/Windows/gwd.bat $(DISTRIB_DIR)
+	cp etc/Windows/gwsetup.bat $(DISTRIB_DIR)
+	cp -f etc/Windows/README.txt $(DISTRIB_DIR)/README.txt
+	cp -f etc/Windows/LISEZMOI.txt $(DISTRIB_DIR)/LISEZMOI.txt
+else ifeq ($(OS_TYPE),Darwin)
+	cp etc/gwd.sh $(DISTRIB_DIR)
+	cp etc/gwsetup.sh $(DISTRIB_DIR)
+	cp etc/macOS/geneweb.sh $(DISTRIB_DIR)
+else
+	cp etc/gwd.sh $(DISTRIB_DIR)/gwd.sh
+	cp etc/gwsetup.sh $(DISTRIB_DIR)/gwsetup.sh
+endif
+	mkdir $(DISTRIB_DIR)/gw
+	cp etc/a.gwf $(DISTRIB_DIR)/gw/.
+	echo "-setup_link" > $(DISTRIB_DIR)/gw/gwd.arg
+	@printf "\n\033[1;37m└ Copy binaries in $(DISTRIB_DIR)/gw/\033[0m\n"
+	cp $(BUILD_DISTRIB_DIR)connex/connex.exe $(DISTRIB_DIR)/gw/connex$(EXT)
+	cp $(BUILD_DISTRIB_DIR)consang/consang.exe $(DISTRIB_DIR)/gw/consang$(EXT)
+	cp $(BUILD_DISTRIB_DIR)fixbase/gwfixbase.exe $(DISTRIB_DIR)/gw/gwfixbase$(EXT)
+	cp $(BUILD_DISTRIB_DIR)ged2gwb/ged2gwb.exe $(DISTRIB_DIR)/gw/ged2gwb$(EXT)
+	cp $(BUILD_DISTRIB_DIR)gwb2ged/gwb2ged.exe $(DISTRIB_DIR)/gw/gwb2ged$(EXT)
+	cp $(BUILD_DISTRIB_DIR)cache_files/cache_files.exe $(DISTRIB_DIR)/gw/cache_files$(EXT)
+	cp $(BUILD_DISTRIB_DIR)gwc/gwc.exe $(DISTRIB_DIR)/gw/gwc$(EXT)
+	cp $(BUILD_DISTRIB_DIR)gwd/gwd.exe $(DISTRIB_DIR)/gw/gwd$(EXT)
+	cp $(BUILD_DISTRIB_DIR)gwdiff/gwdiff.exe $(DISTRIB_DIR)/gw/gwdiff$(EXT)
+	if test -f $(BUILD_DISTRIB_DIR)gwrepl/gwrepl.bc ; then cp $(BUILD_DISTRIB_DIR)gwrepl/gwrepl.bc $(DISTRIB_DIR)/gw/gwrepl$(EXT); fi
+	cp $(BUILD_DISTRIB_DIR)gwu/gwu.exe $(DISTRIB_DIR)/gw/gwu$(EXT)
+	cp $(BUILD_DISTRIB_DIR)setup/setup.exe $(DISTRIB_DIR)/gw/gwsetup$(EXT)
+	cp $(BUILD_DISTRIB_DIR)update_nldb/update_nldb.exe $(DISTRIB_DIR)/gw/update_nldb$(EXT)
+	@printf "\n\033[1;37m└ Copy templates in $(DISTRIB_DIR)/gw/\033[0m\n"
+	cp -R hd/* $(DISTRIB_DIR)/gw/
+	mkdir $(DISTRIB_DIR)/gw/setup
+	cp bin/setup/intro.txt $(DISTRIB_DIR)/gw/setup/
+	mkdir $(DISTRIB_DIR)/gw/setup/lang
+	cp bin/setup/setup.gwf $(DISTRIB_DIR)/gw/setup/
+	cp bin/setup/setup.css $(DISTRIB_DIR)/gw/setup/
+	cp bin/setup/lang/*.htm $(DISTRIB_DIR)/gw/setup/lang/
+	cp bin/setup/lang/lexicon.txt $(DISTRIB_DIR)/gw/setup/lang/
+	cp bin/setup/lang/intro.txt $(DISTRIB_DIR)/gw/setup/lang/
+	@printf "\n\033[1;37m└ Copy plugins in $(DISTRIB_DIR)/gw/plugins\033[0m\n"
+	mkdir $(DISTRIB_DIR)/gw/plugins
+	for P in $(shell ls plugins); do \
+		if [ -f $(BUILD_DIR)/plugins/$$P/plugin_$$P.cmxs ] ; then \
+			mkdir $(DISTRIB_DIR)/gw/plugins/$$P; \
+			cp $(BUILD_DIR)/plugins/$$P/plugin_$$P.cmxs $(DISTRIB_DIR)/gw/plugins/$$P/; \
+			if [ -d plugins/$$P/assets ] ; then \
+				cp -R $(BUILD_DIR)/plugins/$$P/assets $(DISTRIB_DIR)/gw/plugins/$$P/; \
+			fi; \
+			if [ -f $(BUILD_DIR)/plugins/$$P/META ] ; then \
+				cp $(BUILD_DIR)/plugins/$$P/META $(DISTRIB_DIR)/gw/plugins/$$P/; \
+			fi; \
+		fi; \
+	done
+	@printf "\033[1;37mBuild complete.\033[0m\n"
+	@printf "You can launch Geneweb with “\033[1;37mcd $(DISTRIB_DIR)\033[0m” followed by “\033[1;37mgw/gwd$(EXT)\033[0m”.\n"
+.PHONY: install uninstall distrib
+
+# [END] Installation / Distribution section
+
+doc: ## Documentation generation
+doc: | $(GENERATED_FILES_DEP)
+	dune build @doc
+.PHONY: doc
+
+opendoc: doc
+	xdg-open $(ODOC_DIR)/index.html
+.PHONY: opendoc
+
+test: ## Run tests
+test: | $(GENERATED_FILES_DEP)
+	dune build @runtest
+.PHONY: test
+
+bench: ## Run benchmarks
+bench: | $(GENERATED_FILES_DEP)
+	dune build @runbench
+.PHONY: bench
+
+BENCH_FILE?=geneweb-bench.bin
+
+bench-marshal: ## Run benchmarks and record the result
+bench-marshal: | $(GENERATED_FILES_DEP)
+ifdef BENCH_NAME
+	dune exec benchmark/bench.exe -- --marshal --name ${BENCH_NAME} ${BENCH_FILE}
+else
+	 $(error BENCH_NAME variable is empty)
+endif
+.PHONY: bench-marshal
+
+bench-tabulate: ## Read BENCH_FILE and print a report
+bench-tabulate: | $(GENERATED_FILES_DEP)
+	dune exec benchmark/bench.exe -- --tabulate ${BENCH_FILE}
+	@$(RM) $(BENCH_FILE)
+.PHONY: bench-tabulate
+
+clean:
+	@echo -n "Cleaning…"
+	@$(RM) $(GENERATED_FILES_DEP)
+	@$(RM) -r $(DISTRIB_DIR)
+	@dune clean
+	@echo " Done."
+.PHONY: clean
+
+ci: ## Run tests, skip known failures
+ci:
+	@ocaml ./configure.ml && $(MAKE) -s clean build && GENEWEB_CI=on dune runtest
+.PHONY: ci
+
+ocp-indent: ## Run ocp-indent (inplace edition)
+ocp-indent:
+	for f in `find lib bin -type f -regex .*[.]ml[i]?` ; do \
+		echo $$f ; \
+		ocp-indent -i $$f ; \
+	done
+.PHONY: ocp-indent
+
+.DEFAULT_GOAL := help
+help:
+	@clear;grep -E '(^[a-zA-Z_-]+:.*?##.*$$)|(^##)' Makefile | awk 'BEGIN {FS = ":.*?#\
+# "}; {printf "\033[32m%-30s\033[0m %s\n", $$1, $$2}' | sed -e 's/\[32m## /[33m/'
+.PHONY: help

README.md

@@ -0,0 +1,140 @@
+# GeneWeb
+
+[![build status](https://github.com/geneweb/geneweb/actions/workflows/ci.yml/badge.svg)](https://github.com/geneweb/geneweb/actions/workflows/ci.yml)
+
+GeneWeb is an open source genealogy software written in OCaml. It comes
+with a Web interface and can be used off-line or as a Web service.
+
+## Documentation
+
+- Documentation maintained by the community: https://geneweb.tuxfamily.org/
+- GeneWeb API (generated from source): http://geneweb.github.io/geneweb/
+- GeneWeb overview (realized by OCamlPro): https://geneweb.github.io/
+
+## Quick and easy live GeneWeb test
+
+- Test your GeneWeb database on current master: https://github.com/geneweb/geneweb/blob/master/geneweb_colab.ipynb
+
+## Installation (for users)
+
+WARNING: before installing a new version of GeneWeb, it is highly recommended to save
+your bases into .gw formatted files.
+
+When installing a version of GeneWeb with the "pre-release" qualifier, you are
+participating to the collective test effort (thanks for your contribution). You should keep aside the previous version
+you were using and refrain from extensive updates or additions in your bases
+until the "release" qualifier is effective.
+
+Any problem you encounter or issue you want to raise should be entered on the issue page
+of the GitHub repository (https://github.com/geneweb/geneweb/issues).
+
+Download the file corresponding to your environment from
+the [releases page](https://github.com/geneweb/geneweb/releases).
+
+Extract the distribution folder and place it at the location of your choice. You may also rename it.
+Its content is as follows (this example is for a GNU/Linux distribution;
+other distributions are very similar):
+
+```
+distribution/
+├── bases
+├── CHANGES.txt
+├── gw
+   ├── a.gwf
+   ├── connex
+   ├── consang
+   ├── etc
+   ├── ged2gwb
+   ├── gwb2ged
+   ├── gwc
+   ├── gwd
+   ├── gwd.arg
+   ├── gwdiff
+   ├── gwfixbase
+   ├── gwrepl
+   ├── gwsetup
+   ├── gwu
+   ├── images
+   ├── lang
+   ├── plugins
+   ├── setup
+   └── update_nldb
+├── gwd.sh
+├── gwsetup.sh
+├── install-cgi
+├── install-cgi.sh
+├── LICENSE.txt
+├── LISEZMOI.txt
+├── README.txt
+└── START.htm
+```
+
+Starting the GeneWeb servers may depend on your specific environment.
+
+### Windows
+
+TODO
+
+### MacOS
+
+Apple provides a security mechanism preventing users from executing applications
+which are not provided by authenticated developers. Such applications cannot be started
+by double-clicking on their icons.
+Apple provides a two-step mechanism circumventing this security:
+* Right-click on the application icon (```gwd``` and ```gwsetup```). This will pop-up a window
+mentioning the security issue and providing an "open" button. Click on this button to open
+the application. Ignore the resulting messages as no parameters were provided.
+* Once ```gwd``` and ```gwsetup``` have been started in this fashion, they will be white-listed
+on your machine and subsequent opens will succeed.
+
+After white-listing ```gwd``` and ```gwsetup```, double-click on the ```geneweb.command```
+file which will launch both servers with appropriate parameters.
+With the configuration provided in this launch command, the bases are located in
+the ```bases``` folder.
+You may reorganize your folder structure (and launch command) as described in the
+documentation at https://geneweb.tuxfamily.org/.
+
+### Linux
+
+Quite similar to the MacOS solution, without the security check.
+```xxx.command``` files have an equivalent ```xxx.sh``` variant.
+
+## Resources
+
+* Documentation: https://geneweb.tuxfamily.org/wiki/GeneWeb
+* Mailing list: https://framalistes.org/sympa/subscribe/geneweb
+* IRC: irc://irc.libera.chat/geneweb
+* Git: https://github.com/geneweb/geneweb
+* Forum: https://www.geneanet.org/forum/GeneWeb-85
+* Wikipedia: https://en.wikipedia.org/wiki/GeneWeb
+
+## Contribute
+
+See [Contributor guidelines](CONTRIBUTING.md).
+
+### Installation (for developers)
+
+See [geneweb.opam](./geneweb.opam).
+
+### Build instructions
+
+1. Run the configuration script
+   ```
+   $ ocaml ./configure.ml
+   ```
+2. Build the distribution
+   ```
+   $ make clean distrib
+   ```
+
+You can have a description of available configuration options using
+```
+$ ocaml ./configure.ml --help
+```
+
+## Copyright
+
+All files marked in this distribution are Copyright (c) 1998-2016 INRIA
+(Institut National de Recherche en Informatique et Automatique) and
+distributed under the GNU GENERAL PUBLIC LICENSE. See [LICENSE](LICENSE) file
+for details.

benchmark/bench.ml

@@ -0,0 +1,239 @@
+open Geneweb
+
+let style = ref Benchmark.Auto
+
+let test_fn =
+  try
+    let l = String.split_on_char ',' @@ Sys.getenv "BENCH_FN" in
+    fun s -> List.mem s l
+  with Not_found -> fun _ -> true
+
+let bench ?(t = 1) name fn arg =
+  if test_fn name then (
+    Gc.compact ();
+    Benchmark.throughput1 ~style:!style ~name t (List.map fn) arg)
+  else []
+
+let list =
+  [
+    1; 2; 10; 100; 1000; 10000; 100000; 1000000; 10000000; 100000000; 1000000000;
+  ]
+
+let sosa_list = List.map Sosa.of_int list
+
+let bench () =
+  let suite =
+    [
+      bench "Sosa.gen" (List.map Sosa.gen) [ sosa_list ];
+      bench "Sosa.to_string_sep"
+        (List.map @@ Sosa.to_string_sep ",")
+        [ sosa_list ];
+      bench "Sosa.to_string" (List.map Sosa.to_string) [ sosa_list ];
+      bench "Sosa.of_string" (List.map Sosa.of_string)
+        [ List.map string_of_int list ];
+      bench "Sosa.branches" (List.map Sosa.branches) [ sosa_list ];
+      bench "Place.normalize" Geneweb.Place.normalize
+        [
+          "[foo-bar] - boobar (baz)";
+          "[foo-bar] – boobar (baz)";
+          "[foo-bar] — boobar (baz)";
+        ];
+      bench "Mutil.unsafe_tr"
+        (fun s -> Mutil.unsafe_tr 'a' 'b' @@ "a" ^ s)
+        [ "aaaaaaaaaa"; "bbbbbbbbbb"; "abbbbbbbb"; "bbbbbbbbba"; "ababababab" ];
+      bench "Mutil.tr"
+        (fun s -> Mutil.tr 'a' 'b' @@ "a" ^ s)
+        [ "aaaaaaaaaa"; "bbbbbbbbbb"; "abbbbbbbb"; "bbbbbbbbba"; "ababababab" ];
+      bench "Mutil.contains"
+        (Mutil.contains "foobarbaz")
+        [ "foo"; "bar"; "baz"; "foobarbaz!" ];
+      bench "Mutil.start_with"
+        (Mutil.start_with "foobarbaz" 0)
+        [ "foo"; "bar"; ""; "foobarbaz" ];
+      bench "Mutil.start_with_wildcard"
+        (Mutil.start_with_wildcard "foobarbaz" 0)
+        [ "foo"; "bar"; ""; "foobarbaz" ];
+      bench "Place.compare_places"
+        (Place.compare_places "[foo-bar] - baz, boobar")
+        [
+          "[foo-bar] - baz, boobar";
+          "[foo-bar] - baz, boobar, barboo";
+          "baz, boobar";
+        ];
+      bench "Util.name_with_roman_number" Util.name_with_roman_number
+        [
+          "39 39";
+          "39 x 39";
+          "foo 246";
+          "bar 421 baz";
+          "bar 160 baz 207";
+          "foo bar baz";
+        ];
+      bench "Name.lower" Name.lower
+        [ "étienne"; "Étienne"; "ÿvette"; "Ÿvette"; "Ĕtienne" ];
+      bench "Name.split_fname" Name.split_fname
+        [ "Jean-Baptiste Emmanuel"; "Jean Baptiste Emmanuel" ];
+      bench "Name.split_sname" Name.split_sname
+        [ "Jean-Baptiste Emmanuel"; "Jean Baptiste Emmanuel" ];
+      bench ~t:2 "Calendar"
+        (fun () ->
+          let febLength year : int =
+            if (if year < 0 then year + 1 else year) mod 4 = 0 then 29 else 28
+          in
+          let monthLength =
+            [| 31; 28; 31; 30; 31; 30; 31; 31; 30; 31; 30; 31 |]
+          in
+          for year = -4713 to 10000 do
+            if year <> 0 then
+              for month = 1 to 12 do
+                let len =
+                  if month = 2 then febLength year
+                  else Array.get monthLength @@ (month - 1)
+                in
+                for day = 1 to len do
+                  let d =
+                    { Def.day; month; year; delta = 0; prec = Def.Sure }
+                  in
+                  (Sys.opaque_identity ignore)
+                    (Calendar.julian_of_sdn Def.Sure @@ Calendar.sdn_of_julian d)
+                done
+              done
+          done)
+        [ () ];
+    ]
+  in
+  match Sys.getenv_opt "BENCH_BASE" with
+  | Some bname when bname <> "" ->
+      let conf = Config.empty in
+      let bench_w_base ?t ?(load = []) name fn args =
+        Secure.set_base_dir (Filename.dirname bname);
+        let base = Gwdb.open_base bname in
+        List.iter (fun load -> load base) load;
+        let r = bench ?t name (fn base) args in
+        Gwdb.close_base base;
+        r
+      in
+      bench_w_base "UpdateData.get_all_data"
+        (fun base conf -> UpdateData.get_all_data conf base)
+        [ { conf with Config.env = [ ("data", Adef.encoded "place") ] } ]
+      :: bench_w_base "UpdateData.build_list"
+           (fun base conf -> UpdateData.build_list conf base)
+           [
+             {
+               conf with
+               Config.env = [ ("data", Adef.encoded "src") ];
+               wizard = true;
+             };
+             {
+               conf with
+               Config.env = [ ("data", Adef.encoded "place") ];
+               wizard = true;
+             };
+           ]
+      :: bench_w_base "UpdateData.build_list_short"
+           (fun base conf ->
+             UpdateData.build_list_short conf @@ UpdateData.build_list conf base)
+           [
+             {
+               conf with
+               Config.env = [ ("data", Adef.encoded "src") ];
+               wizard = true;
+             };
+             {
+               conf with
+               Config.env = [ ("data", Adef.encoded "place") ];
+               wizard = true;
+             };
+           ]
+      :: bench_w_base
+           ~load:[ Gwdb.load_persons_array ]
+           "Util.authorized_age"
+           (fun base conf ->
+             Gwdb.Collection.iter
+               (Sys.opaque_identity (fun p ->
+                    Sys.opaque_identity ignore
+                    @@ Util.authorized_age conf base p))
+               (Gwdb.persons base))
+           [
+             { conf with wizard = true };
+             { conf with wizard = false; friend = false };
+           ]
+      :: bench_w_base "Check.check_base" ~t:10
+           (fun base _conf ->
+             Check.check_base base
+               (Sys.opaque_identity ignore)
+               (Sys.opaque_identity ignore)
+               (Sys.opaque_identity ignore))
+           [ conf ]
+      :: bench_w_base "Perso.first_possible_duplication" ~t:10
+           (fun base _conf ->
+             Gwdb.Collection.fold
+               (fun acc p ->
+                 Perso.first_possible_duplication base (Gwdb.get_iper p) ([], [])
+                 :: acc)
+               [] (Gwdb.persons base))
+           [ conf ]
+      :: bench_w_base "BirthDeath.select_person" ~t:10
+           (fun base get ->
+             (Sys.opaque_identity BirthDeath.select_person) conf base get true
+             |> Sys.opaque_identity ignore)
+           [ (fun p -> Date.od_of_cdate (Gwdb.get_birth p)) ]
+      :: suite
+  | _ -> suite
+
+let () =
+  let marshal = ref false in
+  let tabulate = ref false in
+  let file = ref "" in
+  let name = ref "" in
+  let speclist =
+    [
+      ("--marshal", Arg.Set marshal, "");
+      ("--tabulate", Arg.Set tabulate, "");
+      ("--name", Arg.Set_string name, "");
+    ]
+  in
+  let usage = "Usage: " ^ Sys.argv.(0) ^ " [OPTION] [FILES]" in
+  let anonfun s = file := s in
+  Arg.parse speclist anonfun usage;
+  if !marshal then style := Benchmark.Nil;
+  if
+    (!file <> "" && (not !tabulate) && not !marshal)
+    || (!tabulate && !marshal)
+    || (!marshal && !name = "")
+  then (
+    Arg.usage speclist usage;
+    exit 2);
+  if !marshal then (
+    let samples : Benchmark.samples list = bench () in
+    let ht =
+      if Sys.file_exists !file then (
+        let ch = open_in_bin !file in
+        let ht : (string, Benchmark.samples) Hashtbl.t =
+          Marshal.from_channel ch
+        in
+        close_in ch;
+        ht)
+      else Hashtbl.create 256
+    in
+    let add k v =
+      match Hashtbl.find_opt ht k with
+      | Some v' -> Hashtbl.replace ht k (v :: v')
+      | None -> Hashtbl.add ht k [ v ]
+    in
+    List.iter
+      (function [ (fn, t) ] -> add fn (!name, t) | _ -> assert false)
+      samples;
+    let ch = open_out_bin !file in
+    Marshal.to_channel ch ht [];
+    close_out ch)
+  else if !tabulate then (
+    let ch = open_in_bin !file in
+    let ht : (string, Benchmark.samples) Hashtbl.t = Marshal.from_channel ch in
+    close_in ch;
+    Hashtbl.iter
+      (fun name samples ->
+        Printf.printf "\n%s:\n" name;
+        Benchmark.tabulate samples)
+      ht)
+  else ignore @@ bench ()

benchmark/dune.in

@@ -0,0 +1,10 @@
+(executable
+  (name bench)
+  (preprocess (action (run %{bin:cppo} %%%CPPO_D%%% -V OCAML:%{ocaml_version} %{input-file})))
+  (libraries unix %%%SOSA_PKG%%% %%%GWDB_PKG%%% geneweb benchmark)
+)
+
+(rule
+  (action (run ./bench.exe) )
+  (alias runbench)
+)

bin/cache_files/cache_files.ml

@@ -0,0 +1,203 @@
+open Geneweb
+open Gwdb
+
+let bname = ref ""
+let trace = ref false
+let fnames = ref false
+let places = ref false
+let fname_alias = ref false
+let snames = ref false
+let alias = ref false
+let qual = ref false
+let all = ref false
+let prog = ref false
+
+let write_cache_file bname fname list =
+  let bname =
+    if Filename.check_suffix bname ".gwb" then Filename.remove_extension bname
+    else bname
+  in
+  let fname =
+    Filename.concat
+      (Util.base_path [] (bname ^ ".gwb"))
+      (bname ^ "_" ^ fname ^ "_cache.txt")
+  in
+  Printf.printf "Write to : %s\n" fname;
+  match try Some (Secure.open_out fname) with Sys_error _ -> None with
+  | Some oc ->
+      List.iter (fun (v, _) -> output_string oc ("<option>" ^ v ^ "\n")) list;
+      close_out oc
+  | None -> ()
+
+let places_all base bname fname =
+  let start = Unix.gettimeofday () in
+  let ht_size = 2048 in
+  (* FIXME: find the good heuristic *)
+  let ht : ('a, 'b) Hashtbl.t = Hashtbl.create ht_size in
+  let ht_add istr _p =
+    let key : 'a = sou base istr in
+    match Hashtbl.find_opt ht key with
+    | Some _ -> Hashtbl.replace ht key key
+    | None -> Hashtbl.add ht key key
+  in
+  let len = nb_of_persons base in
+  if !prog then (
+    Printf.printf "Places\n";
+    flush stdout;
+    ProgrBar.full := '*';
+    ProgrBar.start ());
+  let aux b fn p =
+    if b then
+      let x = fn p in
+      if not (is_empty_string x) then ht_add x p
+  in
+
+  Collection.iteri
+    (fun i ip ->
+      let p = poi base ip in
+      aux true get_birth_place p;
+      aux true get_baptism_place p;
+      aux true get_death_place p;
+      aux true get_burial_place p;
+      if !prog then ProgrBar.run i len else ())
+    (Gwdb.ipers base);
+
+  if !prog then ProgrBar.finish ();
+  let len = nb_of_families base in
+  if !prog then (
+    ProgrBar.full := '*';
+    ProgrBar.start ());
+
+  Collection.iteri
+    (fun i ifam ->
+      let fam = foi base ifam in
+      let pl_ma = get_marriage_place fam in
+      if not (is_empty_string pl_ma) then (
+        let fath = poi base (get_father fam) in
+        let moth = poi base (get_mother fam) in
+        ht_add pl_ma fath;
+        ht_add pl_ma moth);
+      if !prog then ProgrBar.run i len else ())
+    (Gwdb.ifams base);
+
+  if !prog then ProgrBar.finish ();
+  flush stderr;
+  let places_list = Hashtbl.fold (fun _k v acc -> (v, 1) :: acc) ht [] in
+  let places_list =
+    List.sort (fun (v1, _) (v2, _) -> Gutil.alphabetic_utf_8 v1 v2) places_list
+  in
+  write_cache_file bname fname places_list;
+  flush stderr;
+  let stop = Unix.gettimeofday () in
+  Printf.printf "Number of places: %d\n" (List.length places_list);
+  Printf.printf "Execution time: %fs\n" (stop -. start);
+  flush stderr
+
+let names_all base bname fname =
+  let fn = fname = "fnames" in
+  let sn = fname = "snames" in
+  let start = Unix.gettimeofday () in
+  let ht = Hashtbl.create 1 in
+  let nb_ind = nb_of_persons base in
+  flush stderr;
+  if !prog then (
+    Printf.printf "%s\n" fname;
+    flush stdout;
+    ProgrBar.full := '*';
+    ProgrBar.start ());
+
+  Collection.iteri
+    (fun i ip ->
+      if !prog then ProgrBar.run i nb_ind;
+      let p = poi base ip in
+      let nam =
+        if fn then sou base (get_first_name p)
+        else if sn then sou base (get_surname p)
+        else ""
+      in
+      let al = if !alias then get_aliases p else [] in
+      let qual = if !qual then get_qualifiers p else [] in
+      let fna = if !fname_alias && fn then get_first_names_aliases p else [] in
+      let key = nam in
+      if nam <> "" then
+        if not (Hashtbl.mem ht key) then Hashtbl.add ht key (nam, 1)
+        else
+          let vv, i = Hashtbl.find ht key in
+          Hashtbl.replace ht key (vv, i + 1)
+      else ();
+      let nam2 =
+        if al <> [] then al
+        else if fna <> [] then fna
+        else if qual <> [] then qual
+        else []
+      in
+      if nam2 <> [] then
+        List.iter
+          (fun nam ->
+            let nam = sou base nam in
+            let key = nam in
+            if not (Hashtbl.mem ht key) then Hashtbl.add ht key (nam, 1)
+            else
+              let vv, i = Hashtbl.find ht key in
+              Hashtbl.replace ht key (vv, i + 1))
+          nam2;
+      if !prog then ProgrBar.run i nb_ind else ())
+    (Gwdb.ipers base);
+
+  if !prog then ProgrBar.finish ();
+  flush stderr;
+  let name_list = Hashtbl.fold (fun _k v acc -> v :: acc) ht [] in
+  let name_list = List.sort (fun v1 v2 -> compare v1 v2) name_list in
+  write_cache_file bname fname name_list;
+  flush stderr;
+  let stop = Unix.gettimeofday () in
+  Printf.printf "Number of %s : %d\n" fname (Hashtbl.length ht);
+  Printf.printf "Execution time: %fs\n" (stop -. start);
+  flush stderr
+
+let speclist =
+  [
+    ("-fn", Arg.Set fnames, "produce first names");
+    ("-sn", Arg.Set snames, "produce surnames");
+    ("-al", Arg.Set alias, "produce aliases");
+    ("-qu", Arg.Set qual, "produce qualifiers");
+    ("-pl", Arg.Set places, "produce places");
+    ("-all", Arg.Set all, "produce all");
+    ("-fna", Arg.Set fname_alias, "add first names aliases");
+    ("-prog", Arg.Set prog, "show progress bar");
+  ]
+
+let anonfun i = bname := i
+
+let usage =
+  "Usage: cache_files [-fn] [-sn] [-al] [-qu] [-pl] [-all] [-fna] [-prog] base\n\
+  \ cd bases; before running cache_files."
+
+let main () =
+  Arg.parse speclist anonfun usage;
+  if !bname = "" || !bname <> Filename.basename !bname then (
+    Arg.usage speclist usage;
+    exit 2);
+  let base = Gwdb.open_base !bname in
+  bname := Filename.basename !bname;
+  if !places then places_all base !bname "places";
+  if !fnames then names_all base !bname "fnames";
+  if !snames then names_all base !bname "snames";
+  if !alias then names_all base !bname "aliases";
+  if !qual then names_all base !bname "qualifiers";
+  if !all then (
+    places_all base !bname "places";
+    fnames := true;
+    names_all base !bname "fnames";
+    fnames := false;
+    snames := true;
+    names_all base !bname "snames";
+    snames := false;
+    alias := true;
+    names_all base !bname "aliases";
+    alias := false;
+    qual := true;
+    names_all base !bname "qualifiers";
+    qual := false)
+
+let _ = main ()

bin/cache_files/dune.in

@@ -0,0 +1,6 @@
+(executables
+  (names cache_files)
+  (public_names geneweb.cache_files)
+  (modules cache_files)
+  (libraries unix str %%%GWDB_PKG%%% %%%SOSA_PKG%%% geneweb)
+)

bin/connex/connex.ml

@@ -0,0 +1,275 @@
+(* Copyright (c) 1999 INRIA *)
+
+open Def
+open Gwdb
+
+let all = ref false
+let statistics = ref false
+let detail = ref 0
+let ignore = ref []
+let output = ref ""
+let ignore_files = ref true
+let ask_for_delete = ref 0
+let cnt_for_delete = ref 0
+let exact = ref false
+let gwd_port = ref 2317
+let server = ref "127.0.0.1"
+
+let rec merge_families ifaml1f ifaml2f =
+  match (ifaml1f, ifaml2f) with
+  | ifam1 :: ifaml1, ifam2 :: ifaml2 ->
+      let m1 = List.memq ifam1 ifaml2 in
+      let m2 = List.memq ifam2 ifaml1 in
+      if m1 && m2 then merge_families ifaml1 ifaml2
+      else if m1 then ifam2 :: merge_families ifaml1f ifaml2
+      else if m2 then ifam1 :: merge_families ifaml1 ifaml2f
+      else if ifam1 == ifam2 then ifam1 :: merge_families ifaml1 ifaml2
+      else ifam1 :: ifam2 :: merge_families ifaml1 ifaml2
+  | ifaml1, [] -> ifaml1
+  | [], ifaml2 -> ifaml2
+
+let rec filter f = function
+  | x :: l -> if f x then x :: filter f l else filter f l
+  | [] -> []
+
+let connected_families base ifam cpl =
+  let rec loop ifaml ipl_scanned = function
+    | ip :: ipl ->
+        if List.memq ip ipl_scanned then loop ifaml ipl_scanned ipl
+        else
+          let u = poi base ip in
+          let ifaml1 = Array.to_list (get_family u) in
+          let ifaml = merge_families ifaml ifaml1 in
+          let ipl =
+            List.fold_right
+              (fun ifam ipl ->
+                let cpl = foi base ifam in
+                get_father cpl :: get_mother cpl :: ipl)
+              ifaml1 ipl
+          in
+          loop ifaml (ip :: ipl_scanned) ipl
+    | [] -> ifaml
+  in
+  loop [ ifam ] [] [ get_father cpl ]
+
+let neighbourgs base ifam =
+  let fam = foi base ifam in
+  let ifaml = connected_families base ifam fam in
+  let ifaml =
+    match get_parents (poi base (get_father fam)) with
+    | Some ifam -> ifam :: ifaml
+    | None -> ifaml
+  in
+  let ifaml =
+    match get_parents (poi base (get_mother fam)) with
+    | Some ifam -> ifam :: ifaml
+    | None -> ifaml
+  in
+  List.fold_left
+    (fun ifaml ip ->
+      let u = poi base ip in
+      List.fold_left
+        (fun ifaml ifam -> ifam :: ifaml)
+        ifaml
+        (Array.to_list (get_family u)))
+    ifaml
+    (Array.to_list (get_children fam))
+
+let utf8_designation base p =
+  let first_name = p_first_name base p in
+  let surname = p_surname base p in
+  let s = first_name ^ "." ^ string_of_int (get_occ p) ^ " " ^ surname in
+  if first_name = "?" || surname = "?" then
+    s ^ " (i=" ^ string_of_iper (get_iper p) ^ ")"
+  else s
+
+let wiki_designation base basename p =
+  let first_name = p_first_name base p in
+  let surname = p_surname base p in
+  let s =
+    "[[" ^ first_name ^ "/" ^ surname ^ "/"
+    ^ string_of_int (get_occ p)
+    ^ "/" ^ first_name ^ "."
+    ^ string_of_int (get_occ p)
+    ^ " " ^ surname ^ "]]"
+  in
+  if first_name = "?" || surname = "?" then
+    let indx = string_of_iper (get_iper p) in
+    s ^ " <a href=\"http://" ^ !server ^ ":" ^ string_of_int !gwd_port ^ "/"
+    ^ basename ^ "?i=" ^ indx ^ "\">(i=" ^ indx ^ ")</a><br>"
+  else s ^ "<br>"
+
+let print_family base basename ifam =
+  let fam = foi base ifam in
+  let p = poi base (get_father fam) in
+  if !output <> "" then (
+    if sou base (get_first_name p) = "?" || sou base (get_surname p) = "?" then
+      Printf.eprintf "i=%s" (string_of_iper (get_iper p))
+    else Printf.eprintf "  - %s" (utf8_designation base p);
+    Printf.eprintf "\n";
+    Printf.eprintf "  - %s\n"
+      (utf8_designation base (poi base (get_mother fam)));
+    flush stderr);
+  if sou base (get_first_name p) = "?" || sou base (get_surname p) = "?" then
+    let indx = string_of_iper (get_iper p) in
+    Printf.printf "  - <a href=\"http://%s:%d/%s?i=%s\">i=%s</a><br>" !server
+      !gwd_port basename indx indx
+  else Printf.printf "  - %s" (wiki_designation base basename p);
+  Printf.printf "\n";
+  Printf.printf "  - %s\n"
+    (wiki_designation base basename (poi base (get_mother fam)))
+
+let kill_family base ip =
+  let u = { family = Array.of_list [] } in
+  patch_union base ip u
+
+let kill_parents base ip =
+  let a = { parents = None; consang = Adef.fix (-1) } in
+  patch_ascend base ip a
+
+let effective_del base (ifam, fam) =
+  kill_family base (get_father fam);
+  kill_family base (get_mother fam);
+  Array.iter (kill_parents base) (get_children fam);
+  Gwdb.delete_family base ifam
+
+let move base basename =
+  load_ascends_array base;
+  load_unions_array base;
+  load_couples_array base;
+  load_descends_array base;
+  Printf.printf "<h3>Connected components of base %s</h3><br>\n" basename;
+  let ic = Unix.open_process_in "date" in
+  let date = input_line ic in
+  let () = close_in ic in
+  Printf.printf "Computed on %s<br><br>\n" date;
+  flush stderr;
+  let mark = Gwdb.ifam_marker (Gwdb.ifams base) false in
+  let min = ref max_int in
+  let max = ref 0 in
+  let hts = Hashtbl.create 100 in
+  Gwdb.Collection.iter
+    (fun ifam ->
+      let fam = foi base ifam in
+      let origin_file = get_origin_file fam in
+      if List.mem (sou base origin_file) !ignore then ()
+      else
+        let nb, ifaml =
+          let rec loop nb rfaml = function
+            | [] -> (nb, rfaml)
+            | ifam :: ifaml ->
+                let j = ifam in
+                if
+                  (not (Gwdb.Marker.get mark j))
+                  && (!ignore_files || eq_istr (get_origin_file fam) origin_file)
+                then (
+                  Gwdb.Marker.set mark j true;
+                  let nl = neighbourgs base ifam in
+                  let rfaml =
+                    if nb > !detail then
+                      if !ask_for_delete > 0 && nb <= !ask_for_delete then
+                        ifam :: rfaml
+                      else []
+                    else ifam :: rfaml
+                  in
+                  loop (nb + 1) rfaml (List.rev_append nl ifaml))
+                else loop nb rfaml ifaml
+          in
+          loop 0 [] [ ifam ]
+        in
+        if nb > 0 && (!all || nb <= !min) then (
+          if nb <= !min then min := nb;
+          if nb >= !max then max := nb;
+          if !output <> "" then (
+            Printf.eprintf "Connex component \"%s\" length %d\n"
+              (sou base origin_file) nb;
+            flush stderr);
+          Printf.printf "Connex component \"%s\" length %d<br>\n"
+            (sou base origin_file) nb;
+          if !detail == nb then List.iter (print_family base basename) ifaml
+          else print_family base basename ifam;
+          if !statistics then
+            match Hashtbl.find_opt hts nb with
+            | None -> Hashtbl.add hts nb 1
+            | Some n ->
+                Hashtbl.replace hts nb (n + 1);
+                flush stdout;
+                let check_ask =
+                  if !exact then nb = !ask_for_delete else nb <= !ask_for_delete
+                in
+                if !ask_for_delete > 0 && check_ask then (
+                  (* if -o file, repeat branch definition to stderr! *)
+                  Printf.eprintf "Delete up to %d branches of size %s %d ?\n"
+                    !cnt_for_delete
+                    (if !exact then "=" else "<=")
+                    !ask_for_delete;
+                  flush stderr;
+                  let r =
+                    if !cnt_for_delete > 0 then "y"
+                    else (
+                      Printf.eprintf "Delete that branch (y/N) ?";
+                      flush stderr;
+                      input_line stdin)
+                  in
+                  if r = "y" then (
+                    decr cnt_for_delete;
+                    List.iter
+                      (fun ifam ->
+                        let fam = foi base ifam in
+                        effective_del base (ifam, fam))
+                      ifaml;
+                    Printf.eprintf "%d families deleted\n" (List.length ifaml);
+                    flush stderr)
+                  else (
+                    Printf.printf "Nothing done.\n";
+                    flush stdout))))
+    (Gwdb.ifams base);
+  if !ask_for_delete > 0 then Gwdb.commit_patches base;
+  if !statistics then (
+    Printf.printf "<br>\nStatistics:<br>\n";
+    let ls = Hashtbl.fold (fun nb n ls -> (nb, n) :: ls) hts [] in
+    let ls = List.sort compare ls in
+    let ls = List.rev ls in
+    List.iter (fun (nb, n) -> Printf.printf "%d(%d) " nb n) ls;
+    Printf.printf "\n")
+
+let bname = ref ""
+let usage = "usage: " ^ Sys.argv.(0) ^ " <base>"
+
+let speclist =
+  [
+    ( "-gwd_p",
+      Arg.Int (fun x -> gwd_port := x),
+      "<number>: Specify the port number of gwd (default = "
+      ^ string_of_int !gwd_port ^ "); > 1024 for normal users." );
+    ( "-server",
+      Arg.String (fun x -> server := x),
+      "<string>: Name of the server (default is 127.0.0.1)." );
+    ("-a", Arg.Set all, ": all connex components");
+    ("-s", Arg.Set statistics, ": produce statistics");
+    ("-d", Arg.Int (fun x -> detail := x), "<int> : detail for this length");
+    ( "-i",
+      Arg.String (fun x -> ignore := x :: !ignore),
+      "<file> : ignore this file" );
+    ("-bf", Arg.Clear ignore_files, ": by origin files");
+    ( "-del",
+      Arg.Int (fun i -> ask_for_delete := i),
+      "<int> : ask for deleting branches whose size <= that value" );
+    ( "-cnt",
+      Arg.Int (fun i -> cnt_for_delete := i),
+      "<int> : delete cnt branches whose size <= -del value" );
+    ( "-exact",
+      Arg.Set exact,
+      ": delete only branches whose size strictly = -del value" );
+    ("-o", Arg.String (fun x -> output := x), "<file> : output to this file");
+  ]
+
+let main () =
+  Arg.parse speclist (fun s -> bname := s) usage;
+  if !ask_for_delete > 0 then
+    Lock.control (Mutil.lock_file !bname) false
+      (fun () -> move (Gwdb.open_base !bname) !bname)
+      ~onerror:Lock.print_try_again
+  else move (Gwdb.open_base !bname) !bname
+
+let _ = main ()

bin/connex/dune.in

@@ -0,0 +1,6 @@
+(executables
+  (names connex)
+  (public_names geneweb.connex)
+  (modules connex)
+  (libraries unix str %%%GWDB_PKG%%% %%%SOSA_PKG%%% geneweb)
+)

bin/consang/consang.ml

@@ -0,0 +1,55 @@
+(* Copyright (c) 1998-2007 INRIA *)
+
+let fname = ref ""
+let scratch = ref false
+let verbosity = ref 2
+let fast = ref false
+let errmsg = "usage: " ^ Sys.argv.(0) ^ " [options] <file_name>"
+
+let speclist =
+  [
+    ("-q", Arg.Unit (fun () -> verbosity := 1), " quiet mode");
+    ("-qq", Arg.Unit (fun () -> verbosity := 0), " very quiet mode");
+    ("-fast", Arg.Set fast, " faster, but use more memory");
+    ("-scratch", Arg.Set scratch, ": from scratch");
+    ( "-mem",
+      Arg.Set Outbase.save_mem,
+      ": Save memory, but slower when rewritting database" );
+    ("-nolock", Arg.Set Lock.no_lock_flag, ": do not lock database.");
+  ]
+
+let anonfun s =
+  if !fname = "" then fname := s
+  else raise (Arg.Bad "Cannot treat several databases")
+
+let main () =
+  Arg.parse speclist anonfun errmsg;
+  if !fname = "" then (
+    Printf.eprintf "Missing file name\n";
+    Printf.eprintf "Use option -help for usage\n";
+    flush stderr;
+    exit 2);
+  if !verbosity = 0 then Mutil.verbose := false;
+  Secure.set_base_dir (Filename.dirname !fname);
+  Lock.control_retry (Mutil.lock_file !fname) ~onerror:Lock.print_error_and_exit
+    (fun () ->
+      let base = Gwdb.open_base !fname in
+      if !fast then (
+        Gwdb.load_persons_array base;
+        Gwdb.load_families_array base;
+        Gwdb.load_ascends_array base;
+        Gwdb.load_unions_array base;
+        Gwdb.load_couples_array base;
+        Gwdb.load_descends_array base;
+        Gwdb.load_strings_array base);
+      try
+        Sys.catch_break true;
+        if ConsangAll.compute ~verbosity:!verbosity base !scratch then
+          Gwdb.sync base
+      with Consang.TopologicalSortError p ->
+        Printf.printf "\nError: loop in database, %s is his/her own ancestor.\n"
+          (Gutil.designation base p);
+        flush stdout;
+        exit 2)
+
+let _ = Printexc.print main ()

bin/consang/dune.in

@@ -0,0 +1,7 @@
+(executable
+  (name consang)
+  (public_name geneweb.consang)
+  (modules consang)
+  (preprocess (action (run %{bin:cppo} %%%CPPO_D%%% %{input-file})))
+  (libraries unix %%%GWDB_PKG%%% %%%SOSA_PKG%%% geneweb)
+)

bin/fixbase/dune.in

@@ -0,0 +1,6 @@
+(executable
+  (name gwfixbase)
+  (public_name geneweb.gwfixbase)
+  (modules gwfixbase)
+  (libraries unix str %%%GWDB_PKG%%% %%%SOSA_PKG%%% geneweb)
+)

bin/fixbase/gwfixbase.ml

@@ -0,0 +1,225 @@
+open Geneweb
+open Gwdb
+
+let aux txt
+    (fn :
+      ?report:(Fixbase.patch -> unit) -> (int -> int -> unit) -> base -> unit)
+    ~v1 ~v2 base n cnt =
+  let string_of_patch =
+    let string_of_p i = Gutil.designation base (poi base i) in
+    let string_of_f i =
+      let fam = foi base i in
+      Printf.sprintf "[%s & %s]"
+        (string_of_p @@ get_father fam)
+        (string_of_p @@ get_mother fam)
+    in
+    function
+    | Fixbase.Fix_NBDS ip ->
+        Printf.sprintf "Fixed pevents for: %s" (string_of_p ip)
+    | Fix_AddedUnion ip -> Printf.sprintf "Added union for: %s" (string_of_p ip)
+    | Fix_AddedParents ip ->
+        Printf.sprintf "Fixed missing parents for: %s" (string_of_p ip)
+    | Fix_ParentDeleted ip ->
+        Printf.sprintf "Deleted parents for: %s" (string_of_p ip)
+    | Fix_AddedChild ifam ->
+        Printf.sprintf "Added child in: %s" (string_of_f ifam)
+    | Fix_RemovedUnion (ip, ifam) ->
+        Printf.sprintf "Removing ifam %s from [%s] unions" (string_of_ifam ifam)
+          (string_of_p ip)
+    | Fix_RemovedDuplicateUnion (ip, ifam) ->
+        Printf.sprintf "Removing duplicate ifam %s from [%s] unions"
+          (string_of_ifam ifam) (string_of_p ip)
+    | Fix_AddedRelatedFromPevent (ip, ip2) | Fix_AddedRelatedFromFevent (ip, ip2)
+      ->
+        Printf.sprintf "Added related %s to %s" (string_of_p ip2)
+          (string_of_p ip)
+    | Fix_MarriageDivorce ifam ->
+        Printf.sprintf "Fixed marriage and/or divorce info of %s"
+          (string_of_f ifam)
+    | Fix_MissingSpouse (ifam, iper) ->
+        Printf.sprintf "Fixed missing spouse (%s) in family %s"
+          (string_of_p iper) (string_of_f ifam)
+    | Fix_WrongUTF8Encoding (ifam_opt, iper_opt, opt) ->
+        Printf.sprintf "Fixed invalid UTF-8 sequence (%s): %s"
+          (match ifam_opt with
+          | Some i -> "ifam " ^ string_of_ifam i
+          | None -> (
+              match iper_opt with
+              | Some i -> "iper " ^ string_of_iper i
+              | None -> assert false))
+          (match opt with
+          | Some (i, i') -> string_of_istr i ^ " -> " ^ string_of_istr i'
+          | None -> "Dtext")
+    | Fix_UpdatedOcc (iper, oocc, nocc) ->
+        Printf.sprintf "Uptated occ for %s: %d -> %d" (string_of_p iper) oocc
+          nocc
+  in
+  let i' = ref 0 in
+  if v1 then (
+    print_endline txt;
+    flush stdout;
+    ProgrBar.start ());
+  let progress =
+    if v2 then (fun i n ->
+      ProgrBar.run i n;
+      i' := i)
+    else if v1 then ProgrBar.run
+    else fun _ _ -> ()
+  in
+  let report =
+    if v2 then
+      Some
+        (fun s ->
+          incr cnt;
+          ProgrBar.suspend ();
+          print_endline @@ "\t" ^ string_of_patch s;
+          flush stdout;
+          ProgrBar.restart !i' n)
+    else Some (fun _ -> incr cnt)
+  in
+  fn ?report progress base;
+  if v1 then ProgrBar.finish ()
+
+let check_NBDS = aux "Check persons' NBDS" Fixbase.check_NBDS
+
+let check_families_parents =
+  aux "Check families' parents" Fixbase.check_families_parents
+
+let check_families_children =
+  aux "Check families' children" Fixbase.check_families_children
+
+let check_persons_parents =
+  aux "Check persons' parents" Fixbase.check_persons_parents
+
+let check_persons_families =
+  aux "Check persons' families" Fixbase.check_persons_families
+
+let check_pevents_witnesses =
+  aux "Check persons' events witnesses" Fixbase.check_pevents_witnesses
+
+let check_fevents_witnesses =
+  aux "Check family events witnesses" Fixbase.check_fevents_witnesses
+
+let fix_marriage_divorce =
+  aux "Fix families' marriage and divorce" Fixbase.fix_marriage_divorce
+
+let fix_utf8_sequence =
+  aux "Fix invalid UTF-8 sequence" Fixbase.fix_utf8_sequence
+
+let fix_key = aux "Fix duplicate keys" Fixbase.fix_key
+
+let check ~dry_run ~verbosity ~fast ~f_parents ~f_children ~p_parents
+    ~p_families ~p_NBDS ~pevents_witnesses ~fevents_witnesses ~marriage_divorce
+    ~invalid_utf8 ~key bname =
+  let v1 = !verbosity >= 1 in
+  let v2 = !verbosity >= 2 in
+  if not v1 then Mutil.verbose := false;
+  let fast = !fast in
+  let base = Gwdb.open_base bname in
+  let fix = ref 0 in
+  let nb_fam = nb_of_families base in
+  let nb_ind = nb_of_persons base in
+  if fast then (
+    load_strings_array base;
+    load_persons_array base);
+  if !f_parents then check_families_parents ~v1 ~v2 base nb_fam fix;
+  if !f_children then check_families_children ~v1 ~v2 base nb_fam fix;
+  if !p_parents then check_persons_parents ~v1 ~v2 base nb_ind fix;
+  if !p_NBDS then check_NBDS base ~v1 ~v2 nb_ind fix;
+  if !p_families then check_persons_families ~v1 ~v2 base nb_ind fix;
+  if !pevents_witnesses then check_pevents_witnesses ~v1 ~v2 base nb_ind fix;
+  if !fevents_witnesses then check_fevents_witnesses ~v1 ~v2 base nb_fam fix;
+  if !marriage_divorce then fix_marriage_divorce ~v1 ~v2 base nb_fam fix;
+  if !invalid_utf8 then fix_utf8_sequence ~v1 ~v2 base nb_fam fix;
+  if !key then fix_key ~v1 ~v2 base nb_ind fix;
+  if fast then (
+    clear_strings_array base;
+    clear_persons_array base);
+  if not !dry_run then (
+    if !fix <> 0 then (
+      Gwdb.commit_patches base;
+      if v1 then (
+        Printf.printf "%n changes commited\n" !fix;
+        flush stdout))
+    else if v1 then (
+      Printf.printf "No change\n";
+      flush stdout);
+    if v1 then (
+      Printf.printf "Rebuilding the indexes..\n";
+      flush stdout);
+    Gwdb.sync base;
+    if v1 then (
+      Printf.printf "Done";
+      flush stdout))
+
+(**/**)
+
+let bname = ref ""
+let verbosity = ref 2
+let fast = ref false
+let f_parents = ref false
+let f_children = ref false
+let p_parents = ref false
+let p_families = ref false
+let p_NBDS = ref false
+let pevents_witnesses = ref false
+let fevents_witnesses = ref false
+let marriage_divorce = ref false
+let invalid_utf8 = ref false
+let key = ref false
+let index = ref false
+let dry_run = ref false
+
+let speclist =
+  [
+    ("-dry-run", Arg.Set dry_run, " do not commit changes (only print)");
+    ("-q", Arg.Unit (fun () -> verbosity := 1), " quiet mode");
+    ("-qq", Arg.Unit (fun () -> verbosity := 0), " very quiet mode");
+    ("-fast", Arg.Set fast, " fast mode. Needs more memory.");
+    ("-families-parents", Arg.Set f_parents, " missing doc");
+    ("-families-children", Arg.Set f_children, " missing doc");
+    ("-persons-NBDS", Arg.Set p_parents, " missing doc");
+    ("-persons-parents", Arg.Set p_parents, " missing doc");
+    ("-persons-families", Arg.Set p_families, " missing doc");
+    ("-pevents-witnesses", Arg.Set pevents_witnesses, " missing doc");
+    ("-fevents-witnesses", Arg.Set fevents_witnesses, " missing doc");
+    ("-marriage-divorce", Arg.Set marriage_divorce, " missing doc");
+    ("-person-key", Arg.Set key, " missing doc");
+    ( "-index",
+      Arg.Set index,
+      " rebuild index. It is automatically enable by any other option." );
+    ("-invalid-utf8", Arg.Set invalid_utf8, " missing doc");
+  ]
+
+let anonfun i = bname := i
+let usage = "Usage: " ^ Sys.argv.(0) ^ " [OPTION] base"
+
+let main () =
+  Arg.parse speclist anonfun usage;
+  Secure.set_base_dir (Filename.dirname !bname);
+  if !bname = "" then (
+    Arg.usage speclist usage;
+    exit 2);
+  Lock.control (Mutil.lock_file !bname) false ~onerror:Lock.print_try_again
+  @@ fun () ->
+  if
+    !f_parents || !f_children || !p_parents || !p_families || !pevents_witnesses
+    || !fevents_witnesses || !marriage_divorce || !p_NBDS || !invalid_utf8
+    || !key || !index
+  then ()
+  else (
+    f_parents := true;
+    f_children := true;
+    p_parents := true;
+    p_families := true;
+    pevents_witnesses := true;
+    fevents_witnesses := true;
+    marriage_divorce := true;
+    p_NBDS := true;
+    invalid_utf8 := true;
+    key := true);
+  check ~dry_run ~fast ~verbosity ~f_parents ~f_children ~p_NBDS ~p_parents
+    ~p_families ~pevents_witnesses ~fevents_witnesses ~marriage_divorce
+    ~invalid_utf8 ~key !bname
+
+let _ = main ()

bin/ged2gwb/dune.in

@@ -0,0 +1,7 @@
+(executable
+  (name ged2gwb)
+  (public_name geneweb.ged2gwb)
+  (modules ged2gwb)
+  (preprocess (action (run camlp5o pr_o.cmo pa_extend.cmo q_MLast.cmo %{input-file})))
+  (libraries camlp5 unix str %%%GWDB_PKG%%% %%%SOSA_PKG%%% geneweb)
+)

bin/gwb2ged/dune.in

@@ -0,0 +1,22 @@
+(library
+  (name gwb2ged_lib)
+  (public_name geneweb.gwb2ged_lib)
+  (wrapped false)
+  (libraries geneweb geneweb.gwexport_lib)
+  (modules gwb2gedLib)
+)
+
+(executable
+  (name gwb2ged)
+  (public_name geneweb.gwb2ged)
+  (modules gwb2ged)
+  (libraries
+    geneweb
+    gwb2ged_lib
+    gwu_lib
+    str
+    unix
+    %%%GWDB_PKG%%%
+    %%%SOSA_PKG%%%
+  )
+)

bin/gwb2ged/gwb2ged.ml

@@ -0,0 +1,15 @@
+let with_indexes = ref false
+
+let speclist opts =
+  ("-indexes", Arg.Set with_indexes, " export indexes in gedcom")
+  :: Gwexport.speclist opts
+  |> Arg.align
+
+let main () =
+  let opts = ref Gwexport.default_opts in
+  Arg.parse (speclist opts) (Gwexport.anonfun opts) Gwexport.errmsg;
+  let opts = !opts in
+  let select = Gwexport.select opts [] in
+  Gwb2gedLib.gwb2ged !with_indexes opts select
+
+let _ = main ()

bin/gwb2ged/gwb2gedLib.ml

@@ -0,0 +1,725 @@
+(* Copyright (c) 1998-2007 INRIA *)
+
+open Geneweb
+open Def
+open Gwdb
+
+let int_of_iper =
+  let ht = Hashtbl.create 0 in
+  fun i ->
+    try Hashtbl.find ht i
+    with Not_found ->
+      let x = Hashtbl.length ht in
+      Hashtbl.add ht i x;
+      x
+
+let int_of_ifam =
+  let ht = Hashtbl.create 0 in
+  fun i ->
+    try Hashtbl.find ht i
+    with Not_found ->
+      let x = Hashtbl.length ht in
+      Hashtbl.add ht i x;
+      x
+
+let month_txt =
+  [|
+    "JAN";
+    "FEB";
+    "MAR";
+    "APR";
+    "MAY";
+    "JUN";
+    "JUL";
+    "AUG";
+    "SEP";
+    "OCT";
+    "NOV";
+    "DEC";
+  |]
+
+let french_txt =
+  [|
+    "VEND";
+    "BRUM";
+    "FRIM";
+    "NIVO";
+    "PLUV";
+    "VENT";
+    "GERM";
+    "FLOR";
+    "PRAI";
+    "MESS";
+    "THER";
+    "FRUC";
+    "COMP";
+  |]
+
+let hebrew_txt =
+  [|
+    "TSH";
+    "CSH";
+    "KSL";
+    "TVT";
+    "SHV";
+    "ADR";
+    "ADS";
+    "NSN";
+    "IYR";
+    "SVN";
+    "TMZ";
+    "AAV";
+    "ELL";
+  |]
+
+let ged_month cal m =
+  match cal with
+  | Dgregorian | Djulian ->
+      if m >= 1 && m <= Array.length month_txt then month_txt.(m - 1)
+      else failwith "ged_month"
+  | Dfrench ->
+      if m >= 1 && m <= Array.length french_txt then french_txt.(m - 1)
+      else failwith "ged_month"
+  | Dhebrew ->
+      if m >= 1 && m <= Array.length hebrew_txt then hebrew_txt.(m - 1)
+      else failwith "ged_month"
+
+let encode opts s =
+  match opts.Gwexport.charset with
+  | Gwexport.Ansel -> Ansel.of_iso_8859_1 @@ Mutil.iso_8859_1_of_utf_8 s
+  | Gwexport.Ascii | Gwexport.Ansi -> Mutil.iso_8859_1_of_utf_8 s
+  | Gwexport.Utf8 -> s
+
+let max_len = 78
+let br = "<br>"
+
+let find_br s ini_i =
+  let ini = "<br" in
+  let rec loop i j =
+    if i = String.length ini then
+      let rec loop2 j =
+        if j = String.length s then br
+        else if s.[j] = '>' then String.sub s ini_i (j - ini_i + 1)
+        else loop2 (j + 1)
+      in
+      loop2 j
+    else if j = String.length s then br
+    else if String.unsafe_get ini i = String.unsafe_get s j then
+      loop (i + 1) (j + 1)
+    else br
+  in
+  loop 0 ini_i
+
+let oc opts = match opts.Gwexport.oc with _, oc, _ -> oc
+
+(** [display_note_aux opts tagn s len i] outputs text [s] with CONT/CONC
+    tag. GEDCOM lines are limited to 255 characters. However, the
+    CONCatenation or CONTinuation tags can be used to expand a field
+    beyond this limit. Lines are cut and align with [max_len]
+    characters for easy display/printing.
+    @see <https://www.familysearch.org/developers/docs/gedcom/> GEDCOM
+    STANDARD 5.5, Appendix A CONC and CONT tag
+    @param opts carries output channel
+    @param tagn specifies the current gedcom tag level (0, 1, ...)
+    @param s specifies text to print to the output channel (already
+    encode with gedcom charset)
+    @param len specifies the number of characters (char or wide char)
+    already printed
+    @param i specifies the last char index (index to s -- one byte
+    char) *)
+
+let rec display_note_aux opts tagn s len i =
+  let j = ref i in
+  (* read wide char (case charset UTF-8) or char (other charset) in s string*)
+  if !j = String.length s then Printf.ksprintf (oc opts) "\n"
+  else
+    (* \n, <br>, <br \> : cut text for CONTinuate with new gedcom line *)
+    let br = find_br s i in
+    if
+      i <= String.length s - String.length br
+      && String.lowercase_ascii (String.sub s i (String.length br)) = br
+    then (
+      Printf.ksprintf (oc opts) "\n%d CONT " (succ tagn);
+      let i = i + String.length br in
+      let i = if i < String.length s && s.[i] = '\n' then i + 1 else i in
+      display_note_aux opts tagn s
+        (String.length (string_of_int (succ tagn) ^ " CONT "))
+        i)
+    else if s.[i] = '\n' then (
+      Printf.ksprintf (oc opts) "\n%d CONT " (succ tagn);
+      let i = if i < String.length s then i + 1 else i in
+      display_note_aux opts tagn s
+        (String.length (string_of_int (succ tagn) ^ " CONT "))
+        i)
+    else if
+      (* cut text at max length for CONCat with next gedcom line *)
+      len = max_len
+    then (
+      Printf.ksprintf (oc opts) "\n%d CONC " (succ tagn);
+      display_note_aux opts tagn s
+        (String.length (string_of_int (succ tagn) ^ " CONC "))
+        i)
+    else
+      (* continue same gedcom line *)
+
+      (* FIXME: Rewrite this so we can get rid of this custom [nbc] *)
+      let nbc c =
+        if Char.code c < 0b10000000 then 1
+        else if Char.code c < 0b11000000 then -1
+        else if Char.code c < 0b11100000 then 2
+        else if Char.code c < 0b11110000 then 3
+        else if Char.code c < 0b11111000 then 4
+        else if Char.code c < 0b11111100 then 5
+        else if Char.code c < 0b11111110 then 6
+        else -1
+      in
+      (* FIXME: avoid this buffer *)
+      let b = Buffer.create 4 in
+      let rec output_onechar () =
+        if !j = String.length s then decr j (* non wide char / UTF-8 char *)
+        else if opts.Gwexport.charset <> Gwexport.Utf8 then
+          Buffer.add_char b s.[i] (* 1 to 4 bytes UTF-8 wide char *)
+        else if i = !j || nbc s.[!j] = -1 then (
+          Buffer.add_char b s.[!j];
+          incr j;
+          output_onechar ())
+        else decr j
+      in
+      output_onechar ();
+      (oc opts) (Buffer.contents b);
+      display_note_aux opts tagn s (len + 1) (!j + 1)
+
+let display_note opts tagn s =
+  let tag = Printf.sprintf "%d NOTE " tagn in
+  Printf.ksprintf (oc opts) "%s" tag;
+  display_note_aux opts tagn (encode opts s) (String.length tag) 0
+
+let ged_header opts base ifile ofile =
+  Printf.ksprintf (oc opts) "0 HEAD\n";
+  Printf.ksprintf (oc opts) "1 SOUR GeneWeb\n";
+  Printf.ksprintf (oc opts) "2 VERS %s\n" Version.ver;
+  Printf.ksprintf (oc opts) "2 NAME %s\n" (Filename.basename Sys.argv.(0));
+  Printf.ksprintf (oc opts) "2 CORP INRIA\n";
+  Printf.ksprintf (oc opts) "3 ADDR http://www.geneweb.org\n";
+  Printf.ksprintf (oc opts) "2 DATA %s\n"
+    (let fname = Filename.basename ifile in
+     if Filename.check_suffix fname ".gwb" then fname else fname ^ ".gwb");
+  (try
+     let tm = Unix.localtime (Unix.time ()) in
+     let mon = ged_month Dgregorian (tm.Unix.tm_mon + 1) in
+     Printf.ksprintf (oc opts) "1 DATE %02d %s %d\n" tm.Unix.tm_mday mon
+       (1900 + tm.Unix.tm_year);
+     Printf.ksprintf (oc opts) "2 TIME %02d:%02d:%02d\n" tm.Unix.tm_hour
+       tm.Unix.tm_min tm.Unix.tm_sec
+   with _ -> ());
+  if ofile <> "" then
+    Printf.ksprintf (oc opts) "1 FILE %s\n" (Filename.basename ofile);
+  Printf.ksprintf (oc opts) "1 GEDC\n";
+  (match opts.Gwexport.charset with
+  | Gwexport.Ansel | Gwexport.Ansi | Gwexport.Ascii ->
+      Printf.ksprintf (oc opts) "2 VERS 5.5\n"
+  | Gwexport.Utf8 -> Printf.ksprintf (oc opts) "2 VERS 5.5.1\n");
+  Printf.ksprintf (oc opts) "2 FORM LINEAGE-LINKED\n";
+  (match opts.Gwexport.charset with
+  | Gwexport.Ansel -> Printf.ksprintf (oc opts) "1 CHAR ANSEL\n"
+  | Gwexport.Ansi -> Printf.ksprintf (oc opts) "1 CHAR ANSI\n"
+  | Gwexport.Ascii -> Printf.ksprintf (oc opts) "1 CHAR ASCII\n"
+  | Gwexport.Utf8 -> Printf.ksprintf (oc opts) "1 CHAR UTF-8\n");
+  if opts.Gwexport.no_notes = `none then
+    match base_notes_read base "" with "" -> () | s -> display_note opts 1 s
+
+let sub_string_index s t =
+  let rec loop i j =
+    if j = String.length t then Some (i - j)
+    else if i = String.length s then None
+    else if s.[i] = t.[j] then loop (i + 1) (j + 1)
+    else loop (i + 1) 0
+  in
+  loop 0 0
+
+let ged_1st_name base p =
+  let fn = sou base (get_first_name p) in
+  match get_first_names_aliases p with
+  | n :: _ -> (
+      let fna = sou base n in
+      match sub_string_index fna fn with
+      | Some i ->
+          let j = i + String.length fn in
+          String.sub fna 0 i ^ "\"" ^ fn ^ "\""
+          ^ String.sub fna j (String.length fna - j)
+      | None -> fn)
+  | [] -> fn
+
+let string_of_list =
+  let rec loop r = function
+    | s :: l -> if r = "" then loop s l else loop (r ^ "," ^ s) l
+    | [] -> r
+  in
+  loop ""
+
+let ged_index opts per =
+  Printf.ksprintf (oc opts) "1 _GWID %s\n" (Gwdb.string_of_iper (get_iper per))
+
+let ged_name opts base per =
+  Printf.ksprintf (oc opts) "1 NAME %s /%s/\n"
+    (encode opts (Mutil.nominative (ged_1st_name base per)))
+    (encode opts (Mutil.nominative (sou base (get_surname per))));
+  let n = sou base (get_public_name per) in
+  if n <> "" then Printf.ksprintf (oc opts) "2 GIVN %s\n" (encode opts n);
+  (match get_qualifiers per with
+  | nn :: _ ->
+      Printf.ksprintf (oc opts) "2 NICK %s\n" (encode opts (sou base nn))
+  | [] -> ());
+  (match get_surnames_aliases per with
+  | [] -> ()
+  | list ->
+      let list = List.map (fun n -> encode opts (sou base n)) list in
+      Printf.ksprintf (oc opts) "2 SURN %s\n" (string_of_list list));
+  List.iter
+    (fun s ->
+      Printf.ksprintf (oc opts) "1 NAME %s\n" (encode opts (sou base s)))
+    (get_aliases per)
+
+let ged_sex opts per =
+  match get_sex per with
+  | Male -> Printf.ksprintf (oc opts) "1 SEX M\n"
+  | Female -> Printf.ksprintf (oc opts) "1 SEX F\n"
+  | Neuter -> ()
+
+let ged_calendar opts = function
+  | Dgregorian -> ()
+  | Djulian -> Printf.ksprintf (oc opts) "@#DJULIAN@ "
+  | Dfrench -> Printf.ksprintf (oc opts) "@#DFRENCH R@ "
+  | Dhebrew -> Printf.ksprintf (oc opts) "@#DHEBREW@ "
+
+let ged_date_dmy opts dt cal =
+  (match dt.prec with
+  | Sure -> ()
+  | About -> Printf.ksprintf (oc opts) "ABT "
+  | Maybe -> Printf.ksprintf (oc opts) "EST "
+  | Before -> Printf.ksprintf (oc opts) "BEF "
+  | After -> Printf.ksprintf (oc opts) "AFT "
+  | OrYear _ -> Printf.ksprintf (oc opts) "BET "
+  | YearInt _ -> Printf.ksprintf (oc opts) "BET ");
+  ged_calendar opts cal;
+  if dt.day <> 0 then Printf.ksprintf (oc opts) "%02d " dt.day;
+  if dt.month <> 0 then Printf.ksprintf (oc opts) "%s " (ged_month cal dt.month);
+  Printf.ksprintf (oc opts) "%d" dt.year;
+  match dt.prec with
+  | OrYear dmy2 ->
+      Printf.ksprintf (oc opts) " AND ";
+      ged_calendar opts cal;
+      if dmy2.day2 <> 0 then Printf.ksprintf (oc opts) "%02d " dmy2.day2;
+      if dmy2.month2 <> 0 then
+        Printf.ksprintf (oc opts) "%s " (ged_month cal dmy2.month2);
+      Printf.ksprintf (oc opts) "%d" dmy2.year2
+  | YearInt dmy2 ->
+      Printf.ksprintf (oc opts) " AND ";
+      ged_calendar opts cal;
+      if dmy2.day2 <> 0 then Printf.ksprintf (oc opts) "%02d " dmy2.day2;
+      if dmy2.month2 <> 0 then
+        Printf.ksprintf (oc opts) "%s " (ged_month cal dmy2.month2);
+      Printf.ksprintf (oc opts) "%d" dmy2.year2
+  | _ -> ()
+
+let ged_date opts = function
+  | Dgreg (d, Dgregorian) -> ged_date_dmy opts d Dgregorian
+  | Dgreg (d, Djulian) ->
+      ged_date_dmy opts (Calendar.julian_of_gregorian d) Djulian
+  | Dgreg (d, Dfrench) ->
+      ged_date_dmy opts (Calendar.french_of_gregorian d) Dfrench
+  | Dgreg (d, Dhebrew) ->
+      ged_date_dmy opts (Calendar.hebrew_of_gregorian d) Dhebrew
+  | Dtext t -> Printf.ksprintf (oc opts) "(%s)" t
+
+let print_sour opts n s = Printf.ksprintf (oc opts) "%d SOUR %s\n" n s
+
+let ged_ev_detail opts n typ d pl note src =
+  (match (typ, d, pl, note, src) with
+  | "", None, "", "", "" -> Printf.ksprintf (oc opts) " Y"
+  | _ -> ());
+  Printf.ksprintf (oc opts) "\n";
+  if typ = "" then () else Printf.ksprintf (oc opts) "%d TYPE %s\n" n typ;
+  (match d with
+  | Some d ->
+      Printf.ksprintf (oc opts) "%d DATE " n;
+      ged_date opts d;
+      Printf.ksprintf (oc opts) "\n"
+  | None -> ());
+  if pl <> "" then Printf.ksprintf (oc opts) "%d PLAC %s\n" n (encode opts pl);
+  if opts.Gwexport.no_notes <> `nnn && note <> "" then display_note opts n note;
+  if opts.Gwexport.source = None && src <> "" then
+    print_sour opts n (encode opts src)
+
+let ged_tag_pevent base evt =
+  match evt.epers_name with
+  | Epers_Birth -> "BIRT"
+  | Epers_Baptism -> "BAPM"
+  | Epers_Death -> "DEAT"
+  | Epers_Burial -> "BURI"
+  | Epers_Cremation -> "CREM"
+  | Epers_Accomplishment -> "Accomplishment"
+  | Epers_Acquisition -> "Acquisition"
+  | Epers_Adhesion -> "Membership"
+  | Epers_BaptismLDS -> "BAPL"
+  | Epers_BarMitzvah -> "BARM"
+  | Epers_BatMitzvah -> "BASM"
+  | Epers_Benediction -> "BLES"
+  | Epers_ChangeName -> "Change name"
+  | Epers_Circumcision -> "Circumcision"
+  | Epers_Confirmation -> "CONF"
+  | Epers_ConfirmationLDS -> "CONL"
+  | Epers_Decoration -> "Award"
+  | Epers_DemobilisationMilitaire -> "Military discharge"
+  | Epers_Diploma -> "Degree"
+  | Epers_Distinction -> "Distinction"
+  | Epers_Dotation -> "ENDL"
+  | Epers_DotationLDS -> "DotationLDS"
+  | Epers_Education -> "EDUC"
+  | Epers_Election -> "Election"
+  | Epers_Emigration -> "EMIG"
+  | Epers_Excommunication -> "Excommunication"
+  | Epers_FamilyLinkLDS -> "Family link LDS"
+  | Epers_FirstCommunion -> "FCOM"
+  | Epers_Funeral -> "Funeral"
+  | Epers_Graduate -> "GRAD"
+  | Epers_Hospitalisation -> "Hospitalization"
+  | Epers_Illness -> "Illness"
+  | Epers_Immigration -> "IMMI"
+  | Epers_ListePassenger -> "Passenger list"
+  | Epers_MilitaryDistinction -> "Military distinction"
+  | Epers_MilitaryPromotion -> "Military promotion"
+  | Epers_MilitaryService -> "Military service"
+  | Epers_MobilisationMilitaire -> "Military mobilization"
+  | Epers_Naturalisation -> "NATU"
+  | Epers_Occupation -> "OCCU"
+  | Epers_Ordination -> "ORDN"
+  | Epers_Property -> "PROP"
+  | Epers_Recensement -> "CENS"
+  | Epers_Residence -> "RESI"
+  | Epers_Retired -> "RETI"
+  | Epers_ScellentChildLDS -> "SLGC"
+  | Epers_ScellentParentLDS -> "Scellent parent LDS"
+  | Epers_ScellentSpouseLDS -> "SLGS"
+  | Epers_VenteBien -> "Property sale"
+  | Epers_Will -> "WILL"
+  | Epers_Name n -> sou base n
+
+let is_primary_pevents = function
+  | Epers_Birth | Epers_Baptism | Epers_Death | Epers_Burial | Epers_Cremation
+  | Epers_BaptismLDS | Epers_BarMitzvah | Epers_BatMitzvah | Epers_Benediction
+  | Epers_Confirmation | Epers_ConfirmationLDS | Epers_Dotation
+  | Epers_Education | Epers_Emigration | Epers_FirstCommunion | Epers_Graduate
+  | Epers_Immigration | Epers_Naturalisation | Epers_Occupation
+  | Epers_Ordination | Epers_Property | Epers_Recensement | Epers_Residence
+  | Epers_Retired | Epers_ScellentChildLDS | Epers_ScellentSpouseLDS
+  | Epers_Will ->
+      true
+  | _ -> false
+
+let relation_format_of_witness_kind :
+    witness_kind -> ('a, unit, string, unit) format4 = function
+  | Witness -> "3 RELA Witness"
+  | Witness_GodParent -> "3 RELA GODP"
+  | Witness_CivilOfficer -> "3 RELA Civil officer"
+  | Witness_ReligiousOfficer -> "3 RELA Religious officer"
+  | Witness_Informant -> "3 RELA Informant"
+  | Witness_Attending -> "3 RELA Attending"
+  | Witness_Mentioned -> "3 RELA Mentioned"
+  | Witness_Other -> "3 RELA Other"
+
+let oc' opts s = Printf.ksprintf (oc opts) (s ^^ "\n")
+let oc_witness_kind opts wk = oc' opts (relation_format_of_witness_kind wk)
+
+let ged_pevent opts base per_sel evt =
+  let typ =
+    if is_primary_pevents evt.epers_name then (
+      let tag = ged_tag_pevent base evt in
+      Printf.ksprintf (oc opts) "1 %s" tag;
+      "")
+    else (
+      Printf.ksprintf (oc opts) "1 EVEN";
+      ged_tag_pevent base evt)
+  in
+  let date = Date.od_of_cdate evt.epers_date in
+  let place = sou base evt.epers_place in
+  let note = sou base evt.epers_note in
+  let src = sou base evt.epers_src in
+  ged_ev_detail opts 2 typ date place note src;
+  Array.iter
+    (fun (ip, wk) ->
+      if per_sel ip then (
+        Printf.ksprintf (oc opts) "2 ASSO @I%d@\n" (int_of_iper ip + 1);
+        Printf.ksprintf (oc opts) "3 TYPE INDI\n";
+        oc_witness_kind opts wk))
+    evt.epers_witnesses
+
+let adop_fam_list = ref []
+
+let ged_fam_adop opts i (fath, moth, _) =
+  Printf.ksprintf (oc opts) "0 @F%d@ FAM\n" i;
+  (match fath with
+  | Some i -> Printf.ksprintf (oc opts) "1 HUSB @I%d@\n" (int_of_iper i + 1)
+  | _ -> ());
+  match moth with
+  | Some i -> Printf.ksprintf (oc opts) "1 WIFE @I%d@\n" (int_of_iper i + 1)
+  | _ -> ()
+
+let ged_ind_ev_str opts base per per_sel =
+  List.iter (ged_pevent opts base per_sel) (get_pevents per)
+
+let ged_title opts base per tit =
+  Printf.ksprintf (oc opts) "1 TITL ";
+  Printf.ksprintf (oc opts) "%s" (encode opts (sou base tit.t_ident));
+  (match sou base tit.t_place with
+  | "" -> ()
+  | pl -> Printf.ksprintf (oc opts) ", %s" (encode opts pl));
+  if tit.t_nth <> 0 then Printf.ksprintf (oc opts) ", %d" tit.t_nth;
+  Printf.ksprintf (oc opts) "\n";
+  (match
+     (Date.od_of_cdate tit.t_date_start, Date.od_of_cdate tit.t_date_end)
+   with
+  | None, None -> ()
+  | Some sd, None ->
+      Printf.ksprintf (oc opts) "2 DATE FROM ";
+      ged_date opts sd;
+      Printf.ksprintf (oc opts) "\n"
+  | None, Some sd ->
+      Printf.ksprintf (oc opts) "2 DATE TO ";
+      ged_date opts sd;
+      Printf.ksprintf (oc opts) "\n"
+  | Some sd1, Some sd2 ->
+      Printf.ksprintf (oc opts) "2 DATE FROM ";
+      ged_date opts sd1;
+      Printf.ksprintf (oc opts) " TO ";
+      ged_date opts sd2;
+      Printf.ksprintf (oc opts) "\n");
+  match tit.t_name with
+  | Tmain ->
+      Printf.ksprintf (oc opts) "2 NOTE %s\n"
+        (encode opts (sou base (get_public_name per)))
+  | Tname n ->
+      Printf.ksprintf (oc opts) "2 NOTE %s\n" (encode opts (sou base n))
+  | Tnone -> ()
+
+let ged_ind_attr_str opts base per =
+  (match sou base (get_occupation per) with
+  | "" -> ()
+  | occu -> Printf.ksprintf (oc opts) "1 OCCU %s\n" (encode opts occu));
+  List.iter (ged_title opts base per) (get_titles per)
+
+let ged_famc opts fam_sel asc =
+  match get_parents asc with
+  | Some ifam ->
+      if fam_sel ifam then
+        Printf.ksprintf (oc opts) "1 FAMC @F%d@\n" (int_of_ifam ifam + 1)
+  | None -> ()
+
+let ged_fams opts fam_sel ifam =
+  if fam_sel ifam then
+    Printf.ksprintf (oc opts) "1 FAMS @F%d@\n" (int_of_ifam ifam + 1)
+
+let ged_godparent opts per_sel godp = function
+  | Some ip ->
+      if per_sel ip then (
+        Printf.ksprintf (oc opts) "1 ASSO @I%d@\n" (int_of_iper ip + 1);
+        Printf.ksprintf (oc opts) "2 TYPE INDI\n";
+        Printf.ksprintf (oc opts) "2 RELA %s\n" godp)
+  | None -> ()
+
+let ged_witness opts fam_sel ifam =
+  if fam_sel ifam then (
+    Printf.ksprintf (oc opts) "1 ASSO @F%d@\n" (int_of_ifam ifam + 1);
+    Printf.ksprintf (oc opts) "2 TYPE FAM\n";
+    Printf.ksprintf (oc opts) "2 RELA witness\n")
+
+let ged_asso opts base (per_sel, fam_sel) per =
+  List.iter
+    (fun r ->
+      if r.r_type = GodParent then (
+        ged_godparent opts per_sel "GODF" r.r_fath;
+        ged_godparent opts per_sel "GODM" r.r_moth))
+    (get_rparents per);
+  List.iter
+    (fun ic ->
+      let c = poi base ic in
+      if get_sex c = Male then
+        List.iter
+          (fun ifam ->
+            let fam = foi base ifam in
+            if Array.mem (get_iper per) (get_witnesses fam) then
+              ged_witness opts fam_sel ifam)
+          (Array.to_list (get_family c)))
+    (get_related per)
+
+let ged_psource opts base per =
+  match opts.Gwexport.source with
+  | Some "" -> ()
+  | Some s -> print_sour opts 1 (encode opts s)
+  | None -> (
+      match sou base (get_psources per) with
+      | "" -> ()
+      | s -> print_sour opts 1 (encode opts s))
+
+let has_image_file opts base p =
+  let s = Image.default_portrait_filename base p in
+  let f = Filename.concat opts.Gwexport.img_base_path s in
+  if Sys.file_exists (f ^ ".gif") then Some (f ^ ".gif")
+  else if Sys.file_exists (f ^ ".jpg") then Some (f ^ ".jpg")
+  else if Sys.file_exists (f ^ ".png") then Some (f ^ ".png")
+  else None
+
+let ged_multimedia_link opts base per =
+  match sou base (get_image per) with
+  | "" -> (
+      if (not opts.Gwexport.no_picture) && opts.Gwexport.picture_path then
+        match has_image_file opts base per with
+        | Some s ->
+            Printf.ksprintf (oc opts) "1 OBJE\n";
+            Printf.ksprintf (oc opts) "2 FILE %s\n" s
+        | None -> ())
+  | s ->
+      if not opts.Gwexport.no_picture then (
+        Printf.ksprintf (oc opts) "1 OBJE\n";
+        Printf.ksprintf (oc opts) "2 FILE %s\n" s)
+
+let ged_note opts base per =
+  if opts.Gwexport.no_notes <> `nnn then
+    match sou base (get_notes per) with "" -> () | s -> display_note opts 1 s
+
+let ged_tag_fevent base evt =
+  match evt.efam_name with
+  | Efam_Marriage -> "MARR"
+  | Efam_NoMarriage -> "unmarried"
+  | Efam_NoMention -> "nomen"
+  | Efam_Engage -> "ENGA"
+  | Efam_Divorce -> "DIV"
+  | Efam_Separated -> "SEP"
+  | Efam_Annulation -> "ANUL"
+  | Efam_MarriageBann -> "MARB"
+  | Efam_MarriageContract -> "MARC"
+  | Efam_MarriageLicense -> "MARL"
+  | Efam_PACS -> "pacs"
+  | Efam_Residence -> "residence"
+  | Efam_Name n -> sou base n
+
+let is_primary_fevents = function
+  | Efam_Marriage | Efam_Engage | Efam_Divorce | Efam_Separated
+  | Efam_Annulation | Efam_MarriageBann | Efam_MarriageContract
+  | Efam_MarriageLicense ->
+      true
+  | _ -> false
+
+let ged_fevent opts base per_sel evt =
+  let typ =
+    if is_primary_fevents evt.efam_name then (
+      let tag = ged_tag_fevent base evt in
+      Printf.ksprintf (oc opts) "1 %s" tag;
+      "")
+    else (
+      Printf.ksprintf (oc opts) "1 EVEN";
+      ged_tag_fevent base evt)
+  in
+  let date = Date.od_of_cdate evt.efam_date in
+  let place = sou base evt.efam_place in
+  let note = sou base evt.efam_note in
+  let src = sou base evt.efam_src in
+  ged_ev_detail opts 2 typ date place note src;
+  Array.iter
+    (fun (ip, wk) ->
+      if per_sel ip then (
+        Printf.ksprintf (oc opts) "2 ASSO @I%d@\n" (int_of_iper ip + 1);
+        Printf.ksprintf (oc opts) "3 TYPE INDI\n";
+        oc_witness_kind opts wk))
+    evt.efam_witnesses
+
+let ged_child opts per_sel chil =
+  if per_sel chil then
+    Printf.ksprintf (oc opts) "1 CHIL @I%d@\n" (int_of_iper chil + 1)
+
+let ged_fsource opts base fam =
+  match opts.Gwexport.source with
+  | Some "" -> ()
+  | Some s -> print_sour opts 1 (encode opts s)
+  | None -> (
+      match sou base (get_fsources fam) with
+      | "" -> ()
+      | s -> print_sour opts 1 (encode opts s))
+
+let ged_comment opts base fam =
+  if opts.Gwexport.no_notes <> `nnn then
+    match sou base (get_comment fam) with
+    | "" -> ()
+    | s -> display_note opts 1 s
+
+let has_personal_infos base per =
+  get_parents per <> None
+  || sou base (get_first_name per) <> "?"
+  || sou base (get_surname per) <> "?"
+  || get_birth per <> Date.cdate_None
+  || sou base (get_birth_place per) <> ""
+  || (get_death per <> NotDead && get_death per <> DontKnowIfDead)
+  || sou base (get_occupation per) <> ""
+  || get_titles per <> []
+
+let ged_ind_record with_indexes opts base ((per_sel, fam_sel) as sel) i =
+  let per = poi base i in
+  if has_personal_infos base per then (
+    Printf.ksprintf (oc opts) "0 @I%d@ INDI\n" (int_of_iper i + 1);
+    ged_name opts base per;
+    if with_indexes then ged_index opts per;
+    ged_sex opts per;
+    ged_ind_ev_str opts base per per_sel;
+    ged_ind_attr_str opts base per;
+    ged_famc opts fam_sel per;
+    Array.iter (ged_fams opts fam_sel) (get_family per);
+    ged_asso opts base sel per;
+    ged_psource opts base per;
+    ged_multimedia_link opts base per;
+    ged_note opts base per)
+
+let ged_fam_record opts base (per_sel, _fam_sel) ifam =
+  let fam = foi base ifam in
+  Printf.ksprintf (oc opts) "0 @F%d@ FAM\n" (int_of_ifam ifam + 1);
+  List.iter (ged_fevent opts base per_sel) (get_fevents fam);
+  if
+    per_sel (get_father fam)
+    && has_personal_infos base (poi base (get_father fam))
+  then
+    Printf.ksprintf (oc opts) "1 HUSB @I%d@\n" (int_of_iper (get_father fam) + 1);
+  if
+    per_sel (get_mother fam)
+    && has_personal_infos base (poi base (get_mother fam))
+  then
+    Printf.ksprintf (oc opts) "1 WIFE @I%d@\n" (int_of_iper (get_mother fam) + 1);
+  Array.iter (ged_child opts per_sel) (get_children fam);
+  ged_fsource opts base fam;
+  ged_comment opts base fam
+
+let gwb2ged with_indexes opts ((per_sel, fam_sel) as sel) =
+  match opts.Gwexport.base with
+  | Some (ifile, base) ->
+      let ofile, oc, close = opts.Gwexport.oc in
+      if not opts.Gwexport.mem then (
+        load_ascends_array base;
+        load_unions_array base;
+        load_couples_array base;
+        load_descends_array base);
+      ged_header opts base ifile ofile;
+      Gwdb.Collection.iter
+        (fun i -> if per_sel i then ged_ind_record with_indexes opts base sel i)
+        (Gwdb.ipers base);
+      Gwdb.Collection.iter
+        (fun i -> if fam_sel i then ged_fam_record opts base sel i)
+        (Gwdb.ifams base);
+      let _ =
+        List.fold_right
+          (fun adop i ->
+            ged_fam_adop opts i adop;
+            i + 1)
+          !adop_fam_list
+          (nb_of_families base + 1)
+      in
+      Printf.ksprintf oc "0 TRLR\n";
+      close ()
+  | None -> assert false

bin/gwb2ged/gwb2gedLib.mli

@@ -0,0 +1,11 @@
+val gwb2ged :
+  bool ->
+  Gwexport.gwexport_opts ->
+  (Gwdb.iper -> bool) * (Gwdb.ifam -> bool) ->
+  unit
+(** [gwb2ged with_indexes opts sel]
+    Converts a Geneweb database to a GEDCOM file.
+    * `with_indexes` specifies if indexes are printed or not;
+    * `opts` are the export options
+    * `sel` is a pair of selectors returned by the database export
+*)

bin/gwc/db1link.mli

@@ -0,0 +1,27 @@
+val default_source : string ref
+(** Default source field for persons and families without source data *)
+
+val do_check : bool ref
+(** Base consistency check *)
+
+val do_consang : bool ref
+(** Compute consanguinity *)
+
+val pr_stats : bool ref
+(** Print base's statistics *)
+
+val particules_file : string ref
+(** File containing the particles to use *)
+
+type file_info = {
+  mutable f_curr_src_file : string;
+  mutable f_curr_gwo_file : string;
+  mutable f_separate : bool;
+  mutable f_bnotes : [ `drop | `erase | `first | `merge ];
+  mutable f_shift : int;
+  mutable f_local_names : (int * int, int) Hashtbl.t;
+}
+(** Information about current .gwo file. *)
+
+val link : (file_info -> unit -> Gwcomp.gw_syntax option) -> string -> bool
+(** Link .gwo files and create a database. *)

bin/gwc/dune.in

@@ -0,0 +1,7 @@
+(executable
+  (name gwc)
+  (public_name geneweb.gwc)
+  (modules gwc gwcomp db1link)
+  (preprocess (action (run %{bin:cppo} %%%CPPO_D%%% %{input-file})))
+  (libraries unix %%%GWDB_PKG%%% %%%SOSA_PKG%%% geneweb)
+)

bin/gwc/gwc.ml

@@ -0,0 +1,206 @@
+(* Copyright (c) 1998-2007 INRIA *)
+
+open Gwcomp
+
+(** Checks a .gwo header and prints fails if header is absent or not compatible. *)
+let check_magic fname ic =
+  let b = really_input_string ic (String.length magic_gwo) in
+  if b <> magic_gwo then
+    if String.sub magic_gwo 0 4 = String.sub b 0 4 then
+      failwith ("\"" ^ fname ^ "\" is a GeneWeb object file, but not compatible")
+    else
+      failwith
+        ("\"" ^ fname
+       ^ "\" is not a GeneWeb object file, or it is a very old version")
+
+(** [next_family_fun_templ gwo_list fi] creates a function that read
+    sucessivly a [Gwcomp.gw_syntax] for all .gwo files. In details it does :
+
+    - Switch to the next element in the [gwo_list] if reached the end
+      of the current file. Each element is [(gwo,separate, bnotes, shift)]
+      where [gwo] is .gwo filename and [separate], [bnotes], [shift] are
+      captured options from command line related to the giving file.
+    - Modify [fi] with mentioned previusly information if needed.
+    - Start/continue to read current .gwo file content and return
+      [Gwcomp.gw_syntax]. [None] is returned when reading of the last
+      .gwo file reaches end of file *)
+let next_family_fun_templ gwo_list fi =
+  let ngwo = List.length gwo_list in
+  let run =
+    if ngwo < 10 || not !Mutil.verbose then fun () -> ()
+    else if ngwo < 60 then (fun () ->
+      Printf.eprintf ".";
+      flush stderr)
+    else
+      let bar_cnt = ref 0 in
+      let run () =
+        ProgrBar.run !bar_cnt ngwo;
+        incr bar_cnt
+      in
+      ProgrBar.empty := 'o';
+      ProgrBar.full := '*';
+      ProgrBar.start ();
+      run
+  in
+  let ic_opt = ref None in
+  let gwo_list = ref gwo_list in
+  fun () ->
+    let rec loop () =
+      let r =
+        match !ic_opt with
+        | Some ic -> (
+            match
+              try Some (input_value ic : gw_syntax) with End_of_file -> None
+            with
+            | Some fam -> Some fam
+            | None ->
+                close_in ic;
+                ic_opt := None;
+                None)
+        | None -> None
+      in
+      let bnotes_of_string = function
+        | "merge" -> `merge
+        | "erase" -> `erase
+        | "first" -> `first
+        | "drop" -> `drop
+        | _ -> assert false
+      in
+      match r with
+      | Some fam -> Some fam
+      | None -> (
+          (* switch to the next .gwo file *)
+          match !gwo_list with
+          | (x, separate, bnotes, shift) :: rest ->
+              run ();
+              gwo_list := rest;
+              let ic = open_in_bin x in
+              check_magic x ic;
+              fi.Db1link.f_curr_src_file <- input_value ic;
+              fi.Db1link.f_curr_gwo_file <- x;
+              fi.Db1link.f_separate <- separate;
+              fi.Db1link.f_bnotes <- bnotes_of_string bnotes;
+              fi.Db1link.f_shift <- shift;
+              Hashtbl.clear fi.Db1link.f_local_names;
+              ic_opt := Some ic;
+              loop ()
+          | [] ->
+              if ngwo < 10 || not !Mutil.verbose then ()
+              else if ngwo < 60 then (
+                Printf.eprintf "\n";
+                flush stderr)
+              else ProgrBar.finish ();
+              None)
+    in
+    loop ()
+
+let just_comp = ref false
+let out_file = ref (Filename.concat Filename.current_dir_name "a")
+let force = ref false
+let separate = ref false
+let bnotes = ref "merge"
+let shift = ref 0
+let files = ref []
+
+let speclist =
+  [
+    ( "-bnotes",
+      Arg.Set_string bnotes,
+      "[drop|erase|first|merge] Behavior for base notes of the next file. \
+       [drop]: dropped. [erase]: erase the current content. [first]: dropped \
+       if current content is not empty. [merge]: concatenated to the current \
+       content. Default: " ^ !bnotes ^ "" );
+    ("-c", Arg.Set just_comp, " Only compiling");
+    ("-cg", Arg.Set Db1link.do_consang, " Compute consanguinity");
+    ( "-ds",
+      Arg.Set_string Db1link.default_source,
+      "<str> Set the source field for persons and families without source data"
+    );
+    ("-f", Arg.Set force, " Remove database if already existing");
+    ("-mem", Arg.Set Outbase.save_mem, " Save memory, but slower");
+    ("-nc", Arg.Clear Db1link.do_check, " No consistency check");
+    ("-nofail", Arg.Set Gwcomp.no_fail, " No failure in case of error");
+    ("-nolock", Arg.Set Lock.no_lock_flag, " Do not lock database");
+    ( "-nopicture",
+      Arg.Set Gwcomp.no_picture,
+      " Do not create associative pictures" );
+    ( "-o",
+      Arg.Set_string out_file,
+      "<file> Output database (default: a.gwb). Alphanumerics and -" );
+    ( "-particles",
+      Arg.Set_string Db1link.particules_file,
+      "<file> Particles file (default = predefined particles)" );
+    ("-q", Arg.Clear Mutil.verbose, " Quiet");
+    ("-sep", Arg.Set separate, " Separate all persons in next file");
+    ("-sh", Arg.Set_int shift, "<int> Shift all persons numbers in next files");
+    ("-stats", Arg.Set Db1link.pr_stats, " Print statistics");
+    ("-v", Arg.Set Mutil.verbose, " Verbose");
+  ]
+  |> List.sort compare |> Arg.align
+
+let anonfun x =
+  let bn = !bnotes in
+  let sep = !separate in
+  if Filename.check_suffix x ".gw" then ()
+  else if Filename.check_suffix x ".gwo" then ()
+  else raise (Arg.Bad ("Don't know what to do with \"" ^ x ^ "\""));
+  separate := false;
+  bnotes := "merge";
+  files := (x, sep, bn, !shift) :: !files
+
+let errmsg =
+  "Usage: gwc [options] [files]\n\
+   where [files] are a list of files:\n\
+  \  source files end with .gw\n\
+  \  object files end with .gwo\n\
+   and [options] are:"
+
+let main () =
+  Mutil.verbose := false;
+  Arg.parse speclist anonfun errmsg;
+  if not (Mutil.good_name (Filename.basename !out_file)) then (
+    (* Util.transl conf not available !*)
+    Printf.eprintf "The database name \"%s\" contains a forbidden character./n"
+      !out_file;
+    Printf.eprintf "Allowed characters: a..z, A..Z, 0..9, -";
+    flush stdout;
+    exit 2);
+  Secure.set_base_dir (Filename.dirname !out_file);
+  let gwo = ref [] in
+  List.iter
+    (fun (x, separate, bnotes, shift) ->
+      if Filename.check_suffix x ".gw" then (
+        (try Gwcomp.comp_families x
+         with e ->
+           Printf.eprintf "File \"%s\", line %d:\n" x !line_cnt;
+           raise e);
+        gwo := (x ^ "o", separate, bnotes, shift) :: !gwo)
+      else if Filename.check_suffix x ".gwo" then
+        gwo := (x, separate, bnotes, shift) :: !gwo
+      else raise (Arg.Bad ("Don't know what to do with \"" ^ x ^ "\"")))
+    (List.rev !files);
+  if not !just_comp then (
+    let bdir =
+      if Filename.check_suffix !out_file ".gwb" then !out_file
+      else !out_file ^ ".gwb"
+    in
+    if (not !force) && Sys.file_exists bdir then (
+      Printf.eprintf
+        "The database \"%s\" already exists. Use option -f to overwrite it."
+        !out_file;
+      flush stdout;
+      exit 2);
+    Lock.control (Mutil.lock_file !out_file)
+      false ~onerror:Lock.print_error_and_exit (fun () ->
+        let bdir =
+          if Filename.check_suffix !out_file ".gwb" then !out_file
+          else !out_file ^ ".gwb"
+        in
+        let next_family_fun = next_family_fun_templ (List.rev !gwo) in
+        if Db1link.link next_family_fun bdir then ()
+        else (
+          Printf.eprintf "*** database not created\n";
+          flush stderr;
+          exit 2)))
+
+let _ = main ()

bin/gwc/gwcomp.mli

@@ -0,0 +1,99 @@
+(* Copyright (c) 2007-2008 INRIA *)
+
+open Def
+open Gwdb
+
+type key = { pk_first_name : string; pk_surname : string; pk_occ : int }
+(** Key to refer a person's definition *)
+
+(** Represents a person in .gw file. It could be either reference to a person
+    (only key elements provided) or definition (all information provided). *)
+type somebody =
+  | Undefined of key  (** Reference to person *)
+  | Defined of (iper, iper, string) gen_person  (** Person's definition *)
+
+(** Blocks that could appear in .gw file. *)
+type gw_syntax =
+  | Family of
+      somebody gen_couple
+      * sex
+      * sex
+      * (somebody * sex) list
+      * (string gen_fam_event_name
+        * cdate
+        * string
+        * string
+        * string
+        * string
+        * (somebody * sex * witness_kind) list)
+        list
+      * ((iper, iper, string) gen_person, ifam, string) gen_family
+      * (iper, iper, string) gen_person gen_descend
+      (** Family definition block. Contains:
+      - Family couple (father's and mother's definition/reference)
+      - Father's sex
+      - Mother's sex
+      - List of witnesses definition/reference with their sex.
+      - List of information about every family event (name, date,
+        place, reason, source, notes and witnesses)
+      - Family definition
+      - Children (descendants) *)
+  | Notes of key * string
+      (** Block that defines personal notes. First element represents
+      reference to person. Second is note's content. *)
+  | Relations of somebody * sex * (somebody, string) gen_relation list
+      (** Block that defines relations of a person with someone outisde of
+      family block. Contains:
+      - Concerned person definition/reference
+      - Sex of person
+      - List of his relations. *)
+  | Pevent of
+      somebody
+      * sex
+      * (string gen_pers_event_name
+        * cdate
+        * string
+        * string
+        * string
+        * string
+        * (somebody * sex * witness_kind) list)
+        list
+      (** Block that defines events of a person. Specific to gwplus format. Contains:
+      - Concerned person definition/reference
+      - Sex of person
+      - List of information about every personal event (name, date,
+      place, reason, source, notes and witnesses)*)
+  | Bnotes of string * string
+      (** Block that defines database notes and extended pages.
+      First string represents name of extended page ("" for
+      database notes, only one for file).
+      Second is note's or page's content. *)
+  | Wnotes of string * string
+      (** Block that defines wizard notes.
+      First string represents wizard's id.
+      Second is note's content. *)
+
+val magic_gwo : string
+(** .gwo file header *)
+
+val line_cnt : int ref
+(** Line counter while reading .gw file *)
+
+val no_fail : bool ref
+(** Do not raise exception if syntax error occured.
+    Instead print error information on stdout *)
+
+val no_picture : bool ref
+(** Save path to the images *)
+
+val create_all_keys : bool ref
+(** Forces to create all the keys for every persons (even for ? ?).
+    Enabled for gwplus format. *)
+
+val comp_families : string -> unit
+(** Compile .gw file and save result to corresponding .gwo *)
+
+(* Ajout pour l'API *)
+
+val date_of_string : string -> int -> date option
+(** Parses [Def.date] from string that starts at pos [i] inside [s] *)

bin/gwd/README.md

@@ -0,0 +1,79 @@
+# gwd - The GeneWeb daemon
+
+## Plugins
+
+### Disclaimer
+
+Plugin system allow you to run **ANY** piece of code as a handler
+for any requests.
+
+It means that you could run **harmful** code if you do not control the source
+of compiled.
+
+i.e you should not run plugins using the `-unsafe_*` options unless
+you are developping your own plugin.
+
+*Reliable* plugins are the ones accepted by `-plugin` and `-plugins` option.
+
+*Reliable* means that the compiled code and assets you load are the one used
+in official distribution. It does not make the code safe, but you
+know what is actually running on your machine by reading the source code.
+
+### How to load a plugin in gwd
+
+If you want to control what plugins `gwd` loads, and control the order,
+use the `-plugin path/to/foo` option, and it will load
+`path/to/foo/plugin_foo.cmxs` file.
+
+A simpler solution is to use `-plugins path/to/plugins/` and let
+`gwd` load all available plugins in the directory, using `META` files
+in order to load the plugins in the right order.
+
+### How to write a plugin for gwd
+
+It is expected that you follow a simple architecture when writing a
+plugin for `gwd`.
+
+```
+foo/
+    META
+    assets/
+    dune
+    plugin_foo.cmxs
+```
+
+- `META`: describe your plugin metadata such as name, and dependencies.
+- `assets/`: every static assets needed by you plugin (css, js, images, etc...)
+- `plugin_foo.cmxs`: the which will load handlers.
+
+The `dune` file must define the `plugin` `alias`.
+
+```
+(executable
+  (name plugin_foo)
+  (modes (native plugin))
+)
+
+(alias (name plugin) (deps plugin_foo.cmxs))
+```
+
+#### Allowing gwd to run your plugin
+
+Anything in GeneWeb distribution will be registered in whitelist, and
+gwd will check file integrity before loading the plugin.
+
+You can still execute an untrusted plugin with `-unsafe_plugin`
+and `-unsafe_plugins` options.
+
+#### META file
+
+```
+version: version of your plugin
+maintainers: comma-seperated list of plugin maintainers
+depends: comma-seperated list of other plugins needed
+```
+
+### Stability
+
+Plugin system is new and still under heavy test and development.
+API should not be considered stable yet.

bin/gwd/base64.ml

@@ -0,0 +1,42 @@
+(* $Id: base64.ml,v 5.2 2007-01-19 01:53:16 ddr Exp $ *)
+(* Copyright (c) 1998-2007 INRIA *)
+
+(* For basic credentials only *)
+(* Encoding is [A-Z][a-z][0-9]+/= *)
+(* 3 chars = 24 bits = 4 * 6-bit groups -> 4 chars *)
+
+(* Init the index *)
+let index64 =
+  let index64 = Array.make 128 0 in
+  for i = 0 to 25 do
+    index64.(i + Char.code 'A') <- i
+  done;
+  for i = 0 to 25 do
+    index64.(i + Char.code 'a') <- i + 26
+  done;
+  for i = 0 to 9 do
+    index64.(i + Char.code '0') <- i + 52
+  done;
+  index64.(Char.code '+') <- 62;
+  index64.(Char.code '/') <- 63;
+  index64
+
+let decode s =
+  let rpos = ref 0 and wpos = ref 0 and len = String.length s in
+  let res = Bytes.create (len / 4 * 3) in
+  while !rpos < len do
+    let v1 = index64.(Char.code s.[!rpos]) in
+    let v2 = index64.(Char.code s.[!rpos + 1]) in
+    let v3 = index64.(Char.code s.[!rpos + 2]) in
+    let v4 = index64.(Char.code s.[!rpos + 3]) in
+    let i = (v1 lsl 18) lor (v2 lsl 12) lor (v3 lsl 6) lor v4 in
+    Bytes.set res !wpos (Char.chr (i lsr 16));
+    Bytes.set res (!wpos + 1) (Char.chr ((i lsr 8) land 0xFF));
+    Bytes.set res (!wpos + 2) (Char.chr (i land 0xFF));
+    rpos := !rpos + 4;
+    wpos := !wpos + 3
+  done;
+  let cut =
+    if s.[len - 1] = '=' then if s.[len - 2] = '=' then 2 else 1 else 0
+  in
+  Bytes.sub_string res 0 (Bytes.length res - cut)

bin/gwd/base64.mli

@@ -0,0 +1,2 @@
+val decode : string -> string
+(** Decode {i Base64} binary-to-text encoding used at the moment of basic autorization *)

bin/gwd/dune.in

@@ -0,0 +1,49 @@
+(rule
+  (target gwdPluginMD5.ml)
+  (deps
+    (alias_rec %{project_root}/plugins/plugin)
+    (:maker mk_gwdPluginMD5.ml)
+  )
+  (action (with-stdout-to %{target} (run ocaml %{maker} %{project_root}/plugins)))
+)
+
+(library
+  (name gwd_lib)
+  (public_name geneweb.gwd_lib)
+  (wrapped true)
+  (libraries
+    geneweb
+    wserver
+    %%%GWDB_PKG%%%
+    %%%SOSA_PKG%%%
+    %%%SYSLOG_PKG%%%
+  )
+  (preprocess (action (run %{bin:cppo} %%%CPPO_D%%% %{input-file})))
+  (modules gwdLog gwdPlugin request)
+)
+
+(executable
+  (name gwd)
+  (public_name geneweb.gwd)
+  (flags -linkall)
+  (libraries
+    dynlink
+    geneweb
+    gwd_lib
+    str
+    unix
+    uri
+    wserver
+    %%%GWDB_PKG%%%
+    %%%SOSA_PKG%%%
+  )
+  (preprocess (action (run %{bin:cppo} %%%CPPO_D%%% %{input-file})))
+  (modules
+    base64
+    gwd
+    gwdPluginDep
+    gwdPluginMD5
+    gwdPluginMETA
+    robot
+  )
+)

bin/gwd/gwdLog.ml

@@ -0,0 +1,80 @@
+let verbosity = ref 7
+let debug = ref false
+
+let oc : out_channel option ref = ref None
+
+let log fn =
+  match !oc with
+  | Some oc -> fn oc
+  | None -> ()
+
+type level =
+  [ `LOG_ALERT
+  | `LOG_CRIT
+  | `LOG_DEBUG
+  | `LOG_EMERG
+  | `LOG_ERR
+  | `LOG_INFO
+  | `LOG_NOTICE
+  | `LOG_WARNING
+  ]
+
+#ifdef SYSLOG
+let syslog (level : level) msg =
+  let flags = if !debug then [`LOG_PERROR] else [] in
+  if !verbosity
+     >=
+     match level with
+     | `LOG_EMERG -> 0
+     | `LOG_ALERT -> 1
+     | `LOG_CRIT -> 2
+     | `LOG_ERR -> 3
+     | `LOG_WARNING -> 4
+     | `LOG_NOTICE -> 5
+     | `LOG_INFO -> 6
+     | `LOG_DEBUG -> 7
+  then begin
+    let log = Syslog.openlog ~flags @@ Filename.basename @@ Sys.executable_name in
+    Syslog.syslog log level msg ;
+    Syslog.closelog log ;
+    if !debug then Printexc.print_backtrace stderr ;
+  end
+#endif
+
+#ifndef SYSLOG
+let syslog (level : level) msg =
+  if !verbosity
+     >=
+     match level with
+     | `LOG_EMERG -> 0
+     | `LOG_ALERT -> 1
+     | `LOG_CRIT -> 2
+     | `LOG_ERR -> 3
+     | `LOG_WARNING -> 4
+     | `LOG_NOTICE -> 5
+     | `LOG_INFO -> 6
+     | `LOG_DEBUG -> 7
+  then begin
+    let tm = Unix.(time () |> localtime) in
+    let level =
+      match level with
+      | `LOG_EMERG -> "EMERGENCY"
+      | `LOG_ALERT -> "ALERT"
+      | `LOG_CRIT -> "CRITICAL"
+      | `LOG_ERR -> "ERROR"
+      | `LOG_WARNING -> "WARNING"
+      | `LOG_NOTICE -> "NOTICE"
+      | `LOG_INFO -> "INFO"
+      | `LOG_DEBUG -> "DEBUG"
+    in
+    let print oc = Printf.fprintf oc "[%s]: %s %s\n" (Mutil.sprintf_date tm :> string) level msg in
+    begin match Sys.getenv_opt "GW_SYSLOG_FILE" with
+      | Some fn ->
+        let oc = open_out_gen [ Open_wronly ; Open_creat ; Open_append ] 0o644 fn in
+        print oc ;
+        close_out oc
+      | None -> print stderr
+    end ;
+    if !debug then Printexc.print_backtrace stderr ;
+  end
+#endif

bin/gwd/gwdLog.mli

@@ -0,0 +1,27 @@
+val verbosity : int ref
+(** Verbosity level: defines the verbosity level that will
+    allow the [syslog] function to print anything. *)
+
+val debug : bool ref
+(** If set to [true], prints backtrace when printing log. *)
+
+val oc : out_channel option ref
+(** The output channel in which log is written. *)
+
+val log : (out_channel -> unit) -> unit
+(** Prints on [oc] *)
+
+type level =
+  [ `LOG_EMERG  (** Print if `!verbosity >= 0` *)
+  | `LOG_ALERT  (** Print if `!verbosity >= 1` *)
+  | `LOG_CRIT  (** Print if `!verbosity >= 2` *)
+  | `LOG_ERR  (** Print if `!verbosity >= 3` *)
+  | `LOG_WARNING  (** Print if `!verbosity >= 4` *)
+  | `LOG_NOTICE  (** Print if `!verbosity >= 5` *)
+  | `LOG_INFO  (** Print if `!verbosity >= 6` *)
+  | `LOG_DEBUG  (** Print if `!verbosity >= 7` *) ]
+(** The level of log. *)
+
+val syslog : level -> string -> unit
+(** [syslog level msg]
+    Prints [msg] on [!oc] depending on the verbosity. *)

bin/gwd/gwdPlugin.ml

@@ -0,0 +1,19 @@
+open Geneweb
+
+let assets = ref ""
+let registered = ref []
+
+let ht : (string, string * (Config.config -> string option -> bool)) Hashtbl.t =
+  Hashtbl.create 0
+
+let register ~ns list =
+  assert (not @@ List.mem ns !registered);
+  registered := ns :: !registered;
+  List.iter
+    (fun (m, fn) ->
+      let fn = fn !assets in
+      Hashtbl.add ht m (ns, fn))
+    list
+
+let se : (string * (Config.config -> string option -> unit)) list ref = ref []
+let register_se ~ns fn = Mutil.list_ref_append se (ns, fn !assets)

bin/gwd/gwdPlugin.mli

@@ -0,0 +1,50 @@
+val assets : string ref
+(** When dynamically loading a plugin, this variable contains
+    the path of the assets directory associated to the plugin
+    being currently loaded.
+*)
+
+val register :
+  ns:string ->
+  (string * (string -> Geneweb.Config.config -> string option -> bool)) list ->
+  unit
+(** [register ~ns handlers] register modes handlers of a plugin.
+
+    [ns] is the namespace of the plugin (i.e. its name)
+
+    [handler] is a associative list of handler.
+    The key is the mode (the `m` GET/POST parameter).
+    The value is the handler itself. The difference between a plugin
+    handler and default gwd's handlers (the ones in request.ml) is that
+    a plugin handler takes an extra (first) argument being
+    the path of the asset directory associated to this plugin
+    and returns a boolean.
+
+    If the handler returns [true], it means that it actually processed
+    the request. If is is [false], [gwd] must try another plugin handler to
+    treat the request. If no plugin is suitable, gwd's default handler
+    must be used, or fail if it does not exists.
+
+    Handlers can overwrite pre-existing modes or create new ones.
+ *)
+
+val ht :
+  (string, string * (Geneweb.Config.config -> string option -> bool)) Hashtbl.t
+(** Table of handlers registered by plugins.  *)
+
+val register_se :
+  ns:string ->
+  (string -> Geneweb.Config.config -> string option -> unit) ->
+  unit
+(** [register_se ~ns hook] register a plugin hook (side effect function).
+
+    If enabled, hooks are executed before the request handlers, in the
+    order of registration (first registred = first executed).
+
+    For exemple, a plugin could be to change the [conf] output to print everything
+    in a buffer and apply a transformation to the resulting document before actually
+    sending it to the client.
+  *)
+
+val se : (string * (Geneweb.Config.config -> string option -> unit)) list ref
+(** Table of hooks registered by plugins. *)

bin/gwd/gwdPluginDep.ml

@@ -0,0 +1,122 @@
+(* https://github.com/dmbaturin/ocaml-tsort *)
+(* Authors: Daniil Baturin (2019), Martin Jambon (2020). *)
+(* See LICENSE at the end of the file *)
+
+(* Adapted to GeneWeb by Julien Sagot *)
+
+type 'a sort_result = Sorted of 'a list | ErrorCycle of 'a list
+
+(* Finds "isolated" nodes,
+   that is, nodes that have no dependencies *)
+let find_isolated_nodes hash =
+  let aux id deps acc = match deps with [] -> id :: acc | _ -> acc in
+  Hashtbl.fold aux hash []
+
+(* Takes a node name list and removes all those nodes from a hash *)
+let remove_nodes nodes hash = List.iter (Hashtbl.remove hash) nodes
+
+(* Walks through a node:dependencies hash and removes a dependency
+   from all nodes that have it in their dependency lists *)
+let remove_dependency hash dep =
+  let aux dep hash id =
+    let deps = Hashtbl.find hash id in
+    let deps = List.filter (( <> ) dep) deps in
+    Hashtbl.remove hash id;
+    Hashtbl.add hash id deps
+  in
+  let ids = Hashtbl.fold (fun k _ a -> k :: a) hash [] in
+  List.iter (aux dep hash) ids
+
+(* Deduplicate list items. *)
+let deduplicate l =
+  let tbl = Hashtbl.create (List.length l) in
+  List.fold_left
+    (fun acc x ->
+      if Hashtbl.mem tbl x then acc
+      else (
+        Hashtbl.add tbl x ();
+        x :: acc))
+    [] l
+  |> List.rev
+
+(*
+   Append missing nodes to the graph, in the order in which they were
+   encountered. This particular order doesn't have to be guaranteed by the
+   API but seems nice to have.
+*)
+let add_missing_nodes graph_l graph =
+  let missing =
+    List.fold_left
+      (fun acc (_, vl) ->
+        List.fold_left
+          (fun acc v ->
+            if not (Hashtbl.mem graph v) then (v, []) :: acc else acc)
+          acc vl)
+      [] graph_l
+    |> List.rev
+  in
+  List.iter (fun (v, vl) -> Hashtbl.replace graph v vl) missing;
+  graph_l @ missing
+
+(* The Kahn's algorithm:
+    1. Find nodes that have no dependencies ("isolated") and remove them from
+       the graph hash.
+       Add them to the initial sorted nodes list and the list of isolated
+       nodes for the first sorting pass.
+    2. For every isolated node, walk through the remaining nodes and
+       remove it from their dependency list.
+       Nodes that only depended on it now have empty dependency lists.
+    3. Find all nodes with empty dependency lists and append them to the sorted
+       nodes list _and_ the list of isolated nodes to use for the next step
+    4. Repeat until the list of isolated nodes is empty
+    5. If the graph hash is still not empty, it means there is a cycle.
+*)
+let sort nodes =
+  let rec sorting_loop deps hash acc =
+    match deps with
+    | [] -> acc
+    | dep :: deps ->
+        let () = remove_dependency hash dep in
+        let isolated_nodes = find_isolated_nodes hash in
+        let () = remove_nodes isolated_nodes hash in
+        sorting_loop
+          (List.append deps isolated_nodes)
+          hash
+          (List.append acc isolated_nodes)
+  in
+  let nodes_hash =
+    let tbl = Hashtbl.create 32 in
+    List.iter (fun (k, v) -> Hashtbl.add tbl k v) nodes;
+    tbl
+  in
+  let _nodes = add_missing_nodes nodes nodes_hash in
+  let base_nodes = find_isolated_nodes nodes_hash in
+  let () = remove_nodes base_nodes nodes_hash in
+  let sorted_node_ids = sorting_loop base_nodes nodes_hash [] in
+  let sorted_node_ids = List.append base_nodes sorted_node_ids in
+  let remaining_ids = Hashtbl.fold (fun k _ a -> k :: a) nodes_hash [] in
+  match remaining_ids with
+  | [] -> Sorted sorted_node_ids
+  | _ -> ErrorCycle remaining_ids
+
+(* MIT License *)
+
+(* Copyright (c) 2019 Daniil Baturin *)
+
+(* Permission is hereby granted, free of charge, to any person obtaining a copy *)
+(* of this software and associated documentation files (the "Software"), to deal *)
+(* in the Software without restriction, including without limitation the rights *)
+(* to use, copy, modify, merge, publish, distribute, sublicense, and/or sell *)
+(* copies of the Software, and to permit persons to whom the Software is *)
+(* furnished to do so, subject to the following conditions: *)
+
+(* The above copyright notice and this permission notice shall be included in all *)
+(* copies or substantial portions of the Software. *)
+
+(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR *)
+(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
+(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE *)
+(* AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER *)
+(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, *)
+(* OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE *)
+(* SOFTWARE. *)

bin/gwd/gwdPluginDep.mli

@@ -0,0 +1,9 @@
+type 'a sort_result = Sorted of 'a list | ErrorCycle of 'a list
+
+val sort : ('a * 'a list) list -> 'a sort_result
+(** Given a list of elements (in this case, plugins) and their dependencies,
+    tries to compute a valid order `l` and return `Sorted l` .
+    If there is a cycle, returns `ErrorCycle l'` where `l'` is a dependency
+    cycle.
+    Uses Kahn's algorithm for cycle detection.
+ *)

bin/gwd/gwdPluginMD5.mli

@@ -0,0 +1 @@
+val allowed : string -> bool

bin/gwd/gwdPluginMETA.ml

@@ -0,0 +1,30 @@
+type meta = {
+  version : string;
+  maintainers : string list;
+  depends : string list;
+}
+
+let parse fname =
+  let ic = open_in fname in
+  let rec loop meta =
+    match input_line ic with
+    | exception End_of_file ->
+        close_in ic;
+        meta
+    | s -> (
+        match String.index_opt s ':' with
+        | None -> loop meta
+        | Some i -> (
+            let v =
+              String.trim @@ String.sub s (i + 1) (String.length s - i - 1)
+            in
+            let split_and_trim v =
+              List.map String.trim @@ String.split_on_char ',' v
+            in
+            match String.trim @@ String.sub s 0 i with
+            | "depends" -> loop { meta with depends = split_and_trim v }
+            | "maintainers" -> loop { meta with maintainers = split_and_trim v }
+            | "version" -> loop { meta with version = v }
+            | _ -> loop meta))
+  in
+  loop { version = ""; maintainers = []; depends = [] }

bin/gwd/gwdPluginMETA.mli

@@ -0,0 +1,7 @@
+type meta = {
+  version : string;
+  maintainers : string list;
+  depends : string list;
+}
+
+val parse : string -> meta

bin/gwd/mk_gwdPluginMD5.ml

@@ -0,0 +1,71 @@
+let md5 plugin =
+  let files =
+    let rec loop result = function
+      | [] -> result
+      | f :: fs ->
+          if Sys.file_exists f then
+            if String.get f (String.length f - 1) = '~' then loop result fs
+            else if Sys.is_directory f then
+              Sys.readdir f |> Array.to_list
+              |> List.rev_map (Filename.concat f)
+              |> List.rev_append fs |> loop result
+            else loop (f :: result) fs
+          else loop result fs
+    in
+    loop []
+      [
+        Filename.concat plugin @@ "plugin_" ^ Filename.basename plugin ^ ".cmxs";
+        Filename.concat plugin "assets";
+      ]
+  in
+  let files = List.sort compare files in
+  let b = Buffer.create 1024 in
+  List.iter
+    (fun f -> Digest.file f |> Digest.to_hex |> Buffer.add_string b)
+    files;
+  Buffer.contents b |> Digest.string |> Digest.to_hex
+
+let () =
+  print_endline
+    {|let md5 plugin =
+  let files =
+    let rec loop result = function
+      | [] -> result
+      | f :: fs ->
+        if Sys.file_exists f
+        then
+          if String.get f (String.length f - 1) = '~'
+          then loop result fs
+          else if Sys.is_directory f
+          then
+            Sys.readdir f
+            |> Array.to_list
+            |> List.rev_map (Filename.concat f)
+            |> List.rev_append fs
+            |> loop result
+          else (loop (f :: result) fs)
+        else (loop result fs)
+    in
+    loop [] [ Filename.concat plugin @@ "plugin_" ^ Filename.basename plugin ^ ".cmxs"
+            ; Filename.concat plugin "assets"
+            ]
+  in
+  let files = List.sort compare files in
+  let b = Buffer.create 1024 in
+  List.iter begin fun f ->
+    Digest.file f
+    |> Digest.to_hex
+    |> Buffer.add_string b
+  end files ;
+  Buffer.contents b
+  |> Digest.string
+  |> Digest.to_hex
+|};
+  print_endline {|let allowed p = match Filename.basename p with|};
+  Array.iter
+    (fun p ->
+      print_endline
+      @@ Printf.sprintf {||"%s" -> md5 p = "%s"|} p
+           (md5 @@ Filename.concat Sys.argv.(1) p))
+    (Sys.readdir Sys.argv.(1));
+  print_endline {||_ -> false|}

bin/gwd/request.ml

@@ -0,0 +1,835 @@
+(* Copyright (c) 1998-2007 INRIA *)
+
+open Geneweb
+open Config
+open Def
+open Gwdb
+open Util
+
+let person_is_std_key conf base p k =
+  let k = Name.strip_lower k in
+  if k = Name.strip_lower (p_first_name base p ^ " " ^ p_surname base p) then
+    true
+  else if
+    List.exists (fun n -> Name.strip n = k)
+      (person_misc_names base p (nobtit conf base))
+  then
+    true
+  else false
+
+let select_std_eq conf base pl k =
+  List.fold_right
+    (fun p pl -> if person_is_std_key conf base p k then p :: pl else pl) pl
+    []
+
+let find_all conf base an =
+  let sosa_ref = Util.find_sosa_ref conf base in
+  let sosa_nb = try Some (Sosa.of_string an) with _ -> None in
+  match sosa_ref, sosa_nb with
+  | Some p, Some n ->
+    if n <> Sosa.zero then
+      match Util.branch_of_sosa conf base n p with
+        Some (p :: _) -> [p], true
+      | _ -> [], false
+    else [], false
+  | _ ->
+    let acc = SearchName.search_by_key conf base an in
+    if acc <> [] then acc, false
+    else
+      ( SearchName.search_key_aux begin fun conf base acc an ->
+            let spl = select_std_eq conf base acc an in
+            if spl = [] then
+              if acc = [] then SearchName.search_by_name conf base an
+              else acc
+            else spl
+          end conf base an
+      , false )
+
+let relation_print conf base p =
+  let p1 =
+    match p_getenv conf.senv "ei" with
+    | Some i ->
+      conf.senv <- [] ;
+      let i = iper_of_string i in
+      if Gwdb.iper_exists base i
+      then Some (pget conf base i)
+      else None
+    | None ->
+      match find_person_in_env conf base "1" with
+      | Some p1 ->
+        conf.senv <- [];
+        Some p1
+      | None -> None
+  in
+  RelationDisplay.print conf base p p1
+
+let specify conf base n pl =
+  let title _ = Output.printf conf "%s : %s" n (transl conf "specify") in
+  let n = Name.crush_lower n in
+  let ptll =
+    List.map
+      (fun p ->
+         let tl = ref [] in
+         let add_tl t =
+           tl :=
+             let rec add_rec =
+               function
+                 t1 :: tl1 ->
+                 if eq_istr t1.t_ident t.t_ident &&
+                    eq_istr t1.t_place t.t_place
+                 then
+                   t1 :: tl1
+                 else t1 :: add_rec tl1
+               | [] -> [t]
+             in
+             add_rec !tl
+         in
+         let compare_and_add t pn =
+           let pn = sou base pn in
+           if Name.crush_lower pn = n then add_tl t
+           else
+             match get_qualifiers p with
+               nn :: _ ->
+               let nn = sou base nn in
+               if Name.crush_lower (pn ^ " " ^ nn) = n then add_tl t
+             | _ -> ()
+         in
+         List.iter
+           (fun t ->
+              match t.t_name, get_public_name p with
+                Tname s, _ -> compare_and_add t s
+              | _, pn when sou base pn <> "" -> compare_and_add t pn
+              | _ -> ())
+           (nobtit conf base p);
+         p, !tl)
+      pl
+  in
+  Hutil.header conf title;
+  Hutil.print_link_to_welcome conf true;
+  (* Si on est dans un calcul de parenté, on affiche *)
+  (* l'aide sur la sélection d'un individu.          *)
+  Util.print_tips_relationship conf;
+  Output.print_sstring conf "<ul>\n";
+  (* Construction de la table des sosa de la base *)
+  let () = SosaCache.build_sosa_ht conf base in
+  List.iter
+    (fun (p, _tl) ->
+       Output.print_sstring conf "<li>\n";
+       SosaCache.print_sosa conf base p true;
+       Update.print_person_parents_and_spouses conf base p;
+       Output.print_sstring conf "</li>\n"
+    ) ptll;
+  Output.print_sstring conf "</ul>\n";
+  Hutil.trailer conf
+
+let incorrect_request ?(comment = "") conf =
+  Hutil.incorrect_request ~comment:comment conf
+
+let person_selected conf base p =
+  match p_getenv conf.senv "em" with
+    Some "R" -> relation_print conf base p
+  | Some _ -> incorrect_request conf ~comment:"error #9"
+  | None -> record_visited conf (get_iper p); Perso.print conf base p
+
+let person_selected_with_redirect conf base p =
+  match p_getenv conf.senv "em" with
+  | Some "R" -> relation_print conf base p
+  | Some _ -> incorrect_request conf ~comment:"error #8"
+  | None ->
+    Wserver.http_redirect_temporarily
+      (commd conf ^^^ Util.acces conf base p :> string)
+
+let updmenu_print = Perso.interp_templ "updmenu"
+
+let very_unknown conf _ =
+  match p_getenv conf.env "n", p_getenv conf.env "p" with
+  | Some sname, Some fname ->
+    let title _ =
+      transl conf "not found"
+      |> Utf8.capitalize_fst
+      |> Output.print_sstring conf ;
+      Output.print_sstring conf (transl conf ":") ;
+      Output.print_sstring conf {| "|} ;
+      Output.print_string conf (Util.escape_html fname) ;
+      Output.print_sstring conf {| |} ;
+      Output.print_string conf (Util.escape_html sname) ;
+      Output.print_sstring conf {|"|} ;
+    in
+    Output.status conf Def.Not_Found;
+    Hutil.rheader conf title;
+    Hutil.print_link_to_welcome conf false;
+    Hutil.trailer conf
+  | _ ->
+    match p_getenv conf.env "i" with
+    | Some i ->
+      let title _ =
+        Output.print_sstring conf "<kbd>" ;
+        Output.print_string conf (Util.escape_html i) ;
+        Output.print_sstring conf "</kbd>" ;
+        Output.print_sstring conf (transl conf ":") ;
+        Output.print_sstring conf " " ;
+        transl conf "not found"
+        |> Utf8.capitalize_fst
+        |> Output.print_sstring conf ;
+      in
+      Output.status conf Def.Not_Found;
+      Hutil.rheader conf title;
+      Hutil.print_link_to_welcome conf false;
+      Hutil.trailer conf
+    | None -> Hutil.incorrect_request conf ~comment:"error #1"
+
+(* Print Not found page *)
+let unknown conf n =
+  let title _ =
+    transl conf "not found"
+    |> Utf8.capitalize_fst
+    |> Output.print_sstring conf ;
+    Output.print_sstring conf (transl conf ":") ;
+    Output.print_sstring conf {| "|} ;
+    Output.print_string conf (Util.escape_html n) ;
+    Output.print_sstring conf {|"|} ;
+  in
+  Output.status conf Def.Not_Found;
+  Hutil.rheader conf title;
+  Hutil.print_link_to_welcome conf false;
+  Hutil.trailer conf
+
+let make_henv conf base =
+  let conf =
+    match Util.find_sosa_ref conf base with
+    | Some p ->
+      let x =
+        let first_name = p_first_name base p in
+        let surname = p_surname base p in
+        if Util.accessible_by_key conf base p first_name surname then
+          [ "pz", Name.lower first_name |> Mutil.encode
+          ; "nz", Name.lower surname |> Mutil.encode
+          ; "ocz", get_occ p |> string_of_int |> Mutil.encode
+          ]
+        else [ "iz", get_iper p |> string_of_iper |> Mutil.encode ]
+      in
+      { conf with henv = conf.henv @ x }
+    | None -> conf
+  in
+  let conf =
+    match p_getenv conf.env "dsrc" with
+    | Some "" | None -> conf
+    | Some s -> { conf with henv = conf.henv @ ["dsrc", Mutil.encode s] }
+  in
+  let conf =
+    match p_getenv conf.env "templ" with
+    | None -> conf
+    | Some s -> { conf with henv = conf.henv @ ["templ", Mutil.encode s] }
+  in
+  let conf =
+    match Util.p_getenv conf.env "escache" with
+    | Some _ -> { conf with henv = conf.henv @ ["escache", escache_value base] }
+    | None -> conf
+  in
+  let conf =
+    if Util.p_getenv conf.env "manitou" = Some "off"
+    then { conf with henv = conf.henv @ ["manitou", Adef.encoded "off"] }
+    else conf
+  in
+  let aux param conf =
+    match Util.p_getenv conf.env param with
+    | Some s -> { conf with henv = conf.henv @ [param, Mutil.encode s] }
+    | None -> conf
+  in
+  aux "alwsurn" conf
+  |> aux "pure_xhtml"
+  |> aux "size"
+  |> aux "p_mod"
+  |> aux "wide"
+
+let special_vars =
+  [ "alwsurn"; "cgl"; "dsrc"; "em"; "ei"; "ep"; "en"; "eoc"; "escache"; "et";
+    "iz"; "long"; "manitou"; "nz"; "ocz";
+    "p_mod"; "pure_xhtml"; "pz"; "size"; "templ"; "wide" ]
+
+let only_special_env env = List.for_all (fun (x, _) -> List.mem x special_vars) env
+
+let make_senv conf base =
+  let set_senv conf vm vi =
+    let aux k v conf =
+      if p_getenv conf.env k = Some v
+      then { conf with senv = conf.senv @ [ k, Mutil.encode v ] }
+      else conf
+    in
+    let conf =
+      { conf with senv = ["em", vm; "ei", vi] }
+      |> aux "long" "on"
+    in
+    let conf =
+      match p_getenv conf.env "et" with
+      | Some x -> { conf with senv = conf.senv @ ["et", Mutil.encode x] }
+      | _ -> conf
+    in
+    let conf = aux "cgl" "on" conf in
+    let conf =
+      match p_getenv conf.env "bd" with
+      | None | Some ("0" | "") -> conf
+      | Some x -> { conf with senv = conf.senv @ ["bd", Mutil.encode x] }
+    in
+    match p_getenv conf.env "color" with
+    | Some x -> { conf with senv = conf.senv @ ["color", Mutil.encode x] }
+    | _ -> conf
+  in
+  let get x = Util.p_getenv conf.env x in
+  match get "em", get "ei", get "ep", get "en", get "eoc" with
+  | Some vm, Some vi, _, _, _ -> set_senv conf (Mutil.encode vm) (Mutil.encode vi)
+  | Some vm, None, Some vp, Some vn, voco ->
+    let voc =
+      match voco with
+      | Some voc -> (try int_of_string voc with Failure _ -> 0)
+      | None -> 0
+    in
+    let ip =
+      match person_of_key base vp vn voc with
+      | Some ip -> ip
+      | None -> Hutil.incorrect_request conf ~comment:"error #2"; raise Exit
+    in
+    let vi = string_of_iper ip in
+    set_senv conf (Mutil.encode vm) (Mutil.encode vi)
+  | _ -> conf
+
+let propose_base conf =
+  let title _ = Output.print_sstring conf "Base" in
+  Hutil.header conf title;
+  Output.print_sstring conf {|<ul><li><form method="GET" action="|} ;
+  Output.print_sstring conf conf.indep_command ;
+  Output.print_sstring conf {|">|} ;
+  Output.print_sstring conf {|<input name="b" size="40"> =&gt; |} ;
+  Output.print_sstring conf {|<button type="submit" class="btn btn-secondary btn-lg">|} ;
+  transl_nth conf "validate/delete" 0
+  |> Utf8.capitalize_fst
+  |> Output.print_sstring conf ;
+  Output.print_sstring conf "</button></li></ul>";
+  Hutil.trailer conf
+
+let try_plugin list conf base_name m =
+  let fn =
+    if List.mem "*" list
+    then (fun ( _, fn) -> fn conf base_name)
+    else (fun (ns, fn) -> (List.mem ns conf.forced_plugins || List.mem ns list) && fn conf base_name)
+  in
+  List.exists fn (Hashtbl.find_all GwdPlugin.ht m)
+
+let w_lock ~onerror fn conf (base_name : string option) =
+  let bfile = Util.bpath (conf.bname ^ ".gwb") in
+  Lock.control
+    (Mutil.lock_file bfile) true
+    ~onerror:(fun () -> onerror conf base_name)
+    (fun () -> fn conf base_name)
+
+let w_base ~none fn conf (bfile : string option) =
+  match bfile with
+  | None -> none conf
+  | Some bfile ->
+     let base = try Some (Gwdb.open_base bfile) with _ -> None in
+     match base with
+     | None -> none conf
+     | Some base ->
+        let conf = make_henv conf base in
+        let conf = make_senv conf base in
+        let conf = match Util.default_sosa_ref conf base with
+          | Some p -> { conf with default_sosa_ref = get_iper p, Some p;
+              nb_of_persons = Gwdb.nb_of_persons base }
+          | None -> { conf with
+              nb_of_persons = Gwdb.nb_of_persons base }
+        in
+        fn conf base
+
+let w_person ~none fn conf base =
+  match find_person_in_env conf base "" with
+  | Some p -> fn conf base p
+  | _ -> none conf base
+
+let output_error ?headers ?content conf code =
+  !GWPARAM.output_error ?headers ?content conf code
+
+let w_wizard fn conf base =
+  if conf.wizard then
+    fn conf base
+  else if conf.just_friend_wizard then
+    output_error conf Def.Forbidden
+  else
+    (* FIXME: send authentification headers *)
+    output_error conf Def.Unauthorized
+
+let treat_request =
+  let w_lock = w_lock ~onerror:(fun conf _ -> Update.error_locked conf) in
+  let w_base =
+    let none conf =
+      if conf.bname = "" then output_error conf Def.Bad_Request
+      else output_error conf Def.Not_Found
+    in
+    w_base ~none
+  in
+  let w_person = w_person ~none:very_unknown in
+  fun conf ->
+  let bfile =
+    if conf.bname = "" then None
+    else
+      let bfile = Util.bpath (conf.bname ^ ".gwb") in
+      if Sys.file_exists bfile
+      then Some bfile
+      else None
+  in
+  let process () =
+  if conf.wizard
+  || conf.friend
+  || List.assoc_opt "visitor_access" conf.base_env <> Some "no"
+  then begin
+#ifdef UNIX
+    begin match bfile with
+      | None -> ()
+      | Some bfile ->
+        let stat = Unix.stat bfile in
+        Unix.setgid stat.Unix.st_gid ;
+        Unix.setuid stat.Unix.st_uid ;
+    end ;
+#endif
+    let plugins =
+      match List.assoc_opt "plugins" conf.Config.base_env with
+      | None -> []
+      | Some list -> String.split_on_char ',' list
+    in
+    if List.mem "*" plugins then
+      List.iter (fun (_ , fn) -> fn conf bfile) !GwdPlugin.se
+    else
+      List.iter (fun (ns, fn) -> if List.mem ns plugins then fn conf bfile) !GwdPlugin.se ;
+    let m = Option.value ~default:"" (p_getenv conf.env "m") in
+    if not @@ try_plugin plugins conf bfile m
+    then begin
+        if List.assoc_opt "counter" conf.base_env <> Some "no" &&
+          m <> "IM" && m <> "IM_C" && m <> "SRC" && m <> "DOC"
+        then begin
+          match
+            if only_special_env conf.env
+            then SrcfileDisplay.incr_welcome_counter conf
+            else SrcfileDisplay.incr_request_counter conf
+          with
+          | Some (welcome_cnt, request_cnt, start_date) ->
+            GwdLog.log begin fun oc ->
+              let thousand oc x = output_string oc @@ Mutil.string_of_int_sep ","  x in
+              Printf.fprintf oc "  #accesses %a (#welcome %a) since %s\n"
+                thousand (welcome_cnt + request_cnt) thousand welcome_cnt
+                start_date
+            end ;
+          | None -> ()
+        end ;
+        let incorrect_request ?(comment = "") conf _ =
+          incorrect_request ~comment:comment conf
+        in
+        let doc_aux conf base print =
+          match Util.p_getenv conf.env "s" with
+          | Some f ->
+                if Filename.check_suffix f ".txt" then
+                  let f = Filename.chop_suffix f ".txt" in
+                  SrcfileDisplay.print_source conf base f
+                else print conf f
+          | _ -> incorrect_request conf ~comment:"error #3" base
+        in
+        match m with
+        | "" ->
+          let base =
+            match bfile with
+            | None -> None
+            | Some bfile -> try Some (Gwdb.open_base bfile) with _ -> None
+          in
+          if base <> None then
+            w_base @@
+            if only_special_env conf.env then SrcfileDisplay.print_start
+            else w_person @@ fun conf base p ->
+              match p_getenv conf.env "ptempl" with
+              | Some t when List.assoc_opt "ptempl" conf.base_env = Some "yes" ->
+                Perso.interp_templ t conf base p
+              | _ -> person_selected conf base p
+          else if conf.bname = ""
+          then fun conf _ -> include_template conf [] "index" (fun () -> propose_base conf)
+          else
+            w_base begin (* print_start -> welcome.txt *)
+              if only_special_env conf.env then SrcfileDisplay.print_start
+              else w_person @@ fun conf base p ->
+                match p_getenv conf.env "ptempl" with
+                | Some t when List.assoc_opt "ptempl" conf.base_env = Some "yes" ->
+                  Perso.interp_templ t conf base p
+                | _ -> person_selected conf base p
+            end
+
+        | "A" ->
+          AscendDisplay.print |> w_person |> w_base
+        | "ADD_FAM" ->
+          w_wizard @@ w_base @@ UpdateFam.print_add
+        | "ADD_FAM_OK" ->
+          w_wizard @@ w_lock @@ w_base @@ UpdateFamOk.print_add
+        | "ADD_IND" ->
+          w_wizard @@ w_base @@ UpdateInd.print_add
+        | "ADD_IND_OK" ->
+          w_wizard @@ w_lock @@ w_base @@ UpdateIndOk.print_add
+        | "ADD_PAR" ->
+          w_wizard @@ w_base @@ UpdateFam.print_add_parents
+        | "ADD_PAR_OK" ->
+          w_wizard @@ w_lock @@ w_base @@ UpdateFamOk.print_add_parents
+        | "ANM" ->
+          w_base @@ fun conf _ -> BirthdayDisplay.print_anniversaries conf
+        | "AN" ->
+          w_base @@ fun conf base -> begin match p_getenv conf.env "v" with
+            | Some x -> BirthdayDisplay.print_birth conf base (int_of_string x)
+            | _ -> BirthdayDisplay.print_menu_birth conf base
+          end
+        | "AD" ->
+          w_base @@ fun conf base -> begin match p_getenv conf.env "v" with
+            | Some x -> BirthdayDisplay.print_dead conf base (int_of_string x)
+            | _ -> BirthdayDisplay.print_menu_dead conf base
+          end
+        | "AM" ->
+          w_base @@ fun conf base -> begin match p_getenv conf.env "v" with
+            | Some x -> BirthdayDisplay.print_marriage conf base (int_of_string x)
+            | _ -> BirthdayDisplay.print_menu_marriage conf base
+          end
+        | "AS_OK" ->
+          w_base @@ AdvSearchOkDisplay.print
+        | "C" ->
+          w_base @@ w_person @@ CousinsDisplay.print
+        | "CAL" ->
+          fun conf _ -> Hutil.print_calendar conf
+        | "CHG_CHN" when conf.wizard ->
+          w_wizard @@ w_base @@ ChangeChildrenDisplay.print
+        | "CHG_CHN_OK" ->
+          w_wizard @@ w_lock @@ w_base @@ ChangeChildrenDisplay.print_ok
+        | "CHG_EVT_IND_ORD" ->
+          w_wizard @@ w_base @@ UpdateInd.print_change_event_order
+        | "CHG_EVT_IND_ORD_OK" ->
+          w_wizard @@ w_lock @@ w_base @@ UpdateIndOk.print_change_event_order
+        | "CHG_EVT_FAM_ORD" ->
+          w_wizard @@ w_base @@ UpdateFam.print_change_event_order
+        | "CHG_EVT_FAM_ORD_OK" ->
+          w_wizard @@ w_lock @@ w_base @@ UpdateFamOk.print_change_event_order
+        | "CHG_FAM_ORD" ->
+          w_wizard @@ w_base @@ UpdateFam.print_change_order
+        | "CHG_FAM_ORD_OK" ->
+          w_wizard @@ w_lock @@ w_base @@ UpdateFamOk.print_change_order_ok
+        | "CONN_WIZ" ->
+          w_wizard @@ w_base @@ WiznotesDisplay.connected_wizards
+        | "D" ->
+          w_base @@ w_person @@ DescendDisplay.print
+        | "DAG" ->
+          w_base @@ DagDisplay.print
+        | "DEL_FAM" ->
+          w_wizard @@ w_base @@ UpdateFam.print_del
+        | "DEL_FAM_OK" ->
+          w_wizard @@ w_lock @@ w_base @@ UpdateFamOk.print_del
+
+        | "DEL_IMAGE" ->
+          w_wizard @@ w_lock @@ w_base @@ ImageCarrousel.print_del
+        | "DEL_IMAGE_OK" ->
+          w_wizard @@ w_lock @@ w_base @@ ImageCarrousel.print_del_ok
+        | "DEL_IMAGE_C_OK" ->
+          w_wizard @@ w_lock @@ w_base @@ ImageCarrousel.print_main_c
+
+        | "DEL_IND" ->
+          w_wizard @@ w_base @@ UpdateInd.print_del
+        | "DEL_IND_OK" ->
+          w_wizard @@ w_lock @@ w_base @@ UpdateIndOk.print_del
+        | "DOC" ->
+          w_base @@ fun conf base -> doc_aux conf base
+            ImageDisplay.print_source
+        | "DOCH" ->
+          w_base @@ fun conf base -> doc_aux conf base
+            (fun conf _base -> ImageDisplay.print_html conf)
+        | "F" ->
+          w_base @@ w_person @@ Perso.interp_templ "family"
+        | "H" ->
+          w_wizard @@ w_base @@ fun conf base ->
+            ( match p_getenv conf.env "v" with
+            | Some f -> SrcfileDisplay.print conf base f
+            | None -> incorrect_request conf base ~comment:"error #4")
+        | "HIST" ->
+          w_base @@ History.print
+        | "HIST_CLEAN" ->
+          w_wizard @@ w_base @@ fun conf _ -> HistoryDiffDisplay.print_clean conf
+        | "HIST_CLEAN_OK" ->
+          w_wizard @@ w_base @@ fun conf _ -> HistoryDiffDisplay.print_clean_ok conf
+        | "HIST_DIFF" ->
+          w_base @@ HistoryDiffDisplay.print
+        | "HIST_SEARCH" ->
+          w_base @@ History.print_search
+
+        | "IM_C" ->
+          w_base @@ ImageCarrousel.print_c ~saved:false
+        | "IM_C_S" ->
+          w_base @@ ImageCarrousel.print_c ~saved:true
+
+
+        | "IM" ->
+          w_base @@ ImageDisplay.print
+        | "IMH" ->
+          w_base @@ fun conf _ -> ImageDisplay.print_html conf
+        | "INV_FAM" ->
+          w_wizard @@ w_base @@ UpdateFam.print_inv
+        | "INV_FAM_OK" ->
+          w_wizard @@ w_lock @@ w_base @@ UpdateFamOk.print_inv
+        | "KILL_ANC" ->
+          w_wizard @@ w_lock @@ w_base @@ MergeIndDisplay.print_kill_ancestors
+        | "L" -> w_base @@ fun conf base -> Perso.interp_templ "list" conf base 
+              (Gwdb.empty_person base Gwdb.dummy_iper) 
+        | "LB" when conf.wizard || conf.friend ->
+          w_base @@ BirthDeathDisplay.print_birth
+        | "LD" when conf.wizard || conf.friend ->
+          w_base @@ BirthDeathDisplay.print_death
+        | "LINKED" ->
+          w_base @@ w_person @@ Perso.print_what_links
+        | "LL" ->
+          w_base @@ BirthDeathDisplay.print_longest_lived
+        | "LM" when conf.wizard || conf.friend ->
+          w_base @@ BirthDeathDisplay.print_marriage
+        | "MISC_NOTES" ->
+          w_base @@ NotesDisplay.print_misc_notes
+        | "MISC_NOTES_SEARCH" ->
+          w_base @@ NotesDisplay.print_misc_notes_search
+        | "MOD_DATA" ->
+          w_wizard @@ w_base @@ UpdateDataDisplay.print_mod
+        | "MOD_DATA_OK" ->
+          w_wizard @@ w_lock @@ w_base @@ UpdateDataDisplay.print_mod_ok
+        | "MOD_FAM" ->
+          w_wizard @@ w_base @@ UpdateFam.print_mod
+        | "MOD_FAM_OK" when conf.wizard ->
+          w_wizard @@ w_lock @@ w_base @@ UpdateFamOk.print_mod
+        | "MOD_IND" ->
+          w_wizard @@ w_base @@ UpdateInd.print_mod
+        | "MOD_IND_OK" ->
+          w_wizard @@ w_lock @@ w_base @@ UpdateIndOk.print_mod
+        | "MOD_NOTES" ->
+          w_wizard @@ w_base @@ NotesDisplay.print_mod
+        | "MOD_NOTES_OK" ->
+          w_wizard @@ w_lock @@ w_base @@ NotesDisplay.print_mod_ok
+        | "MOD_WIZNOTES" when conf.authorized_wizards_notes ->
+          w_base @@ WiznotesDisplay.print_mod
+        | "MOD_WIZNOTES_OK" when conf.authorized_wizards_notes ->
+          w_lock @@ w_base @@ WiznotesDisplay.print_mod_ok
+        | "MRG" ->
+          w_wizard @@ w_base @@ w_person @@ MergeDisplay.print
+        | "MRG_DUP" ->
+          w_wizard @@ w_base @@ MergeDupDisplay.main_page
+        | "MRG_DUP_IND_Y_N" ->
+          w_wizard @@ w_lock @@ w_base @@ MergeDupDisplay.answ_ind_y_n
+        | "MRG_DUP_FAM_Y_N" ->
+          w_wizard @@ w_lock @@ w_base @@ MergeDupDisplay.answ_fam_y_n
+        | "MRG_FAM" ->
+          w_wizard @@ w_base @@ MergeFamDisplay.print
+        | "MRG_FAM_OK" ->
+          w_wizard @@ w_lock @@ w_base @@ MergeFamOk.print_merge
+        | "MRG_MOD_FAM_OK" ->
+          w_wizard @@ w_lock @@ w_base @@ MergeFamOk.print_mod_merge
+        | "MRG_IND" ->
+          w_wizard @@ w_lock @@ w_base @@ MergeIndDisplay.print
+        | "MRG_IND_OK" -> (* despite the _OK suffix, this one does not actually update databse *)
+          w_wizard @@ w_base @@ MergeIndOkDisplay.print_merge
+        | "MRG_MOD_IND_OK" ->
+          w_wizard @@ w_lock @@ w_base @@ MergeIndOkDisplay.print_mod_merge
+        | "N" ->
+          w_base @@ fun conf base -> begin match p_getenv conf.env "v" with
+            | Some v -> Some.search_surname_print conf base Some.surname_not_found v
+            | _ -> AllnDisplay.print_surnames conf base
+          end
+        | "NG" -> w_base @@ begin fun conf base ->
+            (* Rétro-compatibilité <= 6.06 *)
+            let env =
+              match p_getenv conf.env "n" with
+                Some n ->
+                begin match p_getenv conf.env "t" with
+                    Some "P" -> ("fn", Mutil.encode n) :: conf.env
+                  | Some "N" -> ("sn", Mutil.encode n) :: conf.env
+                  | _ -> ("v", Mutil.encode n) :: conf.env
+                end
+              | None -> conf.env
+            in
+            let conf = {conf with env = env} in
+            (* Nouveau mode de recherche. *)
+            match p_getenv conf.env "select" with
+            | Some "input" | None ->
+              (* Récupère le contenu non vide de la recherche. *)
+              let real_input label =
+                match p_getenv conf.env label with
+                | Some s -> if s = "" then None else Some s
+                | None -> None
+              in
+              (* Recherche par clé, sosa, alias ... *)
+              let search n =
+                let (pl, sosa_acc) = find_all conf base n in
+                match pl with
+                | [] ->
+                  Some.search_surname_print conf base unknown n
+                | [p] ->
+                  if sosa_acc
+                  || Gutil.person_of_string_key base n <> None
+                  || person_is_std_key conf base p n
+                  then person_selected_with_redirect conf base p
+                  else specify conf base n pl
+                | pl -> specify conf base n pl
+              in
+              begin match real_input "v" with
+                | Some n -> search n
+                | None ->
+                  match real_input "fn", real_input "sn" with
+                    Some fn, Some sn -> search (fn ^ " " ^ sn)
+                  | Some fn, None ->
+                    Some.search_first_name_print conf base fn
+                  | None, Some sn ->
+                    Some.search_surname_print conf base unknown sn
+                  | None, None -> incorrect_request conf base ~comment:"error #5"
+              end
+            | Some i ->
+              relation_print conf base
+                (pget conf base (iper_of_string i))
+          end
+        | "NOTES" ->
+          w_base @@ NotesDisplay.print
+        | "OA" when conf.wizard || conf.friend ->
+          w_base @@ BirthDeathDisplay.print_oldest_alive
+        | "OE" when conf.wizard || conf.friend ->
+          w_base @@ BirthDeathDisplay.print_oldest_engagements
+        | "P" ->
+          w_base @@ fun conf base -> begin match p_getenv conf.env "v" with
+            | Some v -> Some.search_first_name_print conf base v
+            | None -> AllnDisplay.print_first_names conf base
+          end
+
+
+        | "PERSO" ->
+          w_base @@ w_person @@ Geneweb.Perso.interp_templ "perso"
+
+        | "POP_PYR" when conf.wizard || conf.friend ->
+          w_base @@ BirthDeathDisplay.print_population_pyramid
+        | "PS" ->
+          w_base @@ PlaceDisplay.print_all_places_surnames
+        | "PPS" ->
+          w_base @@ Place.print_all_places_surnames
+        | "R" ->
+          w_base @@ w_person @@ relation_print
+        | "REFRESH" ->
+          w_base @@ w_person @@ Perso.interp_templ "carrousel"
+        | "REQUEST" ->
+          w_wizard @@ fun _ _ ->
+            Output.status conf Def.OK;
+            Output.header conf "Content-type: text";
+            List.iter begin fun s ->
+              Output.print_sstring conf s ;
+              Output.print_sstring conf "\n"
+            end conf.Config.request ;
+
+        | "RESET_IMAGE_C_OK" ->
+          w_base @@ ImageCarrousel.print_main_c
+
+        | "RL" ->
+          w_base @@ RelationLink.print
+        | "RLM" ->
+          w_base @@ RelationDisplay.print_multi
+        | "S" ->
+          w_base @@ fun conf base -> SearchName.print conf base specify unknown
+
+        | "SND_IMAGE" -> w_wizard @@w_lock @@ w_base @@ ImageCarrousel.print
+        | "SND_IMAGE_OK" ->
+           w_wizard @@ w_lock @@ w_base @@ ImageCarrousel.print_send_ok
+        | "SND_IMAGE_C" ->
+          w_base @@ w_person @@ Perso.interp_templ "carrousel"
+        | "SND_IMAGE_C_OK" ->
+          w_wizard @@ w_lock @@ w_base @@ ImageCarrousel.print_main_c
+
+        | "SRC" ->
+          w_base @@ fun conf base -> begin match p_getenv conf.env "v" with
+            | Some f -> SrcfileDisplay.print_source conf base f
+            | _ -> incorrect_request conf base ~comment:"error #6"
+          end
+        | "STAT" ->
+          w_base @@ fun conf _ -> BirthDeathDisplay.print_statistics conf
+        | "CHANGE_WIZ_VIS" ->
+          w_wizard @@ w_lock @@ w_base @@ WiznotesDisplay.change_wizard_visibility
+        | "TP" ->
+          w_base @@ fun conf base ->
+            begin match Util.p_getenv conf.env "v" with
+            | Some f ->
+              begin match Util.find_person_in_env conf base "" with
+              | Some p -> Perso.interp_templ ("tp_" ^ f) conf base p
+              | _ -> Perso.interp_templ ("tp0_" ^ f) conf base
+                       (Gwdb.empty_person base Gwdb.dummy_iper)
+              end
+            | None -> incorrect_request conf base ~comment:"error #7"
+            end
+        | "TT" ->
+          w_base @@ TitleDisplay.print
+        | "U" ->
+          w_wizard @@ w_base @@ w_person @@ updmenu_print
+        | "VIEW_WIZNOTES" when conf.authorized_wizards_notes ->
+          w_wizard @@ w_base @@ WiznotesDisplay.print_view
+        | "WIZNOTES" when conf.authorized_wizards_notes ->
+          w_base @@ WiznotesDisplay.print
+        | "WIZNOTES_SEARCH" when conf.authorized_wizards_notes ->
+          w_base @@ WiznotesDisplay.print_search
+        | _ ->
+            w_base @@ fun conf base ->
+            incorrect_request conf base ~comment:"error #10"
+      end conf bfile ;
+  end else begin
+    let title _ =
+      Printf.sprintf "%s %s %s"
+      (transl conf "base" |> Utf8.capitalize_fst)
+      conf.bname
+      (transl conf "reserved to friends or wizards")
+      |> Output.print_sstring conf
+    in
+    Hutil.rheader conf title ;
+    let base_name =
+      if conf.cgi then (Printf.sprintf "b=%s&" conf.bname) else ""
+    in
+    let user = transl_nth conf "user/password/cancel" 0 in
+    let passwd = transl_nth conf "user/password/cancel" 1 in
+    let body =
+      if conf.cgi then
+        Printf.sprintf {|
+            <input type="text" class="form-control" name="w"
+              title="%s/%s %s" placeholder="%s:%s"
+              aria-label="password input"
+              aria-describedby="username:password" autofocus>
+            <label for="w" class="sr-only">%s:%s</label>
+            <div class="input-group-append">
+              <button type="submit" class="btn btn-primary">OK</button>
+            </div>|}
+            (transl_nth conf "wizard/wizards/friend/friends/exterior" 2)
+            (transl_nth conf "wizard/wizards/friend/friends/exterior" 0)
+            passwd user passwd user passwd
+      else
+        Printf.sprintf {|
+            <div>
+              <ul>
+              <li>%s%s <a href="%s?%sw=f"> %s</a></li>
+              <li>%s%s <a href="%s?%sw=w"> %s</a></li>
+              </ul>
+            </div> |}
+            (transl conf "access" |> Utf8.capitalize_fst) (transl conf ":")
+            (conf.command :> string) base_name
+            (transl_nth conf "wizard/wizards/friend/friends/exterior" 2)
+            (transl conf "access" |> Utf8.capitalize_fst) (transl conf ":")
+            (conf.command :> string) base_name
+            (transl_nth conf "wizard/wizards/friend/friends/exterior" 0)
+    in
+    Output.print_sstring conf 
+      (Printf.sprintf {|
+        <form class="form-inline" method="post" action="%s">
+          <div class="input-group mt-1">
+            <input type="hidden" name="b" value="%s">
+            %s
+          </div>
+        </form>
+      |} (conf.command :> string) (conf.bname) body
+      );
+    Hutil.trailer conf
+  end
+  in
+  if conf.debug then Mutil.bench (__FILE__ ^ " " ^ string_of_int __LINE__) process
+  else process ()
+
+let treat_request conf =
+  try treat_request conf with Update.ModErr _ -> Output.flush conf

bin/gwd/request.mli

@@ -0,0 +1,59 @@
+(* Copyright (c) 1998-2007 INRIA *)
+
+open Geneweb
+
+val make_senv : Config.config -> Gwdb.base -> Config.config
+val make_henv : Config.config -> Gwdb.base -> Config.config
+
+val w_base :
+  none:(Config.config -> 'a) ->
+  (Config.config -> Gwdb.base -> 'a) ->
+  Config.config ->
+  string option ->
+  'a
+(** [w_lock ~none callback conf base]
+    Acquire a write lock on the base and call [callback], or fail with [none].
+*)
+
+val w_lock :
+  onerror:(Config.config -> string option -> 'a) ->
+  (Config.config -> string option -> 'a) ->
+  Config.config ->
+  string option ->
+  'a
+(** [w_lock ~onerror callback conf base]
+    Acquire a write lock on the base and call the callback, or fail with [onerror].
+*)
+
+val w_wizard :
+  (Config.config -> Gwdb.base -> unit) -> Config.config -> Gwdb.base -> unit
+(** [w_wizard callback conf base]
+    Run [callback conf base] if conf has wizard rights or
+    return [Forbidden] or [Unauthorized].
+*)
+
+val w_person :
+  none:(Config.config -> Gwdb.base -> 'a) ->
+  (Config.config -> Gwdb.base -> Gwdb.person -> 'a) ->
+  Config.config ->
+  Gwdb.base ->
+  'a
+(** [w_person ~none callback conf base]
+    Find a person in environement and call [callback], or fail with [none].
+*)
+
+(**/**)
+
+(* Used internally by [gwd]. Not intended to be used by other programs. *)
+val treat_request : Config.config -> unit
+
+(**/**)
+
+(**/**)
+
+(* Used by v7 plugin *)
+val incorrect_request : ?comment:string -> Config.config -> unit
+val very_unknown : Config.config -> Gwdb.base -> unit
+val only_special_env : (string * _) list -> bool
+
+(**/**)

bin/gwd/robot.ml

@@ -0,0 +1,206 @@
+(* Copyright (c) 1998-2007 INRIA *)
+
+open Geneweb
+open Config
+
+let magic_robot = "GWRB0007"
+
+module W = Map.Make (struct
+  type t = string
+
+  let compare = compare
+end)
+
+type norfriwiz = Normal | Friend of string | Wizard of string
+
+type who = {
+  acc_times : float list;
+  oldest_time : float;
+  nb_connect : int;
+  nbase : string;
+  utype : norfriwiz;
+}
+
+type excl = {
+  mutable excl : (string * int ref) list;
+  mutable who : who W.t;
+  mutable max_conn : int * string;
+}
+
+let robot_error conf cnt sec =
+  Output.status conf Def.Forbidden;
+  Output.header conf "Content-type: text/html; charset=iso-8859-1";
+  let env =
+    [
+      ("cnt", Adef.encoded (string_of_int cnt));
+      ("sec", Adef.encoded (string_of_int sec));
+    ]
+  in
+  Util.include_template conf env "robot" (fun () ->
+      let title _ = Output.print_sstring conf "Access refused" in
+      Output.print_sstring conf "<head><title>";
+      title true;
+      Output.print_sstring conf "</title>\n<body>\n<h1>";
+      title false;
+      Output.print_sstring conf "</body>\n");
+  raise Exit
+
+let purge_who tm xcl sec =
+  let sec = float sec in
+  let to_remove =
+    W.fold
+      (fun k who l ->
+        match who.acc_times with
+        | tm0 :: _ -> if tm -. tm0 > sec then k :: l else l
+        | [] -> k :: l)
+      xcl.who []
+  in
+  List.iter (fun k -> xcl.who <- W.remove k xcl.who) to_remove
+
+let input_excl ic =
+  let b = really_input_string ic (String.length magic_robot) in
+  if b <> magic_robot then raise Not_found else (input_value ic : excl)
+
+let output_excl oc xcl =
+  output_string oc magic_robot;
+  output_value oc (xcl : excl)
+
+let robot_excl () =
+  let fname = SrcfileDisplay.adm_file "robot" in
+  let xcl =
+    match try Some (Secure.open_in_bin fname) with _ -> None with
+    | Some ic ->
+        let v =
+          try input_excl ic
+          with _ -> { excl = []; who = W.empty; max_conn = (0, "") }
+        in
+        close_in ic;
+        v
+    | None -> { excl = []; who = W.empty; max_conn = (0, "") }
+  in
+  (xcl, fname)
+
+let min_disp_req = ref 6
+
+let check tm from max_call sec conf suicide =
+  let nfw =
+    if conf.wizard then Wizard conf.user
+    else if conf.friend then Friend conf.user
+    else Normal
+  in
+  let xcl, fname = robot_excl () in
+  let refused =
+    match try Some (List.assoc from xcl.excl) with Not_found -> None with
+    | Some att ->
+        incr att;
+        if !att mod max_call = 0 then
+          Gwd_lib.GwdLog.syslog `LOG_NOTICE
+          @@ Printf.sprintf
+               {|From: %s --- %d refused attempts --- to restore access, delete file "%s"|}
+               from !att fname;
+        true
+    | None ->
+        purge_who tm xcl sec;
+        let r = try (W.find from xcl.who).acc_times with Not_found -> [] in
+        let cnt, tml, tm0 =
+          let sec = float sec in
+          let rec count cnt tml = function
+            | [] -> (cnt, tml, tm)
+            | [ tm1 ] ->
+                if tm -. tm1 < sec then (cnt + 1, tm1 :: tml, tm1)
+                else (cnt, tml, tm1)
+            | tm1 :: tml1 ->
+                if tm -. tm1 < sec then count (cnt + 1) (tm1 :: tml) tml1
+                else (cnt, tml, tm1)
+          in
+          count 1 [] r
+        in
+        let r = List.rev tml in
+        xcl.who <-
+          W.add from
+            {
+              acc_times = tm :: r;
+              oldest_time = tm0;
+              nb_connect = cnt;
+              nbase = conf.bname;
+              utype = nfw;
+            }
+            xcl.who;
+        let refused =
+          if suicide || cnt > max_call then (
+            Gwd_lib.GwdLog.log (fun oc ->
+                Printf.fprintf oc "--- %s is a robot" from;
+                if suicide then
+                  Printf.fprintf oc " (called the \"suicide\" request)\n"
+                else
+                  Printf.fprintf oc
+                    " (%d > %d connections in %g <= %d seconds)\n" cnt max_call
+                    (tm -. tm0) sec);
+            xcl.excl <- (from, ref 1) :: xcl.excl;
+            xcl.who <- W.remove from xcl.who;
+            xcl.max_conn <- (0, "");
+            true)
+          else false
+        in
+        (match xcl.excl with
+        | [ _; _ ] ->
+            Gwd_lib.GwdLog.log (fun oc ->
+                List.iter
+                  (fun (s, att) ->
+                    Printf.fprintf oc "--- excluded:";
+                    Printf.fprintf oc " %s (%d refused attempts)\n" s !att)
+                  xcl.excl;
+                Printf.fprintf oc "--- to restore access, delete file \"%s\"\n"
+                  fname)
+        | _ -> ());
+        let list, nconn =
+          W.fold
+            (fun k w (list, nconn) ->
+              let tm = w.oldest_time in
+              let nb = w.nb_connect in
+              if nb > fst xcl.max_conn then xcl.max_conn <- (nb, k);
+              ( (if nb < !min_disp_req then list else (k, tm, nb) :: list),
+                nconn + 1 ))
+            xcl.who ([], 0)
+        in
+        let list =
+          List.sort
+            (fun (_, tm1, nb1) (_, tm2, nb2) ->
+              match compare nb2 nb1 with 0 -> compare tm2 tm1 | x -> x)
+            list
+        in
+        Gwd_lib.GwdLog.log (fun oc ->
+            List.iter
+              (fun (k, tm0, nb) ->
+                Printf.fprintf oc "--- %3d req - %3.0f sec - %s\n" nb
+                  (tm -. tm0) k)
+              list;
+            Printf.fprintf oc "--- max %d req by %s / conn %d\n"
+              (fst xcl.max_conn) (snd xcl.max_conn) nconn);
+        refused
+  in
+  (match try Some (Secure.open_out_bin fname) with Sys_error _ -> None with
+  | Some oc ->
+      output_excl oc xcl;
+      close_out oc
+  | None -> ());
+  if refused then robot_error conf max_call sec;
+  W.fold
+    (fun _ w (c, cw, cf, wl) ->
+      if w.nbase = conf.bname && w.nbase <> "" then
+        match w.utype with
+        | Wizard n ->
+            let at = List.hd w.acc_times in
+            if List.mem_assoc n wl then
+              let old_at = List.assoc n wl in
+              if at > old_at then
+                let wl = List.remove_assoc n wl in
+                (c, cw, cf, (n, at) :: wl)
+              else (c, cw, cf, wl)
+            else (c + 1, cw + 1, cf, (n, at) :: wl)
+        | Friend _ ->
+            if w.nb_connect > 2 then (c + 1, cw, cf + 1, wl) else (c, cw, cf, wl)
+        | Normal ->
+            if w.nb_connect > 2 then (c + 1, cw, cf, wl) else (c, cw, cf, wl)
+      else (c, cw, cf, wl))
+    xcl.who (0, 0, 0, [])

bin/gwd/robot.mli

@@ -0,0 +1,53 @@
+(** A module handling robots requests *)
+(* S: This module seems obsolete *)
+
+val magic_robot : string
+
+module W : Map.S with type key = string
+
+type norfriwiz = Normal | Friend of string | Wizard of string
+
+type who = private {
+  acc_times : float list;  (** The timings of the connexion attempts *)
+  oldest_time : float;
+      (** The first connection in the specified window
+                           (check option -robot-xcl) of time in which successive
+                           connections are attempted. *)
+  nb_connect : int;  (** The number of connection in the specified window. *)
+  nbase : string;  (** Always be equal to conf.bname *)
+  utype : norfriwiz;  (** The kind of robot *)
+}
+
+type excl = {
+  mutable excl : (string * int ref) list;
+  mutable who : who W.t;
+  mutable max_conn : int * string;
+}
+(** A collection of robots: the list contains forbidden robots and
+    the map contains accepted (under conditions) robots. *)
+
+val robot_error : Geneweb.Config.config -> int -> int -> 'a
+(** Prints an error "Access refuned" in HTML and raises an `Exit` exception. *)
+
+val robot_excl : unit -> excl * string
+(** Reads the content of the admin file managing robots and returns its content
+    and the full file name. *)
+
+val min_disp_req : int ref
+
+val check :
+  float ->
+  string ->
+  int ->
+  int ->
+  Geneweb.Config.config ->
+  bool ->
+  int * int * int * (string * float) list
+(** [check tm from max_call sec conf suicide]
+    Returns a tuple containing:
+    * the number of robots who attempted to connect twice
+    * the number of wizard robots who attempted to connect twice
+    * the number of friend robots who attempted to connect twice
+    * the wizards list and their last connection attempt.
+    It also updates the robot file by blocking robots who did too many attempts.
+*)

bin/gwdiff/README

@@ -0,0 +1,51 @@
+OVERVIEW:
+
+gwdiff will help you to target differences between two GeneWeb databases. So
+far it needs your help to know what to compare. Two modes are available:
+
+ - descendants checks (option -d): it will compare the descendants of the
+    person you have found in both databases (Spouses and their parents are
+    compared too)
+
+ - descendants of all ascendants (option -ad): it will found ascendants of the 
+    person you have found in both databases that are available in both data
+    bases. For each top person identified, it will compare its descendants in
+    both databases.
+
+USAGE:
+
+Your cousin has just sent you a new GEDCOM file, import it to GeneWeb (data
+base b1). You want to update your database (b2) according to b1 database.
+Now, find a person defined in both databases (ex.: Jean DUPONT). In base b1,
+it is "Jean.0 DUPONT"; in base b2, it is "Jean.3 DUPONT". Run the following
+command:
+
+ gwdiff -d -1 Jean 0 DUPONT -2 Jean 3 DUPONT b1 b2
+
+If your are interested in the descendants of its ascendants, you can try:
+
+ gwdiff -ad -1 Jean 0 DUPONT -2 Jean 3 DUPONT b1 b2
+
+So far, the checks include:
+ - first name: value from b1 has to be found in b2 (first name or first name
+    aliases)
+ - surname: value from b1 has to be found in b2 (surname or surname aliases)
+ - birth date
+ - birth place: if it is set in b1, it has to be set in b2 (whatever the value)
+ - death status
+ - death date
+ - death place: if it is set in b1, it has to be set in b2 (whatever the value)
+ - occupation: if it is set in b1, it has to be set in b2 (whatever the value)
+ - marriage date
+ - marriage place: if it is set in b1, it has to be set in b2 (whatever the
+    value)
+ - divorce date
+ - spouses
+ - parents of spouses
+ - children
+
+BUG REPORTS AND USER FEEDBACK:
+
+Send your bug reports by E-mail to:
+
+   Ludovic LEDIEU: lledieu@free.fr

bin/gwdiff/dune.in

@@ -0,0 +1,6 @@
+(executables
+  (names gwdiff)
+  (public_names geneweb.gwdiff)
+  (modules gwdiff)
+  (libraries unix str %%%GWDB_PKG%%% %%%SOSA_PKG%%% geneweb)
+)

bin/gwdiff/gwdiff.ml

@@ -0,0 +1,652 @@
+(* Copyright (c) 2001 Ludovic LEDIEU *)
+
+open Def
+open Gwdb
+
+(*= TODO =====================================================================
+  - Improve the way not to check several time the same persons.
+=========================================================================== *)
+
+let in_file1 = ref ""
+let in_file2 = ref ""
+let html = ref false
+let root = ref ""
+let cr = ref ""
+
+(** Messages are printed when there is a difference between a person
+    present in the two bases explored. *)
+type messages =
+  | MsgBadChild of iper
+  | MsgBirthDate
+  | MsgBirthPlace
+  | MsgChildMissing of iper
+  | MsgChildren of iper
+  | MsgDeathDate
+  | MsgDeathPlace
+  | MsgDivorce
+  | MsgFirstName
+  | MsgOccupation
+  | MsgParentsMissing
+  | MsgMarriageDate
+  | MsgMarriagePlace
+  | MsgSex
+  | MsgSpouseMissing of iper
+  | MsgSpouses of iper
+  | MsgSurname
+
+(** [person_string base iper]
+    Returns the string associated to the person with id `iper` in the base
+    `base`. *)
+let person_string base iper =
+  let p = poi base iper in
+  let fn = sou base (get_first_name p) in
+  let sn = sou base (get_surname p) in
+  if sn = "?" || fn = "?" then fn ^ " " ^ sn ^ " (#" ^ string_of_iper iper ^ ")"
+  else fn ^ "." ^ string_of_int (get_occ p) ^ " " ^ sn
+
+(** Returns the string associated to a person in HTML if the html option is set,
+    otherwise it has the same effect tja, `person_string`. *)
+let person_link bname base iper target =
+  if !html then
+    Printf.sprintf "<A HREF=\"%s%s_w?i=%s\" TARGET=\"%s\">%s</A>" !root bname
+      (string_of_iper iper) target (person_string base iper)
+  else person_string base iper
+
+(** Prints a message *)
+let print_message base1 msg =
+  Printf.printf " ";
+  (match msg with
+  | MsgBadChild iper1 ->
+      Printf.printf "can not isolate one child match: %s"
+        (person_link !in_file1 base1 iper1 "base1")
+  | MsgBirthDate -> Printf.printf "birth date"
+  | MsgBirthPlace -> Printf.printf "birth place"
+  | MsgChildMissing iper1 ->
+      Printf.printf "child missing: %s"
+        (person_link !in_file1 base1 iper1 "base1")
+  | MsgChildren iper1 ->
+      Printf.printf "more than one child match: %s"
+        (person_link !in_file1 base1 iper1 "base1")
+  | MsgDeathDate -> Printf.printf "death (status or date)"
+  | MsgDeathPlace -> Printf.printf "death place"
+  | MsgDivorce -> Printf.printf "divorce"
+  | MsgFirstName -> Printf.printf "first name"
+  | MsgOccupation -> Printf.printf "occupation"
+  | MsgParentsMissing -> Printf.printf "parents missing"
+  | MsgMarriageDate -> Printf.printf "marriage date"
+  | MsgMarriagePlace -> Printf.printf "marriage place"
+  | MsgSex -> Printf.printf "sex"
+  | MsgSpouseMissing iper1 ->
+      Printf.printf "spouse missing: %s"
+        (person_link !in_file1 base1 iper1 "base1")
+  | MsgSpouses iper1 ->
+      Printf.printf "more than one spouse match: %s"
+        (person_link !in_file1 base1 iper1 "base1")
+  | MsgSurname -> Printf.printf "surname");
+  Printf.printf "%s" !cr
+
+(** Prints messages associates to the two families identifiers in argument *)
+let print_f_messages base1 base2 ifam1 ifam2 res =
+  let f1 = foi base1 ifam1 in
+  let f2 = foi base2 ifam2 in
+  Printf.printf "%s x %s%s/ %s x %s%s"
+    (person_link !in_file1 base1 (get_father f1) "base1")
+    (person_link !in_file1 base1 (get_mother f1) "base1")
+    !cr
+    (person_link !in_file2 base2 (get_father f2) "base2")
+    (person_link !in_file2 base2 (get_father f2) "base2")
+    !cr;
+  List.iter (print_message base1) res
+
+(** Same, but for persons *)
+let print_p_messages base1 base2 iper1 iper2 res =
+  Printf.printf "%s / %s%s"
+    (person_link !in_file1 base1 iper1 "base1")
+    (person_link !in_file2 base2 iper2 "base2")
+    !cr;
+  List.iter (print_message base1) res
+
+(** [compatible_names src_name dest_name_list]
+    Returns true if `src_name` is in `dest_name_list` (case insensitive) *)
+let compatible_names src_name dest_name_list =
+  let src_name = Name.lower src_name in
+  let dest_name_list = List.map Name.lower dest_name_list in
+  List.mem src_name dest_name_list
+
+(** [compatible_str_field istr1 istr2]
+    Checks the compatibility of two string identifiers, i.e.
+    if istr1 is not the empty string identifier, then istr2
+    must not be. *)
+let compatible_str_field istr1 istr2 =
+  is_empty_string istr1 || not (is_empty_string istr2)
+
+(** Returns a list of intervals of SDN (SDN 1 is November 25, 4714 BC Gregorian
+    calendar) of the date in argument. An interval has the format (b, b'),
+    where b is an optional lower bound (None => no bound), and b' an optional
+    upper bound. *)
+let dmy_to_sdn_range_l dmy =
+  let sdn_of_dmy dmy =
+    let sdn = Calendar.sdn_of_gregorian dmy in
+    let sdn = if dmy.month = 0 || dmy.day = 0 then sdn + 1 else sdn in
+    let sdn2 =
+      if dmy.delta != 0 then sdn + dmy.delta
+      else
+        let dmy2 =
+          {
+            year =
+              (if dmy.month = 0 || (dmy.month = 12 && dmy.day = 0) then
+               dmy.year + 1
+              else dmy.year);
+            month =
+              (if dmy.month = 0 then 1
+              else if dmy.day = 0 then
+                if dmy.month = 12 then 1 else dmy.month + 1
+              else dmy.month);
+            day = (if dmy.day = 0 then 1 else dmy.day);
+            prec = (if dmy.month = 0 || dmy.day = 0 then Before else Sure);
+            delta = dmy.delta;
+          }
+        in
+        let sdn2 = Calendar.sdn_of_gregorian dmy2 in
+        if dmy2.prec = Before then sdn2 - 1 else sdn2
+    in
+    (sdn, sdn2)
+  in
+  (* S: calls to sdn_of_dmy dmy can be factorized *)
+  match dmy.prec with
+  | Sure ->
+      let sdn1, sdn2 = sdn_of_dmy dmy in
+      [ (Some sdn1, Some sdn2) ]
+  | Maybe ->
+      let sdn1, sdn2 = sdn_of_dmy dmy in
+      [ (Some sdn1, Some sdn2); (None, None) ]
+  | About ->
+      let sdn1, sdn2 = sdn_of_dmy dmy in
+      let delta = (sdn2 - sdn1 + 1) * 5 in
+      [ (Some (sdn1 - delta), Some (sdn2 + delta)) ]
+  | Before ->
+      let _sdn1, sdn2 = sdn_of_dmy dmy in
+      [ (None, Some sdn2) ]
+  | After ->
+      let sdn1, _sdn2 = sdn_of_dmy dmy in
+      [ (Some sdn1, None) ]
+  | OrYear dmy2 ->
+      let sdn11, sdn12 = sdn_of_dmy dmy in
+      let sdn21, sdn22 = sdn_of_dmy (Date.dmy_of_dmy2 dmy2) in
+      [ (Some sdn11, Some sdn12); (Some sdn21, Some sdn22) ]
+  | YearInt dmy2 ->
+      let sdn11, _sdn12 = sdn_of_dmy dmy in
+      let _sdn21, sdn22 = sdn_of_dmy (Date.dmy_of_dmy2 dmy2) in
+      [ (Some sdn11, Some sdn22) ]
+
+(** [compatible_sdn i1 i2]
+    Checks if two intervals `i1` and `i2` (as described for `dmy_to_sdn_range_l`)
+    are compatible, i.e. if i2 is a sub interval of i1. *)
+let compatible_sdn (sdn11, sdn12) (sdn21, sdn22) =
+  if (sdn21, sdn22) = (None, None) then true
+  else
+    (* S: Add unit argument to bool2 to make good use of OCaml laziness  *)
+    let bool1 =
+      match (sdn11, sdn21) with
+      | Some sdn1, Some sdn2 -> sdn1 <= sdn2
+      | None, _ -> true
+      | Some _, None -> false
+    in
+    let bool2 =
+      match (sdn12, sdn22) with
+      | Some sdn1, Some sdn2 -> sdn1 >= sdn2
+      | None, _ -> true
+      | Some _, None -> false
+    in
+    bool1 && bool2
+
+(** [compatible_sdn_l l i]
+    Checks if there exists an interval in `l` that is compatible with `i` *)
+let compatible_sdn_l sdn1_l sdn2 =
+  (* S: replace by List.exists *)
+  List.fold_left (fun r sdn1 -> r || compatible_sdn sdn1 sdn2) false sdn1_l
+
+(** [compatible_sdn_l l1 l2]
+    Checks if for all intervals `i2` in `l2`, there exists an interval `i1` in
+    `l1` such that `i1` is compatible with `i2` *)
+let compatible_sdn_ll sdn1_l sdn2_l =
+  List.fold_left (fun r sdn2 -> r && compatible_sdn_l sdn1_l sdn2) true sdn2_l
+
+(** [compatible_dmys d1 d2]
+    Checks if `d1` is compatible with `d2`, i.e. if despite a potential lack
+    of precision in the dates, d2 is more precise than d1. *)
+let compatible_dmys dmy1 dmy2 =
+  compatible_sdn_ll (dmy_to_sdn_range_l dmy1) (dmy_to_sdn_range_l dmy2)
+
+(** [compatible_dates date1 date2]
+    Same than before, but also checks the kind of date (Dgreg or Dtext)
+    and, in the first case, if calendars are compatible. *)
+let compatible_dates date1 date2 =
+  let compatible_cals cal1 cal2 =
+    match (cal1, cal2) with
+    | Dgregorian, Djulian | Dgregorian, Dfrench -> true
+    | _ -> cal1 = cal2
+  in
+  if date1 = date2 then true
+  else
+    match (date1, date2) with
+    | Dgreg (dmy1, cal1), Dgreg (dmy2, cal2) ->
+        compatible_dmys dmy1 dmy2 && compatible_cals cal1 cal2
+    | Dgreg (_, _), Dtext _ -> false
+    | Dtext _, _ -> true
+
+(** Same than before, but for Adef.ctype. *)
+let compatible_cdates cdate1 cdate2 =
+  let od1 = Date.od_of_cdate cdate1 in
+  let od2 = Date.od_of_cdate cdate2 in
+  match (od1, od2) with
+  | Some date1, Some date2 -> compatible_dates date1 date2
+  | Some _, None -> false
+  | None, _ -> true
+
+(** Checks if birth between two persons are compatible, i.e. if their birth date
+    (baptism date if birth date not provided) and place are compatible, and
+    returns a list of messages.
+    If birth is not provided, checks bathism date instead.
+    If birth/bathism date are not compatible, the returned list will have MsgBirthDate
+    If birth place are not compatible, the returned list will have MsgBirthPlace *)
+let compatible_birth p1 p2 =
+  let get_birth person =
+    if person.birth = Date.cdate_None then person.baptism else person.birth
+  in
+  let birth1 = get_birth p1 in
+  let birth2 = get_birth p2 in
+  let res1 = if compatible_cdates birth1 birth2 then [] else [ MsgBirthDate ] in
+  let res2 =
+    if compatible_str_field p1.birth_place p2.birth_place then []
+    else [ MsgBirthPlace ]
+  in
+  res1 @ res2
+
+(** Same than before, but for death. Messages returned are
+    MsgDeathDate and MsgDeathPlace *)
+let compatible_death p1 p2 =
+  let bool1 =
+    p1.death = p2.death
+    ||
+    match (p1.death, p2.death) with
+    | Death (_, cdate1), Death (_, cdate2) ->
+        let date1 = Date.date_of_cdate cdate1 in
+        let date2 = Date.date_of_cdate cdate2 in
+        compatible_dates date1 date2
+    | NotDead, _
+    | DeadYoung, Death (_, _)
+    | DeadDontKnowWhen, (Death (_, _) | DeadYoung | DeadDontKnowWhen)
+    | DontKnowIfDead, _ ->
+        true
+    | _ -> (* S: avoid non-exhaustive pattern matching *) false
+  in
+  let res1 = if bool1 then [] else [ MsgDeathDate ] in
+  let res2 =
+    if compatible_str_field p1.death_place p2.death_place then []
+    else [ MsgDeathPlace ]
+  in
+  res1 @ res2
+
+(** [compatible_sexes p1 p2]
+    Returns [] if `p1` and `p2` have the same sex, [MsgSex] otherwise. *)
+let compatible_sexes p1 p2 = if p1.sex = p2.sex then [] else [ MsgSex ]
+
+(** [compatible_occupations p1 p2]
+    Returns [] if `p1` and `p2` have compatible occupations, [MsgOccupation] otherwise. *)
+let compatible_occupations p1 p2 =
+  if compatible_str_field p1.occupation p2.occupation then []
+  else [ MsgOccupation ]
+
+(** Checks if two persons' names are compatible wrt. their eventual aliases and returns a
+    list of messages.
+    If first names are not compatible, the returned list will have MsgFirstName.
+    If surnames are not compatible, the returned list will have MsgSurname. *)
+let compatible_persons_ligth base1 base2 p1 p2 =
+  let fn1 = sou base1 p1.first_name in
+  let fn2 = sou base2 p2.first_name in
+  let afn2 = fn2 :: List.map (sou base2) p2.first_names_aliases in
+  let sn1 = sou base1 p1.surname in
+  let sn2 = sou base2 p2.surname in
+  let asn2 = sn2 :: List.map (sou base2) p2.surnames_aliases in
+  let res1 = if compatible_names fn1 afn2 then [] else [ MsgFirstName ] in
+  let res2 = if compatible_names sn1 asn2 then [] else [ MsgSurname ] in
+  res1 @ res2
+
+(** Checks if two persons are compatible and returns all the messages associated
+    to the compatiblity of their name, sex, birth, death and occupation. *)
+let compatible_persons base1 base2 p1 p2 =
+  compatible_persons_ligth base1 base2 p1 p2
+  @ compatible_sexes p1 p2 @ compatible_birth p1 p2 @ compatible_death p1 p2
+  @ compatible_occupations p1 p2
+
+(** [find_compatible_persons_ligth base1 base2 iper1 iper2_list]
+    Returns the sublist of persons of `iper2_list` that are compatible with
+    `iper1` (only checking names). *)
+let rec find_compatible_persons_ligth base1 base2 iper1 iper2_list =
+  (* S: not tail recursive, could be *)
+  match iper2_list with
+  | [] -> []
+  | head :: rest ->
+      let p1 = gen_person_of_person (poi base1 iper1) in
+      let p2 = gen_person_of_person (poi base2 head) in
+      let c_rest = find_compatible_persons_ligth base1 base2 iper1 rest in
+      if compatible_persons_ligth base1 base2 p1 p2 = [] then head :: c_rest
+      else c_rest
+
+(** Same than before, but with full compatibility ( name, sex, birth, death and
+    occupation) *)
+let rec find_compatible_persons base1 base2 iper1 iper2_list =
+  match iper2_list with
+  | [] -> []
+  | head :: rest ->
+      let p1 = gen_person_of_person (poi base1 iper1) in
+      let p2 = gen_person_of_person (poi base2 head) in
+      let c_rest = find_compatible_persons base1 base2 iper1 rest in
+      if compatible_persons base1 base2 p1 p2 = [] then head :: c_rest
+      else c_rest
+
+(** Checks if the spouse of the persons (whose id are in argument) are
+    compatible (only checking names) and returns the associated messages list. *)
+let compatible_unions base1 base2 iper1 iper2 ifam1 ifam2 =
+  let get_spouse base iper ifam =
+    let f = foi base ifam in
+    if iper = get_father f then poi base (get_mother f)
+    else poi base (get_father f)
+  in
+  let spouse1 = gen_person_of_person (get_spouse base1 iper1 ifam1) in
+  let spouse2 = gen_person_of_person (get_spouse base2 iper2 ifam2) in
+  compatible_persons_ligth base1 base2 spouse1 spouse2
+
+(** [find_compatible_unions base1 base2 iper1 iper2_list ifam1 ifam2_list]
+    Returns the sublist of families of `ifam2_list` whose union is compatible
+    (in the sense of `compatible_unions`). *)
+let rec find_compatible_unions base1 base2 iper1 iper2 ifam1 ifam2_list =
+  match ifam2_list with
+  | [] -> []
+  | head :: rest ->
+      let c_rest = find_compatible_unions base1 base2 iper1 iper2 ifam1 rest in
+      if compatible_unions base1 base2 iper1 iper2 ifam1 head = [] then
+        head :: c_rest
+      else c_rest
+
+(** [compatible_divorces d1 d2]
+    Returns true if divorces are compatible, i.e. if both divorced, then
+    checking date compatibility, if d1 is a divorce and d2 is not returns
+    false, otherwise returns true. *)
+let compatible_divorces d1 d2 =
+  match (d1, d2) with
+  | Divorced cdate1, Divorced cdate2 -> compatible_cdates cdate1 cdate2
+  | Divorced _, _ -> false
+  | _ -> true
+
+(** Checks the compatibility of marriages (mariage date, divorce
+    and mariage place), then print the list of messages calculated. *)
+let compatible_marriages base1 base2 ifam1 ifam2 =
+  let f1 = gen_family_of_family (foi base1 ifam1) in
+  let f2 = gen_family_of_family (foi base2 ifam2) in
+  let res1 =
+    if compatible_cdates f1.marriage f2.marriage then []
+    else [ MsgMarriageDate ]
+  in
+  let res2 =
+    if compatible_divorces f1.divorce f2.divorce then [] else [ MsgDivorce ]
+  in
+  let res3 =
+    if compatible_str_field f1.marriage_place f2.marriage_place then []
+    else [ MsgMarriagePlace ]
+  in
+  let res = res1 @ res2 @ res3 in
+  if res = [] then () else print_f_messages base1 base2 ifam1 ifam2 res
+
+(** Calculates the compatibility of two persons and prints the associated
+    messages *)
+let pdiff base1 base2 iper1 iper2 =
+  let p1 = gen_person_of_person (poi base1 iper1) in
+  let p2 = gen_person_of_person (poi base2 iper2) in
+  let res = compatible_persons base1 base2 p1 p2 in
+  if res = [] then () else print_p_messages base1 base2 iper1 iper2 res
+
+(** Calculates the compatibility of two persons' families and prints the
+    associated messages. *)
+let compatible_parents base1 base2 iper1 iper2 =
+  let a1 = get_parents (poi base1 iper1) in
+  let a2 = get_parents (poi base2 iper2) in
+  match (a1, a2) with
+  | Some ifam1, Some ifam2 ->
+      let f1 = foi base1 ifam1 in
+      let f2 = foi base2 ifam2 in
+      let _ = pdiff base1 base2 (get_father f1) (get_father f2) in
+      let _ = pdiff base1 base2 (get_mother f1) (get_mother f2) in
+      compatible_marriages base1 base2 ifam1 ifam2
+  | None, _ -> ()
+  | Some _, None ->
+      print_p_messages base1 base2 iper1 iper2 [ MsgParentsMissing ]
+
+(** Checks che compatibility of two persons and their families, and prints it.
+    This is performed recursively through their descendants *)
+let rec ddiff base1 base2 iper1 iper2 d_tab =
+  (* S: Simplify with statement:
+     let ddiff iper1 iper2 = ddiff base1 base2 iper1 iper2 d_tab *)
+  let d_check = Gwdb.Marker.get d_tab iper1 in
+  if List.mem iper2 d_check then ()
+  else
+    let _ = Gwdb.Marker.set d_tab iper1 (iper2 :: d_check) in
+    let spouse f iper =
+      if iper = get_father f then get_mother f else get_father f
+    in
+    let udiff base1 base2 iper1 iper2 ifam1 ifam2 =
+      let fd b1 b2 ip2_list ip1 =
+        match find_compatible_persons_ligth b1 b2 ip1 ip2_list with
+        | [ ip2 ] -> ddiff base1 base2 ip1 ip2 d_tab
+        | [] -> print_p_messages base1 base2 iper1 iper2 [ MsgChildMissing ip1 ]
+        | rest_list -> (
+            match find_compatible_persons b1 b2 ip1 rest_list with
+            | [ best_ip2 ] -> ddiff base1 base2 ip1 best_ip2 d_tab
+            | [] -> print_p_messages base1 base2 iper1 iper2 [ MsgBadChild ip1 ]
+            | _ -> print_p_messages base1 base2 iper1 iper2 [ MsgChildren ip1 ])
+      in
+      let f1 = foi base1 ifam1 in
+      let f2 = foi base2 ifam2 in
+      let p1 = spouse f1 iper1 in
+      let p2 = spouse f2 iper2 in
+      let d1 = Array.to_list (get_children (foi base1 ifam1)) in
+      let d2 = Array.to_list (get_children (foi base2 ifam2)) in
+      pdiff base1 base2 p1 p2;
+      List.iter (fd base1 base2 d2) d1
+    in
+    let fu b1 b2 ifam2_list ifam1 =
+      match find_compatible_unions b1 b2 iper1 iper2 ifam1 ifam2_list with
+      | [ ifam2 ] ->
+          compatible_marriages b1 b2 ifam1 ifam2;
+          compatible_parents b1 b2
+            (spouse (foi base1 ifam1) iper1)
+            (spouse (foi base2 ifam2) iper2);
+          udiff b1 b2 iper1 iper2 ifam1 ifam2
+      | [] ->
+          print_p_messages base1 base2 iper1 iper2
+            [ MsgSpouseMissing (spouse (foi base1 ifam1) iper1) ]
+      | _ ->
+          print_p_messages base1 base2 iper1 iper2
+            [ MsgSpouses (spouse (foi base1 ifam1) iper1) ]
+    in
+    let u1 = Array.to_list (get_family (poi base1 iper1)) in
+    let u2 = Array.to_list (get_family (poi base2 iper2)) in
+    pdiff base1 base2 iper1 iper2;
+    List.iter (fu base1 base2 u2) u1
+
+(** Returns the eldest persons on the base starting from the persons in argument. *)
+let rec find_top base1 base2 iper1 iper2 =
+  let p1 = gen_person_of_person (poi base1 iper1) in
+  let p2 = gen_person_of_person (poi base2 iper2) in
+  if compatible_persons_ligth base1 base2 p1 p2 = [] then
+    let a1 = get_parents (poi base1 iper1) in
+    let a2 = get_parents (poi base2 iper2) in
+    match (a1, a2) with
+    | Some ifam1, Some ifam2 ->
+        let f1 = foi base1 ifam1 in
+        let f2 = foi base2 ifam2 in
+        let f_top_list = find_top base1 base2 (get_father f1) (get_father f2) in
+        let m_top_list = find_top base1 base2 (get_mother f1) (get_mother f2) in
+        f_top_list @ m_top_list
+    | _ -> [ (iper1, iper2) ]
+  else (
+    Printf.printf " Warning: %s doesn't match %s%s"
+      (person_link !in_file1 base1 iper1 "base1")
+      (person_link !in_file2 base2 iper2 "base2")
+      !cr;
+    [])
+
+(** Same than ddiff, but starting from the eldest ancestors from the persons in argument *)
+let addiff base1 base2 iper1 iper2 d_tab =
+  let topdiff (iper1, iper2) =
+    Printf.printf "==> %s / %s%s"
+      (person_link !in_file1 base1 iper1 "base1")
+      (person_link !in_file2 base2 iper2 "base2")
+      !cr;
+    ddiff base1 base2 iper1 iper2 d_tab
+  in
+  Printf.printf "Building top list...%s" !cr;
+  let top_list = find_top base1 base2 iper1 iper2 in
+  Printf.printf "Top list built.%s" !cr;
+  List.iter topdiff top_list
+
+(* Main *)
+
+let gwdiff base1 base2 iper1 iper2 d_mode ad_mode =
+  let desc_tab = Gwdb.iper_marker (Gwdb.ipers base1) [] in
+  match (d_mode, ad_mode) with
+  | true, _ | false, false -> ddiff base1 base2 iper1 iper2 desc_tab
+  | false, true -> addiff base1 base2 iper1 iper2 desc_tab
+
+let p1_fn = ref ""
+let p1_occ = ref 0
+let p1_sn = ref ""
+let p2_fn = ref ""
+let p2_occ = ref 0
+let p2_sn = ref ""
+
+type arg_state = ASnone | ASwaitP1occ | ASwaitP1sn | ASwaitP2occ | ASwaitP2sn
+
+let arg_state = ref ASnone
+let mem = ref false
+let d_mode = ref false
+let ad_mode = ref false
+
+let speclist =
+  [
+    ( "-1",
+      Arg.String
+        (fun s ->
+          p1_fn := s;
+          arg_state := ASwaitP1occ),
+      "<fn> <occ> <sn> : (mandatory) defines starting person in base1" );
+    ( "-2",
+      Arg.String
+        (fun s ->
+          p2_fn := s;
+          arg_state := ASwaitP2occ),
+      "<fn> <occ> <sn> : (mandatory) defines starting person in base2" );
+    ("-ad", Arg.Set ad_mode, ": checks descendants of all ascendants ");
+    ("-d", Arg.Set d_mode, ": checks descendants (default)");
+    ( "-html",
+      Arg.String
+        (fun s ->
+          html := true;
+          root := s),
+      "<root>: HTML format used for report" );
+    ("-mem", Arg.Set mem, ": save memory space, but slower");
+  ]
+
+let anonfun s =
+  match !arg_state with
+  | ASnone ->
+      if !in_file1 = "" then in_file1 := s
+      else if !in_file2 = "" then in_file2 := s
+      else raise (Arg.Bad "Too much arguments")
+  | ASwaitP1occ -> (
+      try
+        p1_occ := int_of_string s;
+        arg_state := ASwaitP1sn
+      with Failure _ -> raise (Arg.Bad "Numeric value for occ (-1)!"))
+  | ASwaitP1sn ->
+      p1_sn := s;
+      arg_state := ASnone
+  | ASwaitP2occ -> (
+      try
+        p2_occ := int_of_string s;
+        arg_state := ASwaitP2sn
+      with Failure _ -> raise (Arg.Bad "Numeric value for occ (-2)!"))
+  | ASwaitP2sn ->
+      p2_sn := s;
+      arg_state := ASnone
+
+let errmsg = "Usage: " ^ Sys.argv.(0) ^ " [options] base1 base2\nOptions are: "
+
+let check_args () =
+  Arg.parse speclist anonfun errmsg;
+  if !in_file1 = "" then (
+    Printf.printf "Missing reference data base\n";
+    Printf.printf "Use option -help for usage\n";
+    flush stdout;
+    exit 2);
+  if !in_file2 = "" then (
+    Printf.printf "Missing destination data base\n";
+    Printf.printf "Use option -help for usage\n";
+    flush stdout;
+    exit 2);
+  if !p1_fn = "" then (
+    Printf.printf "-1 parameter is mandatory\n";
+    Printf.printf "Use option -help for usage\n";
+    flush stdout;
+    exit 2);
+  if !p1_sn = "" then (
+    Printf.printf "Incomplete -1 parameter\n";
+    Printf.printf "Use option -help for usage\n";
+    flush stdout;
+    exit 2);
+  if !p2_fn = "" then (
+    Printf.printf "-2 parameter is mandatory\n";
+    Printf.printf "Use option -help for usage\n";
+    flush stdout;
+    exit 2);
+  if !p2_sn = "" then (
+    Printf.printf "Incomplete -2 parameter\n";
+    Printf.printf "Use option -help for usage\n";
+    flush stdout;
+    exit 2)
+
+let main () =
+  let _ = check_args () in
+  let _ = if not !html then cr := "\n" else cr := "<BR>\n" in
+  let load_base file =
+    let base = open_base file in
+    let () = load_ascends_array base in
+    let () = load_strings_array base in
+    let () =
+      if not !mem then
+        let () = load_unions_array base in
+        let () = load_couples_array base in
+        let () = load_descends_array base in
+        ()
+    in
+    base
+  in
+  (* Reference base *)
+  let base1 = load_base !in_file1 in
+  (* Destination base *)
+  let base2 = if !in_file1 != !in_file2 then load_base !in_file2 else base1 in
+  let iper1 = person_of_key base1 !p1_fn !p1_sn !p1_occ in
+  let iper2 = person_of_key base2 !p2_fn !p2_sn !p2_occ in
+  if !html then Printf.printf "<BODY>\n";
+  (match (iper1, iper2) with
+  | None, _ ->
+      Printf.printf "Cannot find person %s.%d %s in reference base" !p1_fn
+        !p1_occ !p1_sn
+  | _, None ->
+      Printf.printf "Cannot find person %s.%d %s in destination base" !p2_fn
+        !p2_occ !p2_sn
+  | Some iper1, Some iper2 -> gwdiff base1 base2 iper1 iper2 !d_mode !ad_mode);
+  if !html then Printf.printf "</BODY>\n"
+
+let _ = Printexc.print main ()

bin/gwexport/dune

@@ -0,0 +1,6 @@
+(library
+ (name gwexport_lib)
+ (public_name geneweb.gwexport_lib)
+ (wrapped false)
+ (libraries geneweb)
+ (modules gwexport))

bin/gwexport/gwexport.ml

@@ -0,0 +1,456 @@
+open Geneweb
+open Gwdb
+
+type gwexport_charset = Ansel | Ansi | Ascii | Utf8
+
+type gwexport_opts = {
+  asc : int option;
+  ascdesc : int option;
+  base : (string * base) option;
+  censor : int;
+  charset : gwexport_charset;
+  desc : int option;
+  img_base_path : string;
+  keys : string list;
+  mem : bool;
+  no_notes : [ `none | `nn | `nnn ];
+  no_picture : bool;
+  oc : string * (string -> unit) * (unit -> unit);
+  parentship : bool;
+  picture_path : bool;
+  source : string option;
+  surnames : string list;
+  verbose : bool;
+}
+
+let default_opts =
+  {
+    asc = None;
+    ascdesc = None;
+    base = None;
+    censor = 0;
+    charset = Utf8;
+    desc = None;
+    img_base_path = "";
+    keys = [];
+    mem = false;
+    no_notes = `none;
+    no_picture = false;
+    oc = ("", prerr_string, fun () -> close_out stderr);
+    parentship = false;
+    picture_path = false;
+    source = None;
+    surnames = [];
+    verbose = false;
+  }
+
+let errmsg = "Usage: " ^ Sys.argv.(0) ^ " <BASE> [OPT]"
+
+let anonfun c s =
+  if !c.base = None then (
+    Secure.set_base_dir (Filename.dirname s);
+    c := { !c with base = Some (s, Gwdb.open_base s) })
+  else raise (Arg.Bad "Cannot treat several databases")
+
+let speclist c =
+  [
+    ( "-a",
+      Arg.Int (fun s -> c := { !c with asc = Some s }),
+      "<N> maximum generation of the root's ascendants" );
+    ( "-ad",
+      Arg.Int (fun s -> c := { !c with ascdesc = Some s }),
+      "<N> maximum generation of the root's ascendants descendants" );
+    ( "-key",
+      Arg.String (fun s -> c := { !c with keys = s :: !c.keys }),
+      "<KEY> key reference of root person. Used for -a/-d options. Can be used \
+       multiple times. Key format is \"First Name.occ SURNAME\"" );
+    ( "-c",
+      Arg.Int (fun s -> c := { !c with censor = s }),
+      "<NUM>: when a person is born less than <num> years ago, it is not \
+       exported unless it is Public. All the spouses and descendants are also \
+       censored." );
+    ( "-charset",
+      Arg.String
+        (fun s ->
+          c :=
+            {
+              !c with
+              charset =
+                (match s with
+                | "ASCII" -> Ascii
+                | "ANSEL" -> Ansel
+                | "ANSI" -> Ansi
+                | "UTF-8" -> Utf8
+                | _ -> raise (Arg.Bad "bad -charset value"));
+            }),
+      "[ASCII|ANSEL|ANSI|UTF-8] set charset; default is UTF-8" );
+    ( "-d",
+      Arg.Int (fun s -> c := { !c with desc = Some s }),
+      "<N> maximum generation of the root's descendants." );
+    ( "-mem",
+      Arg.Unit (fun () -> c := { !c with mem = true }),
+      " save memory space, but slower." );
+    ( "-nn",
+      Arg.Unit
+        (fun () -> if !c.no_notes = `none then c := { !c with no_notes = `nn }),
+      " no (database) notes." );
+    ( "-nnn",
+      Arg.Unit (fun () -> c := { !c with no_notes = `nnn }),
+      " no notes (implies -nn)." );
+    ( "-nopicture",
+      Arg.Unit (fun () -> c := { !c with no_picture = true }),
+      " don't extract individual picture." );
+    ( "-o",
+      Arg.String
+        (fun s ->
+          let oc = open_out s in
+          c := { !c with oc = (s, output_string oc, fun () -> close_out oc) }),
+      "<GED> output file name (default: stdout)." );
+    ( "-parentship",
+      Arg.Unit (fun () -> c := { !c with parentship = true }),
+      " select individuals involved in parentship computation between pairs of \
+       keys. Pairs must be defined with -key option, descendant first: e.g. \
+       -key \"Descendant.0 SURNAME\" -key \"Ancestor.0 SURNAME\". If multiple \
+       pair are provided, union of persons are returned." );
+    ( "-picture-path",
+      Arg.Unit (fun () -> c := { !c with picture_path = true }),
+      " extract pictures path." );
+    ( "-s",
+      Arg.String (fun x -> c := { !c with surnames = x :: !c.surnames }),
+      "<SN> select this surname (option usable several times, union of \
+       surnames will be used)." );
+    ( "-source",
+      Arg.String (fun x -> c := { !c with source = Some x }),
+      "<SRC> replace individuals and families sources. Also delete event \
+       sources." );
+    ("-v", Arg.Unit (fun () -> c := { !c with verbose = true }), " verbose");
+  ]
+
+module IPS = Util.IperSet
+module IFS = Util.IfamSet
+
+(* S: Does it mean private persons whose birth year is before 'max_year'
+   are uncensored? *)
+
+(** [is_censored_person max_year person_name]
+    Returns [true] iff the person has a birth date that is after max_year and
+    its visibility is not public
+*)
+let is_censored_person threshold p =
+  match Date.cdate_to_dmy_opt (get_birth p) with
+  | None -> false
+  | Some dmy -> dmy.Adef.year >= threshold && get_access p != Def.Public
+
+(** [is_censored_couple base max_year family]
+    Returns [true] if either the father or the mother of a given family in the
+    base is censored
+*)
+let is_censored_couple base threshold cpl =
+  (is_censored_person threshold @@ poi base (get_father cpl))
+  || (is_censored_person threshold @@ poi base (get_mother cpl))
+
+(* The following functions are utils set people as "censored" by marking them.
+   Censoring a person consists in setting a mark defined as:
+   `Marker.get pmark p lor flag`
+
+   This gets the current mark, being 0 or 1, and `lor`s it with `flag` which is `1`.
+   TODO: replace integer markers by booleans
+*)
+
+(** Marks a censored person *)
+let censor_person base pmark flag threshold p no_check =
+  let ps = poi base p in
+  if no_check || is_censored_person threshold ps then
+    Marker.set pmark p (Marker.get pmark p lor flag)
+
+(** Marks all the members of a family that are censored.
+    If a couple is censored, its parents and all its descendants are marked.
+*)
+let rec censor_family base pmark fmark flag threshold i no_check =
+  let censor_unions p =
+    let uni = poi base p in
+    Array.iter
+      (fun ifam ->
+        censor_family base pmark fmark flag threshold ifam true;
+        censor_person base pmark flag threshold p true)
+      (get_family uni)
+  in
+  let censor_descendants f =
+    let des = foi base f in
+    Array.iter
+      (fun iper -> if Marker.get pmark iper = 0 then censor_unions iper)
+      (get_children des)
+  in
+  let all_families_censored p =
+    (* FIXME: replace with forall *)
+    let uni = poi base p in
+    Array.fold_left
+      (fun check ifam -> check && Marker.get fmark ifam = 0)
+      true (get_family uni)
+  in
+  let censor_spouse iper =
+    if all_families_censored iper then
+      Marker.set pmark iper (Marker.get pmark iper lor flag)
+    (* S: Replace this line by `censor_person`? *)
+  in
+  if Marker.get fmark i = 0 then
+    let fam = foi base i in
+    if no_check || is_censored_couple base threshold fam then (
+      Marker.set fmark i (Marker.get fmark i lor flag);
+      censor_spouse (get_father fam);
+      censor_spouse (get_mother fam);
+      censor_descendants i)
+
+(** Marks all the families that are censored in the given base. *)
+let censor_base base pmark fmark flag threshold =
+  Collection.iter
+    (fun i -> censor_family base pmark fmark flag threshold i false)
+    (ifams base);
+  Collection.iter
+    (fun i -> censor_person base pmark flag threshold i false)
+    (ipers base)
+
+(** Set non visible persons and families as censored *)
+let restrict_base base per_tab fam_tab flag =
+  (* Starts by censoring non visible persons of the base *)
+  Collection.iter
+    (fun i ->
+      if base_visible_get base (fun _ -> false) i then
+        Marker.set per_tab i (Marker.get per_tab i lor flag))
+      (* S: replace by `censor_person` ? *)
+    (ipers base);
+
+  Collection.iter
+    (fun i ->
+      let fam = foi base i in
+      let des_visible =
+        (* There exists a children of the family that is not censored *)
+        (* FIXME: replace with exists *)
+        Array.fold_left
+          (fun check iper -> check || Marker.get per_tab iper = 0)
+          false (get_children fam)
+      in
+      let cpl_not_visible =
+        (* Father or mother is censored *)
+        Marker.get per_tab (get_father fam) <> 0
+        || Marker.get per_tab (get_mother fam) <> 0
+      in
+      (* If all the children, father and mother are censored, then censor family *)
+      if (not des_visible) && cpl_not_visible then
+        Marker.set fam_tab i (Marker.get fam_tab i lor flag))
+    (ifams base)
+
+(** [select_asc conf base max_gen ips]
+    Returns all the ancestors of persons in the list `ips` up to the `max_gen`
+    generation. *)
+let select_asc conf base max_gen ips =
+  let rec loop_asc (gen : int) set ip =
+    if not @@ IPS.mem ip set then
+      let set = IPS.add ip set in
+      let p = Util.pget conf base ip in
+      if gen < max_gen then
+        match get_parents p with
+        | Some ifam ->
+            let cpl = foi base ifam in
+            let set = loop_asc (gen + 1) set (get_father cpl) in
+            loop_asc (gen + 1) set (get_mother cpl)
+        | _ -> set
+      else set
+    else set
+  in
+  List.fold_left (loop_asc 0) IPS.empty ips
+
+(* S: only used by `select_surnames` in a List.iter *)
+(* Should it use search engine functions? *)
+
+(** [select_surname nase pmark fmark surname]
+    Sets a `true` marker to families whose mother or father that
+    match the given surname. Propagates the mark to children
+    that have this surname.
+*)
+let select_surname base pmark fmark surname =
+  let surname = Name.strip_lower surname in
+  Collection.iter
+    (fun i ->
+      let fam = foi base i in
+      let fath = poi base (get_father fam) in
+      let moth = poi base (get_mother fam) in
+      if
+        Name.strip_lower (sou base (get_surname fath)) = surname
+        || Name.strip_lower (sou base (get_surname moth)) = surname
+      then (
+        Marker.set fmark i true;
+        Marker.set pmark (get_father fam) true;
+        Marker.set pmark (get_mother fam) true;
+        Array.iter
+          (fun ic ->
+            let p = poi base ic in
+            if
+              (not (Marker.get pmark ic))
+              && Name.strip_lower (sou base (get_surname p)) = surname
+            then Marker.set pmark ic true)
+          (get_children fam)))
+    (ifams base)
+
+(** [select_surnames base surnames]
+    Calls `select_surname` on every family that have the given surnames.
+    Returns two functions:
+    * the first takes a person and returns `true` iff it has been selected
+    * the second takes a family and returns `false` iff it has been selected
+*)
+let select_surnames base surnames : (iper -> bool) * (ifam -> bool) =
+  let pmark = Gwdb.iper_marker (Gwdb.ipers base) false in
+  let fmark = Gwdb.ifam_marker (Gwdb.ifams base) false in
+  List.iter (select_surname base pmark fmark) surnames;
+  ((fun i -> Gwdb.Marker.get pmark i), fun i -> Gwdb.Marker.get fmark i)
+
+(**/**)
+
+(** [select_parentship base ip1 ip2]
+    Returns the set of common descendants of ip1 and the
+    ancestors of ip2 and the set of their families. *)
+let select_parentship base ip1 ip2 =
+  let conf = Config.{ empty with wizard = true; bname = Gwdb.bname base } in
+  let asc = select_asc conf base max_int [ ip1 ] in
+  let desc = Util.select_desc conf base (-max_int) [ (ip2, 0) ] in
+  let ipers =
+    (* S: The intersection of asc and desc *)
+    if IPS.cardinal asc > Hashtbl.length desc then
+      Hashtbl.fold
+        (fun k _ acc -> if IPS.mem k asc then IPS.add k acc else acc)
+        desc IPS.empty
+    else
+      IPS.fold
+        (fun k acc -> if Hashtbl.mem desc k then IPS.add k acc else acc)
+        asc IPS.empty
+  in
+  let ifams =
+    (* S: families  *)
+    IPS.fold
+      (fun iper acc ->
+        Array.fold_left
+          (fun acc ifam ->
+            if
+              IFS.mem ifam acc (* S: useless test? *)
+              || not (IPS.mem (Gutil.spouse iper @@ foi base ifam) ipers)
+              (* S: is the partner of the
+                 person not in ipers? *)
+            then acc
+            else IFS.add ifam acc)
+          acc
+          (get_family (poi base iper)))
+      ipers IFS.empty
+  in
+  (ipers, ifams)
+
+(** [select_from_set ipers ifams]
+    Returns two functions :
+    * the first returns true if its input is in ipers
+    * the second returns true if its input is in ifams
+*)
+let select_from_set (ipers : IPS.t) (ifams : IFS.t) =
+  let sel_per i = IPS.mem i ipers in
+  let sel_fam i = IFS.mem i ifams in
+  (sel_per, sel_fam)
+
+(** [select opts ips]
+    Return filters for [iper] and [ifam] to be used when exporting
+    a (portion of a) base.
+*)
+let select opts ips =
+  match opts.base with
+  | None -> raise (Arg.Bad "Missing base name. Use option -help for usage")
+  | Some (_, base) ->
+      let ips =
+        List.rev_append ips
+        @@ Mutil.filter_map (Gutil.person_of_string_key base) opts.keys
+      in
+      let not_censor_p, not_censor_f =
+        if opts.censor <> 0 then (
+          let pmark = iper_marker (ipers base) 0 in
+          let fmark = ifam_marker (ifams base) 0 in
+          (if opts.censor = -1 then restrict_base base pmark fmark 1
+          else
+            let tm = Unix.localtime (Unix.time ()) in
+            let threshold = 1900 + tm.Unix.tm_year - opts.censor in
+            censor_base base pmark fmark 1 threshold);
+          ((fun i -> Marker.get pmark i = 0), fun i -> Marker.get fmark i = 0))
+        else ((fun _ -> true), fun _ -> true)
+      in
+      let conf = Config.{ empty with wizard = true } in
+      let sel_per, sel_fam =
+        (* S: a lot of redundant tests are done here, would be simpler with
+           pattern matchings and factorization. *)
+        if opts.ascdesc <> None || opts.desc <> None then (
+          assert (opts.censor = 0);
+          let asc =
+            if opts.ascdesc <> None then Option.value ~default:max_int opts.asc
+            else Option.value ~default:0 opts.asc
+          in
+          let desc = -Option.value ~default:0 opts.desc in
+          let ht =
+            match opts.ascdesc with
+            | Some ascdesc ->
+                let ips = List.map (fun i -> (i, asc)) ips in
+                Util.select_mascdesc conf base ips ascdesc
+            | None ->
+                let ht = Hashtbl.create 0 in
+                IPS.iter
+                  (fun i -> Hashtbl.add ht i (poi base i))
+                  (select_asc conf base asc ips);
+                ht
+          in
+          let ht' =
+            let ips = List.map (fun i -> (i, 0)) ips in
+            Util.select_desc conf base desc ips
+          in
+          Hashtbl.iter (fun i p -> Hashtbl.replace ht i p) ht';
+          let ipers =
+            Hashtbl.fold (fun i _ ipers -> IPS.add i ipers) ht IPS.empty
+          in
+          let ifams =
+            IPS.fold
+              (fun iper acc ->
+                Array.fold_left
+                  (fun acc ifam ->
+                    if
+                      IFS.mem ifam acc
+                      || not
+                           (IPS.mem (Gutil.spouse iper @@ foi base ifam) ipers)
+                    then acc
+                    else IFS.add ifam acc)
+                  acc
+                  (get_family (poi base iper)))
+              ipers IFS.empty
+          in
+          let sel_per i = IPS.mem i ipers in
+          let sel_fam i = IFS.mem i ifams in
+          (sel_per, sel_fam))
+        else
+          match opts.asc with
+          (* opts.ascdesc = None && opts.desc = None *)
+          | Some asc ->
+              let ipers = select_asc conf base asc ips in
+              let per_sel i = IPS.mem i ipers in
+              let fam_sel i =
+                let f = foi base i in
+                per_sel (get_father f) && per_sel (get_mother f)
+              in
+              (per_sel, fam_sel)
+          | None ->
+              if opts.surnames <> [] then select_surnames base opts.surnames
+              else if opts.parentship then
+                let rec loop ipers ifams = function
+                  | [] -> select_from_set ipers ifams
+                  | k2 :: k1 :: tl ->
+                      let ipers', ifams' = select_parentship base k1 k2 in
+                      let ipers = IPS.fold IPS.add ipers ipers' in
+                      let ifams = IFS.fold IFS.add ifams ifams' in
+                      loop ipers ifams tl
+                  | _ -> assert false
+                in
+                loop IPS.empty IFS.empty ips
+              else ((fun _ -> true), fun _ -> true)
+      in
+      ( (fun i -> not_censor_p i && sel_per i),
+        fun i -> not_censor_f i && sel_fam i )

bin/gwexport/gwexport.mli

@@ -0,0 +1,55 @@
+type gwexport_charset = Ansel | Ansi | Ascii | Utf8
+
+type gwexport_opts = {
+  asc : int option; (* Maximum generation of the root's ascendants *)
+  ascdesc : int option;
+      (* Maximum generation of the root's ascendants descendants *)
+  base : (string * Gwdb.base) option; (* The base analyzed *)
+  censor : int; (* Censors the base for 'n' years *)
+  charset : gwexport_charset; (* The charset of the export *)
+  desc : int option; (* Maximum generation of the root's descendants *)
+  img_base_path : string; (* Unused by this module (and not set by options) *)
+  keys : string list; (* Key reference of additional persons to select *)
+  mem : bool; (* Unused by this module *)
+  no_notes : [ `nn | `nnn | `none ];
+      (* Unused by this module
+         S: Consider simple ADTs *)
+  no_picture : bool; (* Unused by this module *)
+  oc : string * (string -> unit) * (unit -> unit); (* Unused by this module *)
+  parentship : bool;
+      (* If asc, ascdesc and desc are not set & parenting = true, then
+         select individuals involved in parentship between pair of keys
+         (/!\ assumes the input are pairs of keys) *)
+  picture_path : bool; (* Unused by this module *)
+  source : string option; (* Unused by this module *)
+  surnames : string list; (* Used to select persons by their surname *)
+  verbose : bool; (* Unused by this module *)
+}
+
+val default_opts : gwexport_opts
+(** Default set of options *)
+
+val speclist : gwexport_opts ref -> (Arg.key * Arg.spec * Arg.doc) list
+(** Given a set of options, returns default command line arguments for selecting
+    elements from a base. The output of this function is the first input of
+    Arg.parse.
+*)
+(* Used for gwd2ged and gwu. *)
+
+val anonfun : gwexport_opts ref -> Arg.anon_fun
+(** [anonfun opts = fun base_name -> ...]
+    Given a set of options `opts` where `!opts.base` is uninitialized,
+    opens the dir `base_name` and initializes !opts.base with the base name.
+    The output of this function is the second argument of Arg.parse.
+*)
+(* Arg.anon_fun = string -> unit *)
+
+val errmsg : Arg.usage_msg
+(** Default error message.
+    This is the third argument of Arg.parse. *)
+
+val select :
+  gwexport_opts -> Gwdb.iper list -> (Gwdb.iper -> bool) * (Gwdb.ifam -> bool)
+(** [select opts ips]
+    Return filters for [iper] and [ifam] to be used when exporting a (portion of a) base.
+*)

bin/gwgc/dune.in

@@ -0,0 +1,9 @@
+#ifdef GENEWEB_GWDB_LEGACY
+(executable
+  (name gwgc)
+  (public_name geneweb.gwgc)
+  (modules gwgc)
+  (preprocess (action (run %{bin:cppo} %%%CPPO_D%%% %{input-file})))
+  (libraries unix str %%%GWDB_PKG%%% %%%SOSA_PKG%%% geneweb)
+)
+#endif

bin/gwgc/gwgc.ml

@@ -0,0 +1,27 @@
+let dry_run = ref false
+let bname = ref ""
+
+let speclist =
+  [ ("--dry-run", Arg.Set dry_run, " do not commit changes (only print)") ]
+
+let anonfun i = bname := i
+let usage = "Usage: " ^ Sys.argv.(0) ^ " [OPTION] base"
+
+let () =
+  Arg.parse speclist anonfun usage;
+  let bname =
+    match !bname with
+    | "" ->
+        Arg.usage speclist usage;
+        exit 1
+    | s -> s
+  in
+  let dry_run = !dry_run in
+  Secure.set_base_dir (Filename.dirname bname);
+  Lock.control (Mutil.lock_file bname) true ~onerror:Lock.print_try_again
+  @@ fun () ->
+  let base = Database.opendb bname in
+  let p, f, s = Gwdb_gc.gc ~dry_run base in
+  Printf.printf
+    "%s:\n\tnb of persons: %d\n\tnb of families: %d\n\tnb of strings: %d\n"
+    bname (List.length p) (List.length f) (List.length s)

bin/gwrepl/data.mli

@@ -0,0 +1,12 @@
+(* the array of etc/lib/XXX where XXX are either dependencies of geneweb or
+   geneweb/COMPONENT *)
+val directories : string array
+
+(* associations between file names and their (generated) contents: *)
+val cmas : (string * string) array (* .cma *)
+val cmis : (string * string) array (* .cmi *)
+val shared : (string * string) array (* .so  *)
+
+(* An md5 of all the names of the files in [cmis] and [cmas] (not
+   their contents). *)
+val md5 : string

bin/gwrepl/dune.in

@@ -0,0 +1,43 @@
+(library
+  (name gwrepl_deps)
+  (flags -linkall)
+  (libraries
+    stdlib
+    str
+    unix
+    geneweb_core
+    geneweb_def
+    geneweb_util
+    geneweb_gwdb
+    %%%GWDB_PKG%%%
+    %%%SOSA_PKG%%%
+  )
+  (modules)
+)
+
+(rule
+  (target data.cppo.ml)
+  (deps .depend (:maker mk_data.ml))
+  (action (with-stdout-to %{target} (run ocaml %{maker})))
+)
+
+(rule
+  (target data.ml)
+  (deps data.cppo.ml)
+  (action (run %{bin:cppo} %%%CPPO_D%%% %{deps} -o %{target}))
+)
+
+(executable
+ (name gwrepl)
+ (public_name gwrepl)
+ (link_flags -linkall -custom)
+ (libraries compiler-libs.toplevel unix)
+ (preprocess
+  (per_module
+   ((action (run %{bin:cppo} %%%CPPO_D%%% %{input-file})) gwrepl_exe)
+   ((pps ppx_blob) data)
+  )
+ )
+ (modes byte object)
+ (modules gwrepl data)
+)

bin/gwrepl/gwrepl.ml

@@ -0,0 +1,62 @@
+let root = Filename.concat (Filename.get_temp_dir_name ()) ("gwrepl." ^ Data.md5)
+let path = Filename.concat root
+
+let mkdir_p ~verbose x =
+  if verbose then print_string ("mkdir: " ^ x ^ "...");
+  let rec loop x =
+    let y = Filename.dirname x in
+    if y <> x && String.length y < String.length x then loop y;
+    try Unix.mkdir x 0o755 with Unix.Unix_error (_, _, _) -> ()
+  in
+  loop x;
+  if verbose then print_endline "OK!"
+
+let output_file ~verbose (file, contents) =
+  if verbose then print_string ("unpacking: " ^ file ^ "...");
+  let oc = open_out_bin (path file) in
+  output_string oc contents;
+  close_out oc;
+  if verbose then print_endline "OK!"
+
+let unpack ~force_unpack ~verbose =
+  if force_unpack || not (Sys.file_exists root) then (
+    Array.iter (fun dir -> mkdir_p ~verbose (path dir)) Data.directories;
+    Array.iter (output_file ~verbose) Data.cmas;
+    Array.iter (output_file ~verbose) Data.cmis;
+    Array.iter (output_file ~verbose) Data.shared)
+
+let run ~ppf ~verbose ~noprompt =
+  Clflags.noversion := true;
+  Clflags.noinit := true;
+  if Array.length Sys.argv <> 1 || noprompt then Clflags.noprompt := true;
+  Array.iter
+    (fun dir ->
+      if verbose then print_endline ("directory: " ^ dir);
+      path dir |> Topdirs.dir_directory)
+    Data.directories;
+  Array.iter
+    (fun (file, _) ->
+      if verbose then print_endline ("load: " ^ file);
+      path file |> Topdirs.dir_load ppf)
+    Data.cmas;
+  Toploop.loop ppf
+
+(** For script execution, run:
+      cat <script.ml> | [ GWREPL_PPF=/dev/null ] [ GWREPL_VERBOSE=1 ] [ GWREPL_FORCE_UNPACK=1 ] [ GWREPL_NOPROMPT=1 ] gwrepl.exe [scrip_arg1] ...
+    For interactive toplevel, run:
+      gwrepl.exe *)
+let () =
+  let ppf =
+    match Sys.getenv_opt "GWREPL_PPF" with
+    | None | Some ("STD" | "std") -> Format.std_formatter
+    | Some ("ERR" | "err") -> Format.err_formatter
+    | Some path ->
+        let oc = open_out path in
+        Format.make_formatter (Stdlib.output_substring oc) (fun () ->
+            Stdlib.flush oc)
+  in
+  let verbose = Sys.getenv_opt "GWREPL_VERBOSE" <> None in
+  let force_unpack = Sys.getenv_opt "GWREPL_FORCE_UNPACK" <> None in
+  let noprompt = Sys.getenv_opt "GWREPL_NOPROMPT" <> None in
+  unpack ~force_unpack ~verbose;
+  run ~ppf ~verbose ~noprompt

bin/gwrepl/mk_data.ml

@@ -0,0 +1,232 @@
+(* This file is used to generate the file 'data.cppo.ml', containing all
+   the files (cmis, cmas, .so) that could be used at runtime by
+   a geneweb interpreter.
+
+   See 'data.mli' for the signature of the generated file. *)
+
+let read_lines p =
+  let rec loop () =
+    match input_line p with
+    | exception End_of_file ->
+        close_in p;
+        []
+    | line -> line :: loop ()
+  in
+  loop ()
+
+module Either = struct
+  type ('a, 'b) t = Left of 'a | Right of 'b
+end
+
+let partition_map p l =
+  let rec part left right = function
+    | [] -> (List.rev left, List.rev right)
+    | x :: l -> (
+        match p x with
+        | Some (Either.Left v) -> part (v :: left) right l
+        | Some (Either.Right v) -> part left (v :: right) l
+        | None -> part left right l)
+  in
+  part [] [] l
+
+let ( // ) = Filename.concat
+
+let if_sosa_zarith out fn =
+  Printf.fprintf out "\n#ifdef SOSA_ZARITH\n";
+  fn ();
+  Printf.fprintf out "\n#endif\n"
+
+let before_after_ocaml_version ~before ~after version =
+  (if String.compare Sys.ocaml_version version < 0 then before else after) ()
+
+let before_after_ocaml_5_1_0 ~before ~after =
+  before_after_ocaml_version "5.1.0" ~before ~after
+
+let () =
+  let opam_switch_prefix = Sys.getenv "OPAM_SWITCH_PREFIX" in
+  let opam_switch_prefix_lib = opam_switch_prefix // "lib" in
+  let ocaml_stdlib_directory =
+    let output_filename, error_filename =
+      let temporary_filename = Filename.temp_file "gwrepl_" "_ocaml_stdlib" in
+      (temporary_filename ^ ".out", temporary_filename ^ ".err")
+    in
+    let command =
+      let double_quote_if_win32 = if Sys.win32 then "\"" else "" in
+      Printf.sprintf "%sopam exec -- ocamlc -where > %s 2> %s%s"
+        double_quote_if_win32
+        (Filename.quote output_filename)
+        (Filename.quote error_filename)
+        double_quote_if_win32
+    in
+    let exit_code = Sys.command command in
+    if exit_code <> 0 then
+      failwith
+      @@ Printf.sprintf "Command '%s' failed:\nexit code: %d\nerror: %s" command
+           exit_code
+           (String.concat "\n" (read_lines @@ open_in error_filename))
+    else
+      match read_lines @@ open_in output_filename with
+      | ([] | _ :: _ :: _) as lines ->
+          failwith
+          @@ Printf.sprintf "Unexpected output of command '%s':\n%s" command
+               (String.concat "\n" lines)
+      | [ line ] -> line
+  in
+
+  let dune_root, root, (directories0, files0) =
+    let ic = open_in ".depend" in
+    let lines = read_lines ic in
+    let dune_root, out =
+      match lines with
+      | [] -> assert false
+      | dune_root :: out -> (dune_root, out)
+    in
+    let root = dune_root // "_build" // "default" // "lib" in
+    let aux fn =
+      let aux prefix =
+        if
+          String.length fn > String.length prefix
+          && String.sub fn 0 (String.length prefix) = prefix
+        then
+          Some
+            (String.sub fn (String.length prefix)
+               (String.length fn - String.length prefix))
+        else None
+      in
+      match aux opam_switch_prefix_lib with
+      | Some x -> Some (`opam (opam_switch_prefix_lib, x))
+      | None -> ( match aux root with Some x -> Some (`root x) | None -> None)
+    in
+    ( dune_root,
+      root,
+      partition_map
+        (fun s ->
+          try
+            Scanf.sscanf s {|#directory "%[^"]";;|} (fun s ->
+                match aux s with Some s -> Some (Either.Left s) | _ -> None)
+          with _ -> (
+            try
+              Scanf.sscanf s {|#load "%[^"]";;|} (fun s ->
+                  match aux s with Some s -> Some (Either.Right s) | _ -> None)
+            with _ -> failwith s))
+        out )
+  in
+
+  let directories =
+    ("etc" // "lib" // "ocaml")
+    :: ("etc" // "lib" // "ocaml" // "stublibs")
+    :: List.map
+         (function
+           | `opam (_, d) -> "etc" // "lib" // d
+           | `root d ->
+               "etc" // "lib" // "geneweb"
+               // (d |> Filename.dirname |> Filename.dirname))
+         directories0
+  in
+  let files0 =
+    `opam (Filename.dirname ocaml_stdlib_directory, "ocaml" // "stdlib.cma")
+    :: files0
+  in
+  let cmas, cmis =
+    List.fold_right
+      (fun x (cmas, cmis) ->
+        match x with
+        | `opam (prefix_directory, fn) ->
+            let aux fn = (prefix_directory // fn, "etc" // "lib" // fn) in
+            let cmas = aux fn :: cmas in
+            let ((src, _) as cmi) =
+              aux (Filename.remove_extension fn ^ ".cmi")
+            in
+            let cmis = if Sys.file_exists src then cmi :: cmis else cmis in
+            (cmas, cmis)
+        | `root fn ->
+            let cma = (root // fn, "etc" // "lib" // "geneweb" // fn) in
+            let cmas = cma :: cmas in
+            let dir =
+              dune_root // "_build" // "install" // "default" // "lib"
+              // "geneweb"
+              // Filename.(dirname fn |> basename)
+            in
+            let cmis =
+              Array.fold_left
+                (fun cmis s ->
+                  if Filename.check_suffix (Filename.concat dir s) "cmi" then
+                    ( Filename.concat dir s,
+                      "etc" // "lib" // "geneweb"
+                      // Filename.concat (Filename.basename dir) s )
+                    :: cmis
+                  else cmis)
+                cmis
+                (try Sys.readdir dir
+                 with exn ->
+                   Printf.eprintf "Error in Sys.readdir(%S)\n%!" dir;
+                   raise exn)
+            in
+            (cmas, cmis))
+      files0 ([], [])
+  in
+  let cmis =
+    let select =
+      let pref = ocaml_stdlib_directory // "stdlib__" in
+      let len = String.length pref in
+      fun s -> String.length s > len && String.sub s 0 len = pref
+    in
+    Array.fold_left
+      (fun cmis s ->
+        let fname = ocaml_stdlib_directory // s in
+        if Filename.check_suffix fname "cmi" && select fname then
+          (fname, "etc" // "lib" // "ocaml" // s) :: cmis
+        else cmis)
+      cmis
+      (Sys.readdir ocaml_stdlib_directory)
+  in
+  let data = "data.cppo.ml" in
+  let out = open_out_bin data in
+  (let print_dir d = Printf.fprintf out {|"%s";|} d in
+   Printf.fprintf out {|let directories=[||};
+   List.iter print_dir directories;
+   if_sosa_zarith out (fun () -> print_dir ("etc" // "lib" // "stublibs"));
+   Printf.fprintf out {||];;|});
+  (let aux s list =
+     Printf.fprintf out {|let %s=[||} s;
+     List.iter
+       (fun (src, dst) ->
+         Printf.fprintf out {blob|{|%s|},[%%blob {|%s|}];|blob} dst src)
+       list;
+     Printf.fprintf out {||];;|}
+   in
+   aux "cmis" cmis;
+   aux "cmas" cmas);
+  Printf.fprintf out {|let shared=[||};
+  if Sys.unix then (
+    (* FIXME: what is the windows version? *)
+    let aux (prefix_directory, s) =
+      Printf.fprintf out
+        {blob|Filename.(concat "etc" (concat "lib" {|%s|})),[%%blob {|%s|}];|blob}
+        s (prefix_directory // s)
+    in
+    List.iter aux
+      [
+        ( Filename.dirname ocaml_stdlib_directory,
+          "ocaml" // "stublibs"
+          // before_after_ocaml_5_1_0
+               ~before:(fun () -> "dllcamlstr.so")
+               ~after:(fun () -> "dllcamlstrbyt.so") );
+        ( Filename.dirname ocaml_stdlib_directory,
+          "ocaml" // "stublibs"
+          // before_after_ocaml_5_1_0
+               ~before:(fun () -> "dllunix.so")
+               ~after:(fun () -> "dllunixbyt.so") );
+      ];
+    if_sosa_zarith out (fun () ->
+        aux (opam_switch_prefix_lib, "stublibs" // "dllzarith.so")));
+  Printf.fprintf out {||];;|};
+  let b = Buffer.create 1024 in
+  let aux =
+    List.iter (fun (src, _) ->
+        Digest.file src |> Digest.to_hex |> Buffer.add_string b)
+  in
+  aux cmis;
+  aux cmas;
+  Printf.fprintf out {|let md5="%s";;|}
+    (Buffer.contents b |> Digest.string |> Digest.to_hex)

bin/gwu/dune.in

@@ -0,0 +1,14 @@
+(library
+  (name gwu_lib)
+  (public_name geneweb.gwu_lib)
+  (wrapped false)
+  (libraries geneweb gwexport_lib)
+  (modules gwuLib)
+)
+
+(executable
+  (name gwu)
+  (public_name geneweb.gwu)
+  (modules gwu)
+  (libraries geneweb gwexport_lib gwu_lib str unix %%%GWDB_PKG%%% %%%SOSA_PKG%%%)
+)

bin/gwu/gwu.ml

@@ -0,0 +1,68 @@
+open GwuLib
+
+let isolated = ref false
+
+let speclist opts =
+  ( "-odir",
+    Arg.String (fun s -> GwuLib.out_dir := s),
+    "<dir>  create files from original name in directory (else on -o file)" )
+  :: ( "-isolated",
+       Arg.Set isolated,
+       " export isolated persons (work only if export all database)." )
+  :: ( "-old_gw",
+       Arg.Set GwuLib.old_gw,
+       " do not export additional fields (for backward compatibility: < 7.00)"
+     )
+  :: ( "-raw",
+       Arg.Set GwuLib.raw_output,
+       " raw output (without possible utf-8 conversion)" )
+  :: ( "-sep",
+       Arg.String (fun s -> GwuLib.separate_list := s :: !GwuLib.separate_list),
+       "<1st_name.num surname> To use together with the option \"-odir\": \
+        separate this person and all his ancestors and descendants sharing the \
+        same surname. All the concerned families are displayed on standard \
+        output instead of their associated files. This option can be used \
+        several times." )
+  :: ( "-sep_only_file",
+       Arg.String (fun s -> GwuLib.only_file := s),
+       "<file> with option \"-sep\", tells to separate only groups of that \
+        file." )
+  :: ( "-sep_limit",
+       Arg.Int (fun i -> GwuLib.sep_limit := i),
+       "<num> When using the option \"-sep\", groups of families can become \
+        isolated in the files. Gwu reconnects them to the separated families \
+        (i.e. displays them to standard output) if the size of these groups is \
+        less than "
+       ^ string_of_int !GwuLib.sep_limit
+       ^ ". The present option changes this limit." )
+  :: Gwexport.speclist opts
+  |> Arg.align
+
+let main () =
+  let opts = ref Gwexport.default_opts in
+  Arg.parse (speclist opts) (Gwexport.anonfun opts) Gwexport.errmsg;
+  let opts = !opts in
+  match opts.Gwexport.base with
+  | None -> assert false
+  | Some (ifile, base) ->
+      let select = Gwexport.select opts [] in
+      let in_dir =
+        if Filename.check_suffix ifile ".gwb" then ifile else ifile ^ ".gwb"
+      in
+      let src_oc_ht = Hashtbl.create 1009 in
+      Gwdb.load_ascends_array base;
+      Gwdb.load_strings_array base;
+      if not opts.Gwexport.mem then (
+        Gwdb.load_couples_array base;
+        Gwdb.load_unions_array base;
+        Gwdb.load_descends_array base;
+        ());
+      let _ofile, oc, close = opts.Gwexport.oc in
+      if not !GwuLib.raw_output then oc "encoding: utf-8\n";
+      if !GwuLib.old_gw then oc "\n" else oc "gwplus\n\n";
+      GwuLib.prepare_free_occ base;
+      GwuLib.gwu opts !isolated base in_dir !out_dir src_oc_ht select;
+      Hashtbl.iter (fun _ (_, _, close) -> close ()) src_oc_ht;
+      close ()
+
+let _ = main ()

bin/gwu/gwuLib.mli

@@ -0,0 +1,21 @@
+val out_dir : string ref
+val old_gw : bool ref
+val raw_output : bool ref
+val separate_list : string list ref
+val only_file : string ref
+val sep_limit : int ref
+
+val prepare_free_occ : ?select:(Gwdb.iper -> bool) -> Gwdb.base -> unit
+(** Initializes the internal hashtables. Person whose identifier is
+    not selected (`select p = false`) are ignored. *)
+
+val gwu :
+  Gwexport.gwexport_opts ->
+  bool ->
+  Gwdb.base ->
+  string ->
+  string ->
+  (string, (string -> unit) * bool ref * (unit -> unit)) Hashtbl.t ->
+  (Gwdb.iper -> bool) * (Gwdb.ifam -> bool) ->
+  unit
+(** Prints the `.gw` file. *)

bin/setup/dune.in

@@ -0,0 +1,7 @@
+(executable
+  (name setup)
+  (public_name geneweb.setup)
+  (preprocess (action (run %{bin:cppo} %%%CPPO_D%%% %{input-file})))
+  (libraries unix str wserver %%%GWDB_PKG%%% %%%SOSA_PKG%%% geneweb)
+  (modules setup)
+)

bin/setup/intro.txt

@@ -0,0 +1,9 @@
+* Deutsche Version: "de" eingeben
+* English version: type "en"
+* Version espanola: escribir en el teclado "es"
+* Suomalainen versio: kirjoita "fi"
+* Version francaise: tapez "fr"
+* Versione italiana: digitate "it"
+* Latvie<69>u versija: type "lv"
+* Svensk version: skriv "sv"
+? 

bin/setup/lang/backg.htm

@@ -0,0 +1,45 @@
+<!DOCTYPE html>
+<html lang="%l">
+<head>
+  <!-- Copyright (c) 1998-2006 INRIA - GeneWeb -->
+  <!-- $Id: backg.htm,v 7.00 2018-01-01 05:35:06 ddr Exp $ -->
+  <meta charset="utf-8">
+  <meta name="robots" content="none">
+  <link rel="shortcut icon" href="images/favicon_gwsetup.png">
+
+  <title>[Background image]
+</title>
+%fsetup.css;
+</head>
+
+<body %Vbody_prop;>
+
+<div style="background:url('images/gwlogo.png') no-repeat left top; text-align:center; height:95px; line-height:95px; color:#2f6400;">
+<h1 style="margin:0;">
+[Background image]
+</h1>
+</div>
+
+<ul>
+
+<li>
+[To specify a background image for the database "%o", you have to write it:]
+
+<pre>
+     background="gwd%t{.exe}?m=IM;v=/[foo.jpg]"
+</pre>
+
+<p />
+
+[replacing "<tt>foo.jpg</tt>" by the real name of your image file.]
+
+<p />
+
+<li>
+[Put the image file in the directory (possibly create it before):]
+
+<pre>
+     gw%/images
+</pre>
+
+</ul>

bin/setup/lang/bsc.htm

@@ -0,0 +1,39 @@
+<!DOCTYPE html>
+<html lang="%l">
+<head>
+  <!-- Copyright (c) 1998-2006 INRIA - GeneWeb -->
+  <!-- $Id: bsi.htm,v 5.1 2006-01-01 05:35:06 ddr Exp $ -->
+  <meta charset="utf-8">
+  <meta name="robots" content="none">
+  <link rel="shortcut icon" href="images/favicon_gwsetup.png">
+
+  <title>[Application of "%d"]
+</title>
+%fsetup.css;
+</head>
+
+<body %Vbody_prop;>
+
+<div style="background:url('images/gwlogo.png') no-repeat left top; text-align:center; height:95px; line-height:95px; color:#2f6400;">
+<h1 style="margin:0;">[Application of "%d"]</h1>
+</div>
+[The operation "%d" will be applied on your database "%a". Warning: it can take some seconds or some minutes, depending on the case. Be patient.]
+%(
+The operation "%d" will be applied on your database "%a". Warning: it can take s
+ome seconds or some minutes, depending on the case. Be patient.
+%)
+<p>
+[Push this button to start][:]
+<p>
+<form method="post" action="connex_1">
+%h
+<dl><dt><dd><input type="submit" value="Ok" /></dl>
+</form>
+<p>
+[For information, this operation corresponds to the following commands][:]
+<pre>
+     $ cd "%w"
+     $ %x%/%d%p > comm.log
+</pre>
+</body>
+</html>

bin/setup/lang/bsi.htm

@@ -0,0 +1,44 @@
+<!DOCTYPE html>
+<html lang="%l">
+<head>
+  <!-- Copyright (c) 1998-2006 INRIA - GeneWeb -->
+  <!-- $Id: bsi.htm,v 5.1 2006-01-01 05:35:06 ddr Exp $ -->
+  <meta charset="utf-8">
+  <meta name="robots" content="none">
+  <link rel="shortcut icon" href="images/favicon_gwsetup.png">
+
+  <title>[Application of "%d"]
+</title>
+%fsetup.css;
+</head>
+
+<body %Vbody_prop;>
+
+<div style="background:url('images/gwlogo.png') no-repeat left top; text-align:center; height:95px; line-height:95px; color:#2f6400;">
+<h1 style="margin:0;">[Application of "%d"]</h1>
+</div>
+[The operation "%d" will be applied on your database "%a". Warning: it can take some seconds or some minutes, depending on the case. Be patient.]
+%(
+The operation "%d" will be applied on your database "%a". Warning: it can take s
+ome seconds or some minutes, depending on the case. Be patient.
+%)
+<p>
+[Push this button to start][:]
+<p>
+<form method="post" action="%d">
+%h
+<dl><dt><dd><input type="submit" value="Ok" /></dl>
+</form>
+<p>
+[For information, this operation corresponds to the following commands][:]
+<pre>
+     $ cd "%w"
+     $ %x%/%d%p > comm.log
+</pre>
+[<span style="color:#FF0000;">WARNING</span>: The content of file %o will be overwritten.]
+%(
+<span style="color:#FF0000;">WARNING</span>: The content of file %o will be over
+written.
+%)
+</body>
+</html>

bin/setup/lang/bsi_cache_files.htm

@@ -0,0 +1,42 @@
+<!DOCTYPE html>
+<html lang="%l">
+<head>
+  <!-- Copyright (c) 1998-2023 - GeneWeb -->
+  <!-- $Id: bsi_cache_files.htm,v 7.10 2023.11.15 hg Exp $ -->
+  <meta charset="utf-8">
+  <meta name="robots" content="none">
+  <link rel="shortcut icon" href="images/favicon_gwsetup.png">
+
+  <title>[Application of "%d"]
+</title>
+%fsetup.css;
+</head>
+
+<body %Vbody_prop;>
+
+<div style="background:url('images/gwlogo.png') no-repeat left top; text-align:center; height:95px; line-height:95px; color:#2f6400;">
+<h1 style="margin:0;">[Application of "%d"]</h1>
+</div>
+
+[applied operation]
+%(
+en: The operation "%d" will be applied on your database "%a". Warning: it
+    can take some seconds or some minutes, depending on the case. Be
+    patient.
+%)
+
+<p>
+[click on ok]
+<p>
+<form method="post" action="%d">
+%h
+<dl><dt><dd><input type="submit" value="Ok" /></dl>
+</form>
+<p>
+[commands]
+%(
+en: For information, this operation corresponds to the following commands:
+%)
+<pre>
+     $ %x%/%d%S
+</pre>

bin/setup/lang/bsi_connex.htm

@@ -0,0 +1,43 @@
+<!DOCTYPE html>
+<html lang="%l">
+<head>
+  <!-- Copyright (c) 1998-2006 INRIA - GeneWeb -->
+  <!-- $Id: bsi_connex.htm,v 7.00 2018_04_10 05:35:06 hg Exp $ -->
+  <meta charset="utf-8">
+  <meta name="robots" content="none">
+  <link rel="shortcut icon" href="images/favicon_gwsetup.png">
+
+  <title>[Application of "%d"]
+</title>
+%fsetup.css;
+</head>
+
+<body %Vbody_prop;>
+
+<div style="background:url('images/gwlogo.png') no-repeat left top; text-align:center; height:95px; line-height:95px; color:#2f6400;">
+<h1 style="margin:0;">[Application of "%d"]</h1>
+</div>
+[The operation "%d" will be applied on your database "%a". Warning: it can take some seconds or some minutes, depending on the case. Be patient.]
+%(
+The operation "%d" will be applied on your database "%a". Warning: it can take some
+seconds or some minutes, depending on the case. Be patient.
+%)
+<p>
+[<span style="color:#FF0000;">WARNING</span>: the -del command suppresses irreversibly some families. It may be prudent to have a backup archive.]
+%(
+<span style="color:#FF0000;">WARNING</span>: the -del command suppresses irreversibly
+some families. It may be prudent to have a backup archive.
+%)
+<p >
+[Push this button to start][:]
+<form method="post" action="%d">
+%h
+<dl><dt><dd><input type="submit" value="Ok"></dl>
+</form>
+<p>
+[For information, this operation corresponds to the following commands][:]
+<pre>
+     $ %x%/%d %Q
+</pre>
+</body>
+</html>

bin/setup/lang/bsi_diff.htm

@@ -0,0 +1,43 @@
+<!DOCTYPE html>
+<html lang="%l">
+<head>
+  <!-- Copyright (c) 1998-2006 INRIA - GeneWeb -->
+  <!-- $Id: bsi_diff.htm,v 7.00 2018_04_10 05:35:06 hg Exp $ -->
+  <meta charset="utf-8">
+  <meta name="robots" content="none">
+  <link rel="shortcut icon" href="images/favicon_gwsetup.png">
+
+  <title>[Application of "%d"]
+</title>
+%fsetup.css;
+</head>
+
+<body %Vbody_prop;>
+
+<div style="background:url('images/gwlogo.png') no-repeat left top; text-align:center; height:95px; line-height:95px; color:#2f6400;">
+<h1 style="margin:0;">[Application of "%d"]</h1>
+</div>
+[The operation "%d" will be applied on your database "%a". Warning: it can take some seconds or some minutes, depending on the case. Be patient.]
+%(
+The operation "%d" will be applied on your database "%a". Warning: it can take some 
+seconds or some minutes, depending on the case. Be patient.
+%)
+<p>
+[<span style="color:#FF0000;">WARNING</span>: the -del command suppresses irreversibly some families. It may be prudent to have a backup archive.]
+%(
+<span style="color:#FF0000;">WARNING</span>: the -del command suppresses irreversibly
+some families. It may be prudent to have a backup archive.
+%)
+<p>
+[Push this button to start][:]
+<form method="post" action="%d">
+%h
+<dl><dt><dd><input type="submit" value="Ok"></dl>
+</form>
+<p>
+[For information, this operation corresponds to the following commands][:]
+<pre>
+     $ %x%/%d %R > comm.log
+</pre>
+</body>
+</html>

bin/setup/lang/bsi_err.htm

@@ -0,0 +1,43 @@
+<!DOCTYPE html>
+<html lang="%l">
+<head>
+  <!-- Copyright (c) 1998-2006 INRIA - GeneWeb -->
+  <!-- $Id: bsi_err.htm,v 7.00 2018-01-01 05:35:06 ddr Exp $ -->
+  <meta charset="utf-8">
+  <meta name="robots" content="none">
+  <link rel="shortcut icon" href="images/favicon_gwsetup.png">
+
+  <title>[error]
+</title>
+%fsetup.css;
+</head>
+
+<body %Vbody_prop;>
+
+<div style="background:url('images/gwlogo.png') no-repeat left top; text-align:center; height:95px; line-height:95px; color:#2f6400;">
+<h1 style="margin:0;"><font color=red>[error]
+</font></h1>
+</div>
+[The command "%d" exited with an error code. This operation may have not been done.]
+<p>
+[Here are the traces of the command, maybe you can find an explanation][:]
+<p>
+<dl><dt><dd>
+<pre>
+%g{- [no traces]
+-}
+</pre>
+</dl>
+<p>
+[And the content of gwsetup.log]
+<p>
+<dl><dt><dd>
+<pre>
+%G{- [no traces]
+-}
+</pre>
+</dl>
+<p>
+[Return to the main menu.] (<a href="gwsetup?lang=%l;v=welcome.htm">welcome</a>)
+</body>
+</html>

bin/setup/lang/bsi_fix.htm

@@ -0,0 +1,44 @@
+<!DOCTYPE html>
+<html lang="%l">
+<head>
+  <!-- Copyright (c) 1998-2006 INRIA - GeneWeb -->
+  <!-- $Id: bsi_fix.htm,v 7.00 2018_04_10 05:35:06 hg Exp $ -->
+  <meta charset="utf-8">
+  <meta name="robots" content="none">
+  <link rel="shortcut icon" href="images/favicon_gwsetup.png">
+
+  <title>[Application of "%d"]
+</title>
+%fsetup.css;
+</head>
+
+<body %Vbody_prop;>
+
+<div style="background:url('images/gwlogo.png') no-repeat left top; text-align:center; height:95px; line-height:95px; color:#2f6400;">
+<h1 style="margin:0;">[Application of "%d"]</h1>
+</div>
+[The operation "%d" will be applied on your database "%a". Warning: it can take some seconds or some minutes, depending on the case. Be patient.]
+%(
+The operation "%d" will be applied on your database "%a". Warning: it can take some
+seconds or some minutes, depending on the case. Be patient.
+%)
+<p>
+[<span style="color:#FF0000;">WARNING</span>: this command modifies the base irreversibly. It may be prudent to have a backup archive.]
+%(
+<span style="color:#FF0000;">WARNING</span>: this command modifies the base irreversibly.
+It may be prudent to have a backup archive.
+%)
+<p>
+[Push this button to start][:]
+<p>
+<form method="post" action="%d">
+%h
+<dl><dt><dd><input type="submit" value="Ok" /></dl>
+</form>
+<p>
+[For information, this operation corresponds to the following commands][:]
+<pre>
+     $ %x%/%d %p > comm.log
+</pre>
+</body>
+</html>

bin/setup/lang/bso.htm

@@ -0,0 +1,63 @@
+<!DOCTYPE html>
+<html lang="%l">
+<head>
+  <!-- Copyright (c) 1998-2006 INRIA - GeneWeb -->
+  <!-- $Id: bso.htm,v 7.00 2018-02-25 02:32:19 ddr Exp $ -->
+  <meta charset="utf-8">
+  <meta name="robots" content="none">
+  <link rel="shortcut icon" href="images/favicon_gwsetup.png">
+
+  <title>[Creation of a database]
+</title>
+%fsetup.css;
+</head>
+
+<body %Vbody_prop;>
+
+<div style="background:url('images/gwlogo.png') no-repeat left top; text-align:center; height:95px; line-height:95px; color:#2f6400;">
+<h1 style="margin:0;">[Creation of a database]</h1>
+</div>
+<p>
+<ul>
+%v{<li>
+[Warning: there already exists a database with the name "%o" in your directory. If you push the button "Ok" below, it will be erased.]
+%(
+Warning: there already exists a database with the name "%o" in your directory.
+If you push the button "Ok" below, it will be erased.
+%)
+<p>
+[If you just made this, it is probably its result, and therefore it is not important. Else, return to the previous page and choose another name for your database.]
+%(
+If you just made this, it is probably its result, and therefore it is not important. 
+Else, return to the previous page and choose another name for your database.
+%)
+<p>}
+<li>
+[We are going to create a database named "%o". Remark: this operation can answer in the twinkling of a eye or take some tenths of seconds or some minutes, depending on the cases. Be patient.]
+%(
+We are going to create a database named "%o". Remark: this operation can answer 
+in the twinkling of a eye or take some tenths of seconds or some minutes, depend
+ing on the cases. Be patient.
+%)
+<p >
+[Push the button below to create you database]
+%v{<br><blink><font color=red>[, and overwrite the previous database "%o" of the target directory]
+</font></blink>}:
+<p>
+<form method="post" action="%d">
+%h
+<dl><dt><dd>
+<input type="submit" value="Ok">
+<input type="submit" name="cancel" value="[cancel]">
+</dl>
+</form>
+<p>
+[For information, this operation corresponds to the following commands][:]
+<pre>
+     $ cd "%w"
+     $ %x%/%d%p > comm.log
+</pre>
+[This builds a directory named "%o.gwb".]
+</ul>
+</body>
+</html>

bin/setup/lang/bso_comm.htm

@@ -0,0 +1,36 @@
+<!DOCTYPE html>
+<html lang="%l">
+<head>
+  <!-- Copyright (c) 1998-2006 INRIA - GeneWeb -->
+  <!-- $Id: bso_comm.htm,v 7.00 2018-04-10 05:35:06 hg Exp $ -->
+  <meta charset="utf-8">
+  <meta name="robots" content="none">
+  <link rel="shortcut icon" href="images/favicon_gwsetup.png">
+
+  <title>[Content of comm.log]
+</title>
+%fsetup.css;
+</head>
+
+<body %Vbody_prop;>
+
+<div style="background:url('images/gwlogo.png') no-repeat left top; text-align:center; height:95px; line-height:95px; color:#2f6400;">
+<h1 style="margin:0;">
+[Content of comm.log]
+</h1>
+</div>
+
+<p />
+
+<dl><dt><dd>
+<pre>
+%g{- [empty file]
+-}
+</pre>
+</dl>
+
+contenu d'un autre fichier (%o) :
+
+%H
+
+done

bin/setup/lang/bso_err.htm

@@ -0,0 +1,27 @@
+<!DOCTYPE html>
+<html lang="%l">
+<head>
+  <!-- Copyright (c) 1998-2006 INRIA - GeneWeb -->
+  <!-- $Id: bso_err.htm,v 7.00 2018-01-01 05:35:06 ddr Exp $ -->
+  <meta charset="utf-8">
+  <meta name="robots" content="none">
+  <link rel="shortcut icon" href="images/favicon_gwsetup.png">
+
+  <title>[error]
+</title>
+%fsetup.css;
+</head>
+
+<body %Vbody_prop;>
+
+<div style="background:url('images/gwlogo.png') no-repeat left top; text-align:center; height:95px; line-height:95px; color:#2f6400;">
+<h1 style="margin:0;"><font color=red>[error]
+</font></h1>
+</div>
+<p>
+[The previous command exited with an error code. Your database may have not been created.]
+<p>
+[Look at the traces, maybe you can find an explanation.]
+(<a href="gwsetup?lang=%l;v=traces.htm">traces</a>)
+<p>
+[Return to the main menu.] (<a href="gwsetup?lang=%l;v=welcome.htm">welcome</a>)

bin/setup/lang/bso_log.htm

@@ -0,0 +1,30 @@
+<!DOCTYPE html>
+<html lang="%l">
+<head>
+  <!-- Copyright (c) 1998-2006 INRIA - GeneWeb -->
+  <!-- $Id: bso_log.htm,v 7.00 2018-04-10 05:35:06 hg Exp $ -->
+  <meta charset="utf-8">
+  <meta name="robots" content="none">
+  <link rel="shortcut icon" href="images/favicon_gwsetup.png">
+
+  <title>[Content of result file]
+</title>
+%fsetup.css;
+</head>
+
+<body %Vbody_prop;>
+
+<div style="background:url('images/gwlogo.png') no-repeat left top; text-align:center; height:95px; line-height:95px; color:#2f6400;">
+<h1 style="margin:0;">
+[Content of result file]
+</h1>
+</div>
+
+<p />
+
+<dl><dt><dd>
+<pre>
+%H{- [empty file]
+-}
+</pre>
+</dl>

bin/setup/lang/bso_ok.htm

@@ -0,0 +1,36 @@
+<!DOCTYPE html>
+<html lang="%l">
+<head>
+  <!-- Copyright (c) 1998-2006 INRIA - GeneWeb -->
+  <!-- $Id: bso_ok.htm,v 7.00 2018-01-01 05:35:06 ddr Exp $ -->
+  <meta charset="utf-8">
+  <meta name="robots" content="none">
+  <link rel="shortcut icon" href="images/favicon_gwsetup.png">
+
+  <title>[Database created]
+</title>
+%fsetup.css;
+</head>
+
+<body %Vbody_prop;>
+
+<div style="background:url('images/gwlogo.png') no-repeat left top; text-align:center; height:95px; line-height:95px; color:#2f6400;">
+<h1 style="margin:0;">[Database created]</h1>
+</div>
+<p>
+[Done. The operation is terminated. Your database named "%o" is created.]
+<p>
+[To consult your database, and possibly modify it, the gwd service must have been launched.]
+<p>
+[If it is, try the address below. The displayed page is called "welcome page" of your database. Bookmark it.]
+<p>
+<ul>
+<li><a
+href="http://%m:%P/%o">http://%m:%P/%o</a>
+</ul>
+<p>
+[Return to the main menu.] (<a href="gwsetup?lang=%l;v=welcome.htm">welcome</a>)
+<p>
+[Read the alert messages in the file "comm.log"] (<a href="gwsetup?lang=%l;v=bso_comm.htm">comm.log</a>)
+</body>
+</html>

bin/setup/lang/cache_files.htm

@@ -0,0 +1,123 @@
+<!DOCTYPE html>
+<html lang="%l">
+<head>
+  <!-- Copyright (c) 1998-2023 - GeneWeb -->
+  <!-- $Id: cache_files.htm,v 7.10 2023.11.15 hg Exp $ -->
+  <meta charset="utf-8">
+  <meta name="robots" content="none">
+  <link rel="shortcut icon" href="images/favicon_gwsetup.png">
+
+  <title>[cache files]</title>
+%fsetup.css;
+</head>
+
+<body %Vbody_prop;>
+<div style="background:url('images/gwlogo.png') no-repeat left top; text-align:center; height:95px; line-height:95px; color:#2f6400;">
+<h1 style="margin:0;">
+[cache files title]
+</h1>
+<p>
+</div>
+<div>
+<ul>
+<li>
+<form method="get" action="cache_files">
+<input type=hidden name=opt value=check>
+<input type="hidden" name="lang" value="%l">
+
+[select base]
+<p>
+<table class="setup">
+%b{
+<tr align="left">
+<td><input type="radio" name="anon" value="%a">&nbsp;&nbsp;&nbsp;</td>
+<td><a href="http://%m:%P/%a">%a</a></td>
+</tr>|
+<tr align="left"><td>- [no base provided]</tr></td>}
+</table></dl>
+<p>
+<li>
+[select options]
+<p>
+<table class="setup">
+<tr align="left">
+<td><input type="checkbox" name="fn" id="sn" value="on">
+<label for="fn" style="font-family: monospace">-fn&nbsp;&nbsp;</label>[first_names]
+</td>
+</tr>
+</table></dl>
+<p>
+<table class="setup">
+<tr align="left">
+<td><input type="checkbox" name="sn" id="sn" value="on">
+<label for="sn" style="font-family: monospace">-sn&nbsp;&nbsp;</label>[surnames]
+</td>
+</tr>
+</table></dl>
+<p>
+<table class="setup">
+<tr align="left">
+<td>
+<td><input type="checkbox" name="al" id="al" value="on">
+<label for="al" style="font-family: monospace">-al&nbsp;&nbsp;</label>[aliases]
+</td>
+</tr>
+</table></dl>
+<p>
+<table class="setup">
+<tr align="left">
+<td>
+<td><input type="checkbox" name="qu" id="qu" value="on">
+<label for="qu" style="font-family: monospace">-qu&nbsp;&nbsp;</label>[qualifiers]
+</td>
+</tr>
+</table></dl>
+<p>
+<table class="setup">
+<tr align="left">
+<td>
+<td><input type="checkbox" name="pl" id="pl" value="on">
+<label for="pl" style="font-family: monospace">-pl&nbsp;&nbsp;</label>[places]
+</td>
+</tr>
+</table></dl>
+<p>
+<table class="setup">
+<tr align="left">
+<td>
+<td><input type="checkbox" name="all" id="all" value="on" checked>
+<label for="all" style="font-family: monospace">-all&nbsp;&nbsp;</label>[all]
+</td>
+</tr>
+</table></dl>
+<p>
+<table class="setup">
+<tr align="left">
+<td><input type="checkbox" name="fna" id="fna" value="on">
+<label for="fna" style="font-family: monospace">-fna&nbsp;&nbsp;</label>[fn alias]
+</td>
+</tr>
+</table></dl>
+<p>
+<table class="setup">
+<tr align="left">
+<td>
+<td><input type="checkbox" name="prog" id="prog" value="on">
+<label for="prog" style="font-family: monospace">-prog&nbsp;&nbsp;</label>[progress]
+</td>
+</tr>
+</table></dl>
+
+
+<p>
+<li>
+[ok]
+</li>
+
+<input type="submit" value="Ok">
+</dl>
+</form>
+</ul>
+</div>
+</body>
+</html>

bin/setup/lang/cache_files_ok.htm

@@ -0,0 +1,24 @@
+<!DOCTYPE html>
+<head>
+  <!-- Copyright (c) 1998-2023- GeneWeb -->
+  <!-- $Id: cache_files_ok.htm,v 7.10 2023.11.15 hg Exp $ -->
+  <meta charset="utf-8">
+  <meta name="robots" content="none">
+  <link rel="shortcut icon" href="images/favicon_gwsetup.png">
+
+  <title>[cache files compute]
+</title>
+%fsetup.css;
+</head>
+
+<body %Vbody_prop;">
+
+<div style="background:url('images/gwlogo.png') no-repeat left top; text-align:center; height:95px; line-height:95px; color:#2f6400;">
+<h1 style="margin:0;">
+[cache file compute]
+</h1>
+</div>
+
+<p />
+[return]
+

bin/setup/lang/clean_ok.htm

@@ -0,0 +1,33 @@
+<!DOCTYPE html>
+<html lang="%l">
+<head>
+  <!-- Copyright (c) 1998-2006 INRIA - GeneWeb -->
+  <!-- $Id: clean_ok.htm,v 5.1 2006-01-01 05:35:06 ddr Exp $ -->
+  <meta charset="utf-8">
+  <meta name="robots" content="none">
+  <link rel="shortcut icon" href="images/favicon_gwsetup.png">
+
+  <title>[Operation completed]
+</title>
+%fsetup.css;
+</head>
+
+<body %Vbody_prop;>
+
+<div style="background:url('images/gwlogo.png') no-repeat left top; text-align:center; height:95px; line-height:95px; color:#2f6400;">
+<h1 style="margin:0;">[Operation completed]</h1>
+</div>
+<p>
+[The cleaning up of you database "%a" is completed.]
+<p>
+[Your database has been completely rebuilt: the old version is on the subdirectory "old" of the directory "%w". You can recover it in case of problem.]
+%(
+Your database has been completely rebuilt: the old version is on the subdirector
+y "old" of the directory "%w". You can recover it in case of problem.
+%)
+<p>
+[You can consult your very clean new database][:]
+<p>
+<ul><li><a href="http://%m:%P/%a">http://%m:%P/%a</a></ul>
+<p>
+[Return to the main menu.] (<a href="gwsetup?lang=%l;v=welcome.htm">gesetup</a>)

bin/setup/lang/cleanup.htm

@@ -0,0 +1,58 @@
+<!DOCTYPE html>
+<html lang="%l">
+<head>
+  <!-- Copyright (c) 1998-2006 INRIA - GeneWeb -->
+  <!-- $Id: cleanup.htm,v 7.00 2018-04-20 05:35:06 ddr Exp $ -->
+  <meta charset="utf-8">
+  <meta name="robots" content="none">
+  <link rel="shortcut icon" href="images/favicon_gwsetup.png">
+
+  <title>[Cleanup]
+</title>
+%fsetup.css;
+</head>
+
+<body %Vbody_prop;>
+
+<div style="background:url('images/gwlogo.png') no-repeat left top; text-align:center; height:95px; line-height:95px; color:#2f6400;">
+<h1 style="margin:0;">
+[Cleaning up a database]
+</h1>
+</div>
+
+[If you made many modifications in your database, or if you simply entered much data, it is advised to make a cleaning up, especially if you observe that the access to your database has slowed down.]
+%(
+If you made many modifications in your database, or if you simply entered much d
+ata, it is advised to make a cleaning up, especially if you observe that the acc
+ess to your database has slowed down.
+%)
+<p>
+<ul><li>
+[For a simple cleaning up, apply the initialisation of consanguinities.]
+(<a href="gwsetup?lang=%l;v=consang.htm">consang</a>)
+<p >
+<li>
+<form method="get" action="cleanup">
+<input type="hidden" name="lang" value="%l" />
+
+[For a radical cleaning up, select your database by clicking on the associated button][:]
+<p>
+<table class="setup">
+%b{
+<tr align="left">
+<td><input type="radio" name="anon" value="%a" />   </td>
+<td><a href="http://%m:%P/%a">%a</a></td>
+</tr>|
+<tr align="left"><td>- [there is no database at present]
+</tr></td>}
+</table>
+<p>
+<li>
+[Then push this button][:]
+<p>
+<input type="submit" value="[Cleanup]
+" />
+
+</form>
+
+</ul>

bin/setup/lang/cleanup1.htm

@@ -0,0 +1,48 @@
+<!DOCTYPE html>
+<html lang="%l">
+<head>
+  <!-- Copyright (c) 1998-2006 INRIA - GeneWeb -->
+  <!-- $Id: cleanup1.htm,v 7.00 2018-01-01 05:35:06 ddr Exp $ -->
+  <meta charset="utf-8">
+  <meta name="robots" content="none">
+  <link rel="shortcut icon" href="images/favicon_gwsetup.png">
+
+  <title>[Cleanup - Phase 2]
+</title>
+%fsetup.css;
+</head>
+
+<body %Vbody_prop;>
+
+<div style="background:url('images/gwlogo.png') no-repeat left top; text-align:center; height:95px; line-height:95px; color:#2f6400;">
+<h1 style="margin:0;">[Cleanup]</h1>
+</div>
+<p>
+[We are going to proceed to the cleaning up of the database "%a".]
+<p>
+[Warning: this operation can take some seconds or minutes, depending on the cases. Be patient.]
+<p>
+[Push this button to start][:]
+<p>
+<form method="post" action="cleanup_1">
+%h
+<dl><dt><dd><input type="submit" value="Ok" /></dl>
+</form>
+<p>
+[For information, this operation corresponds to the following commands][:]
+<pre>
+     $ cd "%w"
+     $ %x%/gwu %a -o tmp.gw
+     $ mkdir old
+     [Under Unix][:]
+        $ rm -rf old/%a.gwb
+        $ mv %a.gwb old/.
+     [Under MSdos][:]
+        $ del old\%a.gwb\*.*
+        $ rmdir old\%a.gwb
+        $ move %a.gwb old\.
+     $ %x%/gwc tmp.gw -nofail -o %a > comm.log
+</pre>
+</body>
+</html>
+

bin/setup/lang/connex.htm

@@ -0,0 +1,147 @@
+<!DOCTYPE html>
+<html lang="%l">
+<head>
+  <!-- Copyright (c) 1998-2006 INRIA - GeneWeb -->
+  <!-- $Id: connex.htm,v 7.00 2018-04-09 05:35:06 hg Exp $ -->
+  <meta charset="utf-8">
+  <meta name="robots" content="none">
+  <link rel="shortcut icon" href="images/favicon_gwsetup.png">
+
+  <title>[Connex]
+</title>
+%fsetup.css;
+</head>
+
+<body %Vbody_prop;>
+<div style="background:url('images/gwlogo.png') no-repeat left top; text-align:center; height:95px; line-height:95px; color:#2f6400;">
+<h1 style="margin:0;">
+[Listing connected components]
+</h1>
+</div>
+<ul>
+<li>
+<form method="get" action="connex">
+<input type="hidden" name="opt" value="check">
+<input type="hidden" name="lang" value="%l">
+<input type="hidden" name="server" value="%m">
+<input type="hidden" name="gwd_p" value="%P">
+[Select your database by clicking on the associated button][:]
+<p>
+<table class="setup">
+%b{
+<tr align="left">
+<td><input type="radio" name="anon" value="%a">&nbsp;&nbsp;&nbsp;</td>
+<td><a href="http://%m:%P/%a">%a</a></td>
+</tr>|
+<tr align="left"><td>- [there is no database at present]
+</tr></td>}
+</table></dl>
+<p>
+<li>
+[Select the options you want][:]
+<p>
+<table class="setup">
+<tr align="left">
+<td><input type="checkbox" name="a" id="a" value="on">
+<label for="a" style="font-family: monospace">-a&nbsp;&nbsp;</label>[All connex components.]
+</td>
+</tr>
+</table></dl>
+<p>
+<table class="setup">
+<tr align="left">
+<td><input type="checkbox" name="s" id="s" value="on">
+<label for="s" style="font-family: monospace">-s&nbsp;&nbsp;</label>[Produce connected components statistics.]
+</td>
+</tr>
+</table></dl>
+<p>
+<table class="setup">
+<tr align="left">
+<td>
+<label for="d_1" style="font-family: monospace">-d&nbsp;&nbsp;
+<input type="input" name="d" size="2" maxlength="2" style="padding-left:4px">
+</label>&nbsp;&nbsp;[Details for this length.]
+</td>
+</tr>
+</table></dl>
+<p>
+<table class="setup">
+<tr align="left">
+<td>
+<label for="i" style="font-family: monospace">-i&nbsp;&nbsp;
+<input type="input" name="i" size="20" maxlength="50" style="padding-left:4px"></label>&nbsp;&nbsp;[Ignore this file.]
+</td>
+</tr>
+</table></dl>
+<p>
+<table class="setup">
+<tr align="left">
+<td><input type="checkbox" name="bf" id="bf" value="on">
+<label for="bf" style="font-family: monospace">-bf&nbsp;&nbsp;</label>[By origin file.]
+</td>
+</tr>
+</table></dl>
+<p>
+[<span style="color:#FF0000;">WARNING</span>: The following three options result in irreversible deletions. Having a backup archive is recommended.]
+%(
+<span style="color:#FF0000;">WARNING</span>: The following three options result 
+in irreversible deletions. Having a backup archive is recommended.
+%)
+<p>
+<table class="setup">
+<tr align="left">
+<td>
+<label for="del_1" style="font-family: monospace">-del
+<input type="input" name="del" size="5" maxlength="2" style="padding-left:4px"></label>&nbsp;&nbsp;[Ask for deleting branches whose size <= that value.]
+</td>
+</tr>
+</table></dl>
+<p>
+<table class="setup">
+<tr align="left">
+<td>
+<label for="cnt_1" style="font-family: monospace">-cnt
+<input type="input" name="cnt" size="5" maxlength="2" style="padding-left:4px"></label>&nbsp;&nbsp;[Specifiy the number of branches to be deleted.]
+</td>
+</tr>
+</table></dl>
+<p>
+<table class="setup">
+<tr align="left">
+<td><input type="checkbox" name="exact" id="exact" value="on">
+<label for="exact" style="font-family: monospace">-exact&nbsp;&nbsp;</label>[Restrict deleting branches whose size = -del.]
+</td>
+</tr>
+</table></dl>
+<p>
+<table class="setup">
+<tr align="left">
+<td>
+<input type="radio" name="o" id="o" value="choice">
+<label for="o1" style="font-family: monospace">-o &nbsp;
+<input type="input" name="o1" size="20" maxlength="50" style="padding-left:4px"></label>&nbsp;&nbsp;[Output results to this file.]
+</td>
+</tr>
+<p>
+<tr align="left">
+<td><input type="radio" name="o" id="o" value="/notes_d/connex.txt">
+<label for="o" style="font-family: monospace">&nbsp;&nbsp;</label>
+[Output results in basename/notes_d/connex.txt (-o must stay empty and notes_d must exist).]
+</td>
+</tr>
+<p>
+<tr align="left">
+<td><input type="radio" name="o" id="o" value="" checked/>
+<label for="o" style="font-family: monospace">&nbsp;&nbsp;</label>[No redirection of results.]
+</td>
+</tr>
+</table></dl>
+<p>
+<li>
+[Then click on this button][:]
+</li>
+<input type="submit" value="Ok">
+</dl>
+</form>
+</ul>

bin/setup/lang/connex_ok.htm

@@ -0,0 +1,43 @@
+<!DOCTYPE html>
+<head>
+  <!-- Copyright (c) 1998-2006 INRIA - GeneWeb -->
+  <!-- $Id: connex_ok.htm,v 7.00 2018-04-10 05:35:06 hg Exp $ -->
+  <meta charset="utf-8">
+  <meta name="robots" content="none">
+  <link rel="shortcut icon" href="images/favicon_gwsetup.png">
+
+  <title>[Connected components identified]
+</title>
+%fsetup.css;
+</head>
+
+<body %Vbody_prop;">
+
+<div style="background:url('images/gwlogo.png') no-repeat left top; text-align:center; height:95px; line-height:95px; color:#2f6400;">
+<h1 style="margin:0;">
+[Connected components identified]
+</h1>
+</div>
+[You may observe results through two means][:]
+<ul>
+<li>
+[By looking at the terminal window if you have not asked for result redirection.]
+<li>
+%Io1;;{
+[Using <b>gwd</b> to visualize the file in the NOTES folder of your base where you have redirected output (%a.gwb/notes_d/connex.txt).<br> This file contains the last set of data stored at this location (which is not necessarily the one you have just computed - see the time stamp at the head of the file).<br> This solution allows you to follow links to designated persons.]
+(<a href="http://%m:%P/%a?w=w;lang=%l;m=NOTES;f=connex">connex.txt</a>)
+%(
+Using <b>gwd</b> to visualize the file in the NOTES folder of your base
+where you have redirected output (%a.gwb/notes_d/connex.txt).<br>
+This file contains the last set of data stored at this location
+(which is not necessarily the one you have just computed -see the
+time stamp at the head of the file).<br>
+This solution allows you to follow links to designated persons.
+%)
+|
+[Using <b>gwsetup</b> to visualize the file in which results were redirected ("%K").]
+(<a href="gwsetup?lang=%l;o=%K;v=bso_log.htm">log</a>)
+}
+</ul>
+<p>
+[Return to the main menu.] (<a href="gwsetup?lang=%l;v=welcome.htm">welcome</a>)

bin/setup/lang/consang.htm

@@ -0,0 +1,60 @@
+<!DOCTYPE html>
+<html lang="%l">
+<head>
+  <!-- Copyright (c) 1998-2006 INRIA - GeneWeb -->
+  <!-- $Id: consang.htm,v 7.00 2018-04-20 05:35:06 ddr Exp $ -->
+  <meta charset="utf-8">
+  <meta name="robots" content="none">
+  <link rel="shortcut icon" href="images/favicon_gwsetup.png">
+
+  <title>[Consanguinities]
+</title>
+%fsetup.css;
+</head>
+
+<body %Vbody_prop;>
+
+<div style="background:url('images/gwlogo.png') no-repeat left top; text-align:center; height:95px; line-height:95px; color:#2f6400;">
+<h1 style="margin:0;">[Consanguinities]</h1>
+</div>
+[The initialization of consanguinities is necessary so that the consanguinities are displayed when browsing the database.]
+%(
+The initialization of consanguinities is necessary so that the consanguinities
+are displayed when browsing the database.
+%)
+<p >
+<form method="get" action="consang">
+<input type="hidden" name="opt" value="check">
+<input type="hidden" name="lang" value="%l">
+<input type="hidden" name="q" value="on">
+<ul><li>
+[Select your database by clicking on the associated button][:]
+<p>
+<table class="setup">
+%b{
+<tr align="left">
+<td>
+<input type="radio" name="anon" value="%a">   </td>
+<td><a href="http://%m:%P/%a">%a</a></td>
+</tr>|
+<tr align="left">
+<td>- [there is no database at present]
+</tr></td>}
+</table>
+<p>
+<li>
+[Select the options you want][:]
+<p >
+<table class="setup">
+<tr align="left">
+<td><input type="checkbox" name="scratch" value="on" />   </td>
+<td>[Restart the computing from scratch.]
+</td></tr>
+</table>
+<p>
+<li>
+[Then click on this button][:]
+<p>
+<input type="submit" value="[Consang]">
+</ul>
+</form>